mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Update Makefile.am's; remove slib import

Browse source 
* Makefile.am:
* module/Makefile.am:
* module/language/scheme/Makefile.am:
* module/system/Makefile.am:
* module/system/base/Makefile.am:
* module/system/il/Makefile.am:
* module/system/repl/Makefile.am:
* module/system/vm/Makefile.am: Cleaned up to be more complete, if not
  completely working.

* module/guile/slib.scm:
* module/slib/: Removed the slib import; it's a bit out of place here,
  and bitrotten at that.
This commit is contained in:
Andy Wingo 2008-05-13 00:07:40 +02:00
parent 0a5db6e11d
commit 83dff6e55f
176 changed files with 7 additions and 62200 deletions
Download patch file Download diff file Expand all files Collapse all files

1
Makefile.am
View file

@ -1,4 +1,5 @@
SUBDIRS = src doc testsuite
DIST_SUBDIRS = src module doc testsuite
# FIXME: The `module' directory is removed from `SUBDIRS' until it can
# actually be built.

16
module/Makefile.am
View file

@ -1,15 +1 @@
SUBDIRS = system
DISTDIRS = $(srcdir)/system $(srcdir)/language $(srcdir)/guile $(srcdir)/slib
EXCLUDES = --exclude=CVS --exclude=*.go --exclude=*~
all: slibcat
clean:
rm -f slibcat slib/*.go
slibcat:
guile -s $(top_srcdir)/src/guilec slib/*.scm
dist-hook:
$(TAR) cf - $(EXCLUDES) $(DISTDIRS) | (cd $(distdir); $(TAR) xf -)
SUBDIRS = system language

40
module/guile/slib.scm
View file

@ -1,40 +0,0 @@
;;; Guile SLIB interface
;; Copyright (C) 2001 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Code:
(define-module (guile slib)
:use-module (system vm core))
(define (slib:load file)
(let ((comp (string-append file ".go")))
(cond ((file-exists? comp) (load-compiled comp))
((file-exists? file) (load file))
(else (load (string-append file ".scm")))))
(module-export! (current-module)
(delq! '%module-public-interface
(hash-fold (lambda (k v d) (cons k d)) '()
(module-obarray (current-module))))))
(let ((file (%search-load-path "slib/guile.init")))
(if file
(slib:load file)
(error "Could not find slib/guile.init in" %load-path)))
(define-public require require:require)

7
module/language/scheme/Makefile.am
View file

@ -1,16 +1,11 @@
SOURCES =
SOURCES = translate.scm spec.scm
## FIXME: There's a bug showing up when compiling `translate.scm'.
##
## `spec.scm' cannot be compiled because it uses the `define-language'
## macro which introduces an unregular object, namely the first-class
## `<language>' procedure.
GOBJECTS = $(SOURCES:%.scm=%.go)
vmdir = $(guiledir)/language/scheme
vm_DATA = $(SOURCES) $(GOBJECTS)
CLEANFILES = $(GOBJECTS)
MAINTAINERCLEANFILES = Makefile.in
SUFFIXES = .scm .go
%.go: %.scm

1
module/slib/.cvsignore
View file

@ -1 +0,0 @@
*.go

171
module/slib/ANNOUNCE
View file

@ -1,171 +0,0 @@
This message announces the availability of Scheme Library release slib2d1.
New in slib2d1:
+ Linux RPM distribution.
+ Automated generation of HTTP/HTML static and (multi-client)
dynamically editable tables from relational databases.
(HTTP server demo at http://www.foxkid.net:8143/tla/).
+ Reference implementation of Metric Interchange Format:
"Representation of numerical values and SI units in character strings
for information interchanges"
http://swissnet.ai.mit.edu/~jaffer/MIXF.html
* Makefile (rpm): Added to dist target.
(mfiles): Added slib.spec.
* slib.spec: Added spec file to generate a .rpm file.
Largely based on that of Dr. Robert J. Meier
<robert.meier@computer.org>
* Makefile (docfiles): Added all the *.txi.
* db2html.scm (HTML editing tables): Replaced "record" with "row".
* http-cgi.scm (query-alist->parameter-list): Null string --> #f.
* coerce.scm (type-of): Removed 'null; broke (coerce '() 'string).
* htmlform.scm (html:meta, html:http-equiv): Added.
* htmlform.scm (html:meta-refresh): Added.
* http-cgi.scm (query-alist->parameter-list): Only separate words
for nary parameters.
* getparam.scm (getopt->parameter-list): Accomodate positional
arguments, both ends.
(getopt->parameter-list, getopt->arglist): Take optional
description strings.
* db2html.scm (command:make-editable-table): Added optional
arguments passed to command:modify-table.
(command:modify-table): Added null-keys argument; removed pkl.
* http-cgi.scm (http:forwarding-page): Added.
* htmlform.scm (html:text-area): fixed.
* http-cgi.scm (coerce->list): Added.
* paramlst.scm (check-arities): Generate warning for wrong arity.
* db2html.scm (command:make-editable-table): Deduce arities.
* comlist.scm (comlist:list-of??): Added.
* coerce.scm (coerce, type-of): Extracted from comlist.scm.
* uri.scm (uri:path->keys): Takes list of type-symbols.
* simetrix.scm (SI:unit-infos): bit is "bit" (not b).
* uri.scm (uri:decode-path, uri:path->keys): Now take path-list
instead of path. Fixes bug when '/' was in URI path.
* http-cgi.scm (make-query-alist-command-server): Renamed from
make-uriencoded-command-server; takes query-alist instead of
query-string. Diagnostics can use query-alist without recreating.
* db2html.scm (html:linked-row-converter): If a field has a
foreign-key of "*catalog-data*", then link to foreign table.
(catalog->html, table->linked-html): Put caption at BOTTOM.
* htmlform.scm (command->p-specs): Renamed from command->html
because it has changed so much. No longer does mapper argument.
* db2html.scm (command:make-editable-table): Returns editing-row
procedure.
* htmlform.scm (html:select, html:buttons, form:element,
form:delimited): value-list and visibles arguments combined.
* dbutil.scm (get-foreign-choices): extracted from command->html.
(make-defaulter): Added.
* strcase.scm (symbol-append): Added.
* http-cgi.scm (make-uriencoded-command-server): Only apply comval
if arglist worked.
* htmlform.scm (command->html): Big change; returns list of
results of application of (new) MAPPER argument.
(form:delimited, form:tabled): Added MAPPER procedures.
* db2html.scm (html:editable-row-converter): Check for
edit-converter being #f.
(command:make-editable-table): *keys*, *row-hash* NOT optional.
* htmlform.scm (form:element): Extracted from html:generate-form.
* db2html.scm (html:editable-row-converter): Added.
(command:modify-table): Handle case all fields are primary keys.
* db2html.scm (command:modify-table, command:make-editable-table):
(HTML editing tables): Added.
* htmlform.scm (form:submit): Enhanced.
* uri.scm (uri:decode-authority, make-uri): en/decode userinfo.
(uri:make-path): Added.
(read-anchor-string): Removed; just use paths for combined keys.
* slib.texi (Lists as sets): Examples had incorrect order in
returned lists.
* uri.scm (html:base, html:isindex): Added.
(uri->tree): Optional base-tree argument added for relative URI.
Brought into full conformance with RFC 2396 test cases.
* uri.scm (html:anchor, html:link uri->tree make-uri): Added.
(uri:split-fields, uri:decode-query): Moved and renamed from
http-cgi.scm.
* htmlform.scm (form:image): Added.
* uri.scm: Added collected URI functions from "http-cgi.scm" and
"db2html.scm".
* makcrc.scm (make-port-crc): Added CRC-16 default. Can now take
just generator argument.
* db2html.scm (html:linked-row-converter, table->linked-html,
table->linked-page, db->html-files, db->html-directory): more
evocative names.
(html:catalog-row-converter): Stripped down version for catalog.
* pp.scm (pretty-print->string): Added.
(pp:pretty-print): Use (output-port-width port) for width.
* genwrite.scm (genwrite:newline-str): abstracted.
* htmlform.scm (html:pre): Improved HTML formatting.
* http-cgi.scm (query-alist->parameter-list): Made robust for
unexpected option-names; and generates warning.
* db2html.scm: Fixed HTML per http://validator.w3.org/check.
* simetrix.scm (SI:conversion-factor): Negative return codes.
* simetrix.scm (SI:unit-infos): Added katal. Replaced bel (B)
with decibel (dB).
(SI:prefix-exponents): Added [IEC 60027-2] binary prefixes.
(SI:unit-infos): Added bit and byte (B).
* simetrix.scm (SI:unit-infos): Updated eV and u from CODATA-1998.
(SI:solidus): Abstracted parse functions.
* simetrix.scm: SI Metric Interchange Format for Scheme Added.
* scanf.scm (stdio:scan-and-set read-ui): Fixed dependence on LET
evaluation order.
* schmooz.texi: Split out from slib.texi.
* printf.scm (stdio:parse-float): Adjust so %e format prints an
exponent of zero for 0.0
* dbutil.scm (dbutil:list-table-definition): Added.
* db2html.scm (html:caption): Split out from html:table.
* rdms.scm (sync-database): Added.
* pnm.scm (pnm:array-write): PGMs were always being written with
15 for maxval.
* http-cgi.scm (make-urlencoded-command-server): Uses the value of
*suggest* if *command* is not in the query-string; if neither uses
literal *default*.
* htmlform.scm (html:form html:hidden html:checkbox html:text
html:text-area html:select html:buttons form:submit form:reset):
Procedures documented. No longer builds in <DL> tags.
* htmlform.scm (html:blank): Added.
(html:plain): Returns non-break-space for html:blank.
(html:select html:buttons command->html html:generate-form): Added
support for VISIBLE-NAME field for foreign-key domains.
* debug.scm (for-each-top-level-definition-in-file): define-syntax
is a top-level-definition too.
* makcrc.scm (make-port-crc): Converted to use read-byte.
* htmlform.scm (html:generate-form): was ignoring method.
From Ben Goetter <goetter@mazama.net>
* pscheme.init: Revised.
From Lars Arvestad <arve@inddama.sto.se.pnu.com>
* gambit.init (*features*): Gambit 3.0 provides
call-with-input-string and call-with-output-string.
SLIB is a portable Scheme library providing compatibiliy and utility
functions for all standard Scheme implementations.
SLIB includes initialization files for Bigloo, Chez, DrScheme, ELK,
GAMBIT, MacScheme, MITScheme, PocketScheme, RScheme Scheme->C,
Scheme48, SCM, SCSH, T3.1, UMB-Scheme, and VSCM.
Documentation includes a manifest, installation instructions, and
coding guidelines for the library. Documentation of each library
package is supplied. SLIB Documentation is online at:
http://swissnet.ai.mit.edu/~jaffer/SLIB.html
SLIB is available from:
http://swissnet.ai.mit.edu/ftpdir/scm/slib2d1.zip
http://swissnet.ai.mit.edu/ftpdir/scm/slib-2d1-1.noarch.rpm
swissnet.ai.mit.edu:/pub/scm/slib2d1.zip
swissnet.ai.mit.edu:/pub/scm/slib-2d1-1.noarch.rpm
SLIB-PSD is a portable debugger for Scheme (requires emacs editor):
http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.zip
swissnet.ai.mit.edu:/pub/scm/slib-psd1-3.zip
SCHELOG is an embedding of Prolog in Scheme+SLIB:
http://www.cs.rice.edu/CS/PLT/packages/schelog/
Programs for printing and viewing TexInfo documentation (which SLIB
has) come with GNU Emacs or can be obtained via ftp from:
ftp.gnu.org:pub/gnu/texinfo/texinfo-4.0.tar.gz

94
module/slib/Bev2slib.scm
View file

@ -1,94 +0,0 @@
;;;; "Bev2slib.scm" Build SLIB catalogs for Stephen Bevan's libraries.
;Copyright (C) 1998 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;;; Put this file into the implementation-vicinity directory for your
;;; scheme implementation.
;;; Add the line
;;; (load (in-vicinity (implementation-vicinity) "Bev2slib.scm"))
;;; to "mkimpcat.scm"
;;; Delete "slibcat" in your implementation-vicinity.
;;; Bind `Bevan-dir' to the directory containing directories "bawk",
;;; "mawk", "pathname", etc. Bev2slib.scm will put entries into the
;;; catalog only for those directories and files which exist.
(let ((Bevan-dir (in-vicinity (library-vicinity) "../"));"/usr/local/lib/Bevan/"
(catname "sitecat"))
(call-with-output-file (in-vicinity (implementation-vicinity) catname)
(lambda (op)
(define (display* . args)
(for-each (lambda (arg) (display arg op)) args)
(newline op))
(define (add-alias from to)
(display " " op)
(write (cons from to) op)
(newline op))
(begin
(display* ";\"" catname "\" Site-specific SLIB catalog for "
(scheme-implementation-type) (scheme-implementation-version)
". -*-scheme-*-")
(display* ";")
(display* "; DO NOT EDIT THIS FILE")
(display* "; it is automagically generated by \"Bev2slib.scm\"")
(newline op)
)
;; Output association lists to file "sitecat"
(for-each
(lambda (dir)
(let* ((vic (in-vicinity Bevan-dir (string-append dir "/")))
(map-file (in-vicinity vic (string-append dir ".map"))))
(display* ";;; from " map-file)
(display* "(")
(and
(file-exists? map-file)
(call-with-input-file map-file
(lambda (ip)
(define files '())
(do ((feature (read ip) (read ip)))
((eof-object? feature))
(let* ((type (read ip))
(file (read ip))
(fsym (string->symbol (string-append "Req::" file))))
(and (not (assq fsym files))
(set! files (cons (cons fsym file) files)))
(add-alias feature fsym)))
(for-each
(lambda (pr) (add-alias (car pr) (in-vicinity vic (cdr pr))))
files)
)))
(display* ")")))
'("char-set" "conc-string" "string" "string-03"
"avl-tree" "avl-trie"
"bawk" "mawk" "pathname"))
(begin
(display* "(")
(add-alias 'btree (in-vicinity Bevan-dir "bawk/btree"))
(add-alias 'read-line 'line-i/o)
(display* ")")
))))

2604
module/slib/ChangeLog
View file

File diff suppressed because it is too large Load diff

6
module/slib/DrScheme.init
View file

@ -1,6 +0,0 @@
;;;"DrScheme.init" Initialization for SLIB for DrScheme -*-scheme-*-
;; Friedrich Dominicus <frido@q-software-solutions.com>
;; Newsgroups: comp.lang.scheme
;; Date: 02 Oct 2000 09:24:57 +0200
(require-library "init.ss" "slibinit")

217
module/slib/FAQ
View file

@ -1,217 +0,0 @@
FAQ (Frequently Asked Questions and answers) for SLIB Scheme Library (slib2d1).
Written by Aubrey Jaffer (http://swissnet.ai.mit.edu/~jaffer).
INTRODUCTION AND GENERAL INFORMATION
[] What is SLIB?
SLIB is a portable scheme library meant to provide compatibiliy and
utility functions for all standard scheme implementations.
[] What is Scheme?
Scheme is a programming language in the Lisp family.
[] Which implementations has SLIB been ported to?
SLIB is supported by Bigloo, Chez, DrScheme, ELK, GAMBIT, MacScheme,
MITScheme, PocketScheme, RScheme Scheme->C, Scheme48, SCM, SCSH, T3.1,
UMB-Scheme, and VSCM.
[] How can I obtain SLIB?
SLIB is available via http from:
http://swissnet.ai.mit.edu/~jaffer/SLIB.html
SLIB is available via ftp from:
swissnet.ai.mit.edu:/pub/scm/
SLIB is also included with SCM floppy disks.
[] How do I install SLIB?
Read the INSTALLATION INSTRUCTIONS in "slib/README".
[] What are slib.texi and slib.info?
"slib.texi" is the `texinfo' format documentation for SLIB.
"slib.info" is produced from "slib.texi" by either Gnu Emacs or the
program `makeinfo'. "slib.info" can be viewed using either Gnu Emacs
or `info' or a text editor.
Programs for printing and viewing TexInfo documentation (which SLIB
has) come with GNU Emacs or can be obtained via ftp from:
ftp.gnu.org:/pub/gnu/texinfo/texinfo-3.12.tar.gz
[] How often is SLIB released?
Several times a year.
[] What is the latest version?
The version as of this writing is slib2d1. The latest documentation
is available online at:
http://swissnet.ai.mit.edu/~jaffer/SLIB.html
[] Which version am I using?
The Version is in the first line of the files slib/FAQ, slib/ANNOUNCE,
and slib/README. If you have Scheme and SLIB running, type
(slib:report-version)
SLIB INSTALLATION PROBLEMS
[] When I load an SLIB initialization file for my Scheme
implementation, I get ERROR: Couldn't find "require.scm"
Did you remember to set either the environment variable
SCHEME_LIBRARY_PATH or the library-vicinity in your initialization
file to the correct location? If you set SCHEME_LIBRARY_PATH, make
sure that the Scheme implementation supports getenv.
[] When I load an SLIB initialization file for my Scheme
implementation, I get ERROR: Couldn't find
"/usr/local/lib/slibrequire.scm"
Notice that it is looking for "slibrequire.scm" rather than
"slib/require.scm". You need to put a trailing slash on either the
environment variable SCHEME_LIBRARY_PATH or in the library-vicinity in
your initialization file.
[] SLIB used to work, but now I get ERROR: Couldn't find
"slib/require.scm". What happened?
You changed directories and now the relative pathname
"slib/require.scm" no longer refers to the same directory. The
environment variable SCHEME_LIBRARY_PATH and library-vicinity in your
initialization file should be absolute pathnames.
[] When I type (require 'macro) I get "ERROR: unbound variable:
require".
You need to arrange to have your Scheme implementation load the
appropriate SLIB initialization file ("foo.init") before using SLIB.
If your implementation loads an initialization file on startup, you
can have it load the SLIB initialization file automatically. For
example (load "/usr/local/lib/slib/foo.init").
[] Why do I get a string-ref (or other) error when I try to load
or use SLIB.
Check that the version of the Scheme implementation you are using
matches the version for which the SLIB initialization file was
written. There are some notes in the SLIB initialization files about
earlier versions. You may need to get a more recent version of your
Scheme implementation.
USING SLIB PROCEDURES
[] I installed SLIB. When I type (random 5) I get "ERROR:
unbound variable: random". Doesn't SLIB have a `random'
function?
Before you can use most SLIB functions, the associated module needs to
be loaded. You do this by typing the line that appears at the top of
the page in slib.info (or slib.texi) where the function is documented.
In the case of random, that line is (require 'random).
[] Why doesn't SLIB just load all the functions so I don't have
to type require statements?
SLIB has more than 1 Megabyte of Scheme source code. Many scheme
implementations take unacceptably long to load 1 Megabyte of source;
some implementations cannot allocate enough storage. If you use a
package often, you can put the require statement in your Scheme
initialization file. Consult the manual for your Scheme
implementation to find out the initialization file's name.
`Autoloads' will work with many Scheme implementations. You could put
the following in your initialization file:
(define (random . args) (require 'random) (apply random args))
I find that I only type require statements at top level when
debugging. I put require statements in my Scheme files so that the
appropriate modules are loaded automatically.
[] Why does SLIB have PRINTF when it already has the more
powerful (CommonLisp) FORMAT?
CommonLisp FORMAT does not support essential features which PRINTF
does. For instance, how do you format a signed 0 extended number?
(format t "~8,'0,X~%" -3) ==> 000000-3
But printf gets it right:
(printf "%08x\n" -3) ==> -0000003
How can one trunctate a non-numeric field using FORMAT? This feature
is essential for printing reports. The first 20 letters of a name is
sufficient to identify it. But if that name doesn't get trucated to
the desired length it can displace other fields off the page. Once
again, printf gets it right:
(printf "%.20s\n" "the quick brown fox jumped over the lazy dog")
==> the quick brown fox
FORMAT also lacks directives for formatting date and time. printf
does not handle these directly, but a related function strftime does.
[] Why doesn't SLIB:ERROR call FORMAT?
Format does not provide a method to truncate fields. When an error
message contains non-terminating or large expressions, the essential
information of the message may be lost in the ensuing deluge.
FORMAT as currently written in SLIB is not reentrant. Until this is
fixed, exception handlers and errors which might occur while using
FORMAT cannot use it.
MACROS
[] Why are there so many macro implementations in SLIB?
The R4RS committee specified only the high level pattern language in
the Revised^4 Report on Scheme and left to the free marketplace of
ideas the details of the low-level facility. Each macro package has a
different low-level facility. The low-level facilities are sometimes
needed because the high level pattern language is insufficiently
powerful to accomplish tasks macros are often written to do.
[] Why are there both R4RS macros and Common-Lisp style defmacros
in SLIB?
Most Scheme implementations predate the adoption of the R4RS macro
specification. All of the implementations except scheme48 version
0.45 support defmacro natively.
[] I did (LOAD "slib/yasos.scm"). The error I get is "variable
define-syntax is undefined".
The way to load the struct macro package is (REQUIRE 'YASOS).
[] I did (REQUIRE 'YASOS). Now when I type (DEFINE-PREDICATE
CELL?) The error I get is "variable define-predicate is
undefined".
If your Scheme does not natively support R4RS macros, you will need to
install a macro-capable read-eval-print loop. This is done by:
(require 'macro) ;already done if you did (require 'yasos)
(require 'repl)
(repl:top-level macro:eval)
This would also be true for a Scheme implementation which didn't
support DEFMACRO. The lines in this case would be:
(require 'repl)
(repl:top-level defmacro:eval)
[] I always use R4RS macros with an implementation which doesn't
natively support them. How can I avoid having to type require
statements every time I start Scheme?
As explained in the Repl entry in slib.info (or slib.texi):
To have your top level loop always use macros, add any interrupt
catching code and the following script to your Scheme init file:
(require 'macro)
(require 'repl)
(repl:top-level macro:eval)

333
module/slib/Makefile
View file

@ -1,333 +0,0 @@
# Makefile for Scheme Library
# Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998 Aubrey Jaffer.
SHELL = /bin/sh
intro:
@echo
@echo "Welcome to SLIB. Read \"README\" and \"slib.info\" (or"
@echo "\"slib.texi\") to learn how to install and use SLIB."
@echo
@echo
-make slib.info
srcdir=$(HOME)/slib/
PREVDOCS = slib/
dvidir=../dvi/
dvi: $(dvidir)slib.dvi
$(dvidir)slib.dvi: version.txi slib.texi $(dvidir)slib.fn schmooz.texi
# cd $(dvidir);export TEXINPUTS=$(srcdir):;texi2dvi $(srcdir)slib.texi
-(cd $(dvidir);export TEXINPUTS=$(srcdir):;texindex slib.??)
cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)slib.texi
$(dvidir)slib.fn:
cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)slib.texi \
$(srcdir)schmooz.texi
xdvi: $(dvidir)slib.dvi
xdvi -s 6 $(dvidir)slib.dvi
htmldir=../public_html/
slib_toc.html: version.txi slib.texi htmlform.txi schmooz.texi
texi2html -split -verbose slib.texi
$(PREVDOCS)slib_toc.html:
cd slib;make slib_toc.html
cd slib;texi2html -split -verbose slib.texi
html: $(htmldir)slib_toc.html
$(htmldir)slib_toc.html: slib slib_toc.html Makefile
hitch $(PREVDOCS)slib_\*.html slib_\*.html $(htmldir)
rpm_prefix=/usr/src/redhat/
prefix = /usr/local
exec_prefix = $(prefix)
bindir = $(exec_prefix)/bin
libdir = $(exec_prefix)/lib
infodir = $(exec_prefix)/info
RUNNABLE = scheme48
LIB = $(libdir)/$(RUNNABLE)
VM = scheme48vm
IMAGE = slib.image
INSTALL_DATA = install -c
slib48.036:
(echo ,load `pwd`/scheme48.init; \
echo "(define *args* '())"; \
echo "(define (program-arguments) (cons \"$(VM)\" *args*))"; \
echo ,dump $(LIB)/$(IMAGE); \
echo ,exit) | scheme48
(echo '#!/bin/sh'; \
echo exec '$(LIB)/$(VM)' -i '$(LIB)/$(IMAGE)' \"\$$\@\") \
> $(bindir)/slib48
chmod +x $(bindir)/slib48
$(LIB)/slibcat:
touch $(LIB)/slibcat
slib48: $(LIB)/slibcat Makefile
(echo ",batch on"; \
echo ",config"; \
echo ",load =scheme48/misc/packages.scm"; \
echo "(define-structure slib-primitives"; \
echo " (export s48-error"; \
echo " s48-ascii->char"; \
echo " s48-force-output"; \
echo " s48-current-error-port"; \
echo " s48-system";\
echo " s48-with-handler";\
echo " s48-getenv)";\
echo " (open scheme signals ascii extended-ports i/o"; \
echo " primitives handle unix-getenv)"; \
echo " (begin"; \
echo " (define s48-error error)"; \
echo " (define s48-ascii->char ascii->char)"; \
echo " (define s48-force-output force-output)"; \
echo " (define s48-current-error-port current-error-port)"; \
echo " (define (s48-system c) (vm-extension 96 c))"; \
echo " (define s48-with-handler with-handler)"; \
echo " (define s48-getenv getenv)))"; \
echo ",user"; \
echo ",open slib-primitives"; \
echo "(define (implementation-vicinity) \"$(LIB)/\")"; \
echo "(define (library-vicinity) \"`pwd`/\")"; \
echo ",load scheme48.init"; \
echo "(define *args* '())"; \
echo "(define (program-arguments) (cons \"scheme48\" *args*))"; \
echo "(set! *catalog* #f)"; \
echo ",collect"; \
echo ",batch off"; \
echo ",dump $(IMAGE) \"(slib $(VERSION))\""; \
echo ",exit") | scheme48
install48: slib48
$(INSTALL_DATA) $(IMAGE) $(LIB)
(echo '#!/bin/sh'; \
echo exec $(RUNNABLE) -i '$(LIB)/$(IMAGE)' \"\$$\@\") \
> $(bindir)/slib48
chmod +x $(bindir)/slib48
#### Stuff for maintaining SLIB below ####
VERSION = 2d1
ver = $(VERSION)
version.txi: Makefile
echo @set SLIBVERSION $(VERSION) > version.txi
echo @set SLIBDATE `date +"%B %Y"` >> version.txi
scheme = scm
htmlform.txi: *.scm
$(scheme) -rschmooz -e'(schmooz "slib.texi")'
slib.info: version.txi slib.texi htmlform.txi objdoc.txi schmooz.texi
makeinfo slib.texi --no-split -o slib.info
mv slib.info slib$(VERSION).info
if [ -f $(PREVDOCS)slib.info ]; \
then infobar $(PREVDOCS)slib.info slib$(VERSION).info slib.info; \
else cp slib$(VERSION).info slib.info;fi
info: installinfo
installinfo: $(infodir)/slib.info
$(infodir)/slib.info: slib.info
cp -a slib.info $(infodir)/slib.info
-install-info $(infodir)/slib.info $(infodir)/dir
-rm $(infodir)/slib.info.gz
infoz: installinfoz
installinfoz: $(infodir)/slib.info.gz
$(infodir)/slib.info.gz: $(infodir)/slib.info
gzip -f $(infodir)/slib.info
ffiles = printf.scm format.scm genwrite.scm obj2str.scm pp.scm \
ppfile.scm strcase.scm debug.scm trace.scm lineio.scm \
strport.scm scanf.scm chap.scm qp.scm break.scm stdio.scm \
strsrch.scm prec.scm schmooz.scm
lfiles = sort.scm comlist.scm tree.scm logical.scm random.scm tsort.scm \
coerce.scm
revfiles = sc4opt.scm sc4sc3.scm sc2.scm mularg.scm mulapply.scm \
trnscrpt.scm withfile.scm dynwind.scm promise.scm values.scm \
eval.scm
afiles = ratize.scm randinex.scm modular.scm factor.scm \
charplot.scm root.scm minimize.scm cring.scm determ.scm \
selfset.scm psxtime.scm cltime.scm timezone.scm tzfile.scm
bfiles = collect.scm fluidlet.scm struct.scm object.scm recobj.scm yasyn.scm
scfiles = r4rsyn.scm scmacro.scm synclo.scm synrul.scm synchk.scm \
repl.scm macwork.scm mwexpand.scm mwdenote.scm mwsynrul.scm
scafiles = scainit.scm scaglob.scm scamacr.scm scaoutp.scm scaexpp.scm \
structure.scm
dfiles = defmacex.scm mbe.scm
efiles = record.scm dynamic.scm queue.scm process.scm \
priorque.scm hash.scm hashtab.scm alist.scm \
wttree.scm wttest.scm array.scm arraymap.scm \
sierpinski.scm soundex.scm byte.scm nclients.scm pnm.scm \
simetrix.scm
rfiles = rdms.scm alistab.scm dbutil.scm paramlst.scm report.scm \
batch.scm makcrc.scm dbrowse.scm comparse.scm getopt.scm \
htmlform.scm db2html.scm http-cgi.scm getparam.scm glob.scm \
fft.scm uri.scm
gfiles = tek40.scm tek41.scm
docfiles = ANNOUNCE README FAQ slib.info slib.texi schmooz.texi ChangeLog \
coerce.txi lineio.txi nclients.txi factor.txi minimize.txi \
obj2str.txi randinex.txi random.txi uri.txi db2html.txi \
htmlform.txi http-cgi.txi version.txi fmtdoc.txi objdoc.txi
mfiles = Makefile require.scm Template.scm syncase.sh mklibcat.scm \
Bev2slib.scm slib.spec
ifiles = bigloo.init chez.init elk.init macscheme.init \
mitscheme.init scheme2c.init scheme48.init gambit.init t3.init \
vscm.init mitcomp.pat scm.init scsh.init pscheme.init STk.init \
RScheme.init DrScheme.init umbscheme.init
tfiles = plottest.scm formatst.scm macrotst.scm scmactst.scm \
dwindtst.scm structst.scm
sfiles = $(ffiles) $(lfiles) $(revfiles) $(afiles) $(scfiles) $(efiles) \
$(rfiles) $(gfiles) $(scafiles) $(dfiles)
allfiles = $(docfiles) $(mfiles) $(ifiles) $(sfiles) $(tfiles) $(bfiles)
makedev = make -f $(HOME)/makefile.dev
CHPAT=$(HOME)/bin/chpat
RSYNC=rsync -avessh
dest = $(HOME)/dist/
temp/slib: $(allfiles)
-rm -rf temp
mkdir temp
mkdir temp/slib
ln $(allfiles) temp/slib
infotemp/slib: slib.info
-rm -rf infotemp
mkdir infotemp
mkdir infotemp/slib
ln slib.info slib.info-* infotemp/slib
#For change-barred HTML.
slib:
unzip -a $(dest)slib[0-9]*.zip
distinfo: $(dest)slib.info.zip
$(dest)slib.info.zip: infotemp/slib
$(makedev) TEMP=infotemp/ DEST=$(dest) PROD=slib ver=.info zip
rm -rf infotemp
release: dist rpm
cvs tag -F slib$(VERSION)
cp ANNOUNCE $(htmldir)SLIB_ANNOUNCE.txt
$(RSYNC) $(htmldir)SLIB.html $(htmldir)SLIB_ANNOUNCE.txt nestle.ai.mit.edu:public_html/
$(RSYNC) $(dest)README $(dest)slib$(VERSION).zip \
$(dest)slib-$(VERSION)-1.noarch.rpm nestle.ai.mit.edu:dist/
# upload $(dest)README $(dest)slib$(VERSION).zip ftp.gnu.org:gnu/jacal/
# $(MAKE) indiana
indiana:
upload $(dest)slib$(VERSION).zip ftp@ftp.cs.indiana.edu:/pub/scheme-repository/incoming
echo -e \
'I have uploaded slib$(VERSION).zip to ftp.cs.indiana.edu:/pub/scheme-repository/incoming\n' \
'for placement into ftp.cs.indiana.edu:/pub/scheme-repository/code/lib/' \
| mail -s 'SLIB upload' -b jaffer scheme-repository-request@cs.indiana.edu
postnews:
echo -e "Newsgroups: comp.lang.scheme\n" | cat - ANNOUNCE | \
inews -h -O -S \
-f "announce@docupress.com (Aubrey Jaffer & Radey Shouman)" \
-t "SLIB$(VERSION) Released" -d world
upzip: $(HOME)/pub/slib.zip
$(RSYNC) $(HOME)/pub/slib.zip nestle.ai.mit.edu:pub/
dist: $(dest)slib$(VERSION).zip
$(dest)slib$(VERSION).zip: temp/slib
$(makedev) DEST=$(dest) PROD=slib ver=$(VERSION) zip
rpm: $(dest)slib-$(VERSION)-1.noarch.rpm
$(dest)slib-$(VERSION)-1.noarch.rpm: $(dest)slib$(VERSION).zip
cp $(dest)slib$(VERSION).zip $(rpm_prefix)SOURCES
rpm -bb --clean slib.spec
rm $(rpm_prefix)SOURCES/slib$(VERSION).zip
mv $(rpm_prefix)RPMS/noarch/slib-$(VERSION)-1.noarch.rpm $(dest)
shar: slib.shar
slib.shar: temp/slib
$(makedev) PROD=slib shar
dclshar: slib.com
com: slib.com
slib.com: temp/slib
$(makedev) PROD=slib com
zip: slib.zip
slib.zip: temp/slib
$(makedev) PROD=slib zip
doszip: /c/scm/dist/slib$(VERSION).zip
/c/scm/dist/slib$(VERSION).zip: temp/slib
$(makedev) DEST=/c/scm/dist/ PROD=slib ver=$(VERSION) zip
zip -d /c/scm/dist/slib$(VERSION).zip slib/slib.info
pubzip: temp/slib
$(makedev) DEST=$(HOME)/pub/ PROD=slib zip
diffs: pubdiffs
pubdiffs: temp/slib
$(makedev) DEST=$(HOME)/pub/ PROD=slib pubdiffs
distdiffs: temp/slib
$(makedev) DEST=$(dest) PROD=slib ver=$(ver) distdiffs
announcediffs: temp/slib
$(makedev) DEST=$(dest) PROD=slib ver=$(VERSION) announcediffs
psdfiles=COPYING.psd README.psd cmuscheme.el comint.el instrum.scm pexpr.scm \
primitives.scm psd-slib.scm psd.el read.scm runtime.scm version.scm
psdocfiles=article.bbl article.tex manual.bbl manual.tex quick-intro.tex
psdtemp/slib:
-rm -rf psdtemp
mkdir psdtemp
mkdir psdtemp/slib
mkdir psdtemp/slib/psd
cd psd; ln $(psdfiles) ../psdtemp/slib/psd
mkdir psdtemp/slib/psd/doc
cd psd/doc; ln $(psdocfiles) ../../psdtemp/slib/psd/doc
psdist: $(dest)slib-psd.tar.gz
$(dest)slib-psd.tar.gz: psdtemp/slib
$(makedev) DEST=$(dest) PROD=slib ver=-psd tar.gz TEMP=psdtemp/
new:
echo `date` \ Aubrey Jaffer \ \<`whoami`@`hostname`\>> change
echo>> change
echo \ \* require.scm \(*SLIB-VERSION*\): Bumped from $(VERSION) to $(ver).>>change
echo>> change
cat ChangeLog >> change
mv -f change ChangeLog
$(CHPAT) slib$(VERSION) slib$(ver) ANNOUNCE FAQ ../scm/ANNOUNCE \
../jacal/ANNOUNCE ../wb/README ../wb/ANNOUNCE \
../synch/ANNOUNCE \
$(htmldir)README.html ../dist/README \
$(htmldir)JACAL.html \
$(htmldir)SCM.html $(htmldir)Hobbit.html \
$(htmldir)SIMSYNCH.html ../scm/scm.texi \
/c/scm/dist/install.bat /c/scm/dist/makefile \
/c/scm/dist/mkdisk.bat
$(CHPAT) slib-$(VERSION) slib-$(ver) ANNOUNCE FAQ ../scm/ANNOUNCE \
../jacal/ANNOUNCE ../wb/README ../wb/ANNOUNCE \
../synch/ANNOUNCE \
$(htmldir)README.html ../dist/README \
$(htmldir)JACAL.html \
$(htmldir)SCM.html $(htmldir)Hobbit.html \
$(htmldir)SIMSYNCH.html ../scm/scm.texi \
/c/scm/dist/install.bat /c/scm/dist/makefile \
/c/scm/dist/mkdisk.bat
$(CHPAT) $(VERSION) $(ver) README slib.texi require.scm Makefile \
$(htmldir)SLIB.html slib.spec
cvs commit -m '(*SLIB-VERSION*): Bumped from $(VERSION) to $(ver).'
cvs tag -F slib$(ver)
tagfiles = version.txi slib.texi $(mfiles) $(sfiles) $(bfiles) $(tfiles) \
$(ifiles)
# README and $(ifiles) cause semgentation faults in ETAGS for Emacs version 19.
tags: $(tagfiles)
etags $(tagfiles)
test: $(sfiles)
scheme Template.scm $(sfiles)
rights:
scm -ladmin -e"(admin:check-all)" $(sfiles) $(tfiles) \
$(bfiles) $(ifiles)
report:
scmlit -e"(slib:report #t)"
scm -e"(slib:report #t)"
clean:
-rm -f *~ *.bak *.orig *.rej core a.out *.o \#*
-rm -rf *temp
distclean: realclean
realclean:
-rm -f *~ *.bak *.orig *.rej TAGS core a.out *.o \#*
-rm -f slib.info* slib.?? slib.???
-rm -rf *temp
realempty: temp/slib
-rm -f $(allfiles)

297
module/slib/README
View file

@ -1,297 +0,0 @@
This directory contains the distribution of Scheme Library slib2d1.
Slib conforms to Revised^5 Report on the Algorithmic Language Scheme
and the IEEE P1178 specification. Slib supports Unix and similar
systems, VMS, and MS-DOS.
The maintainer can be reached at jaffer @ ai.mit.edu.
http://swissnet.ai.mit.edu/~jaffer/SLIB.html
MANIFEST
`README' is this file. It contains a MANIFEST, INSTALLATION
INSTRUCTIONS, and coding guidelines.
`FAQ' Frequently Asked Questions and answers.
`ChangeLog' documents changes to slib.
`slib.texi' has documentation on library packages in TexInfo format.
`Template.scm' Example configuration file. Copy and customize to
reflect your system.
`bigloo.init' is a configuration file for Bigloo.
`chez.init' is a configuration file for Chez Scheme.
`DrScheme.init' is a configuration file for DrScheme.
`elk.init' is a configuration file for ELK 2.1
`gambit.init' is a configuration file for Gambit Scheme.
`macscheme.init' is a configuration file for MacScheme.
`mitscheme.init' is a configuration file for MIT Scheme.
`mitcomp.pat' is a patch file which adds definitions to SLIB files
for the MitScheme compiler.
`pscheme.init' is configuration file for PocketScheme 0.2.5 (WinCE SIOD)
`RScheme.init' is a configuration file for RScheme.
`scheme2c.init' is a configuration file for DEC's scheme->c.
`scheme48.init' is a configuration file for Scheme48.
`scsh.init' is a configuration file for Scheme-Shell
`scm.init' is a configuration file for SCM.
`t3.init' is a configuration file for T3.1 in Scheme mode.
`STk.init' is a configuration file for STk.
`umbscheme.init' is a configuration file for umb-scheme.
`vscm.init' is a configuration file for VSCM.
`mklibcat.scm' builds the *catalog* cache.
`require.scm' has code which allows system independent access to
the library files.
`Bev2slib.scm' Converts Stephen Bevan's "*.map" files to SLIB catalog entries.
`format.scm' has Common-Lisp style format.
`formatst.scm' has code to test format.scm
`pp.scm' has pretty-print.
`ppfile.scm' has pprint-file and pprint-filter-file.
`obj2str.scm' has object->string.
`strcase.scm' has functions for manipulating the case of strings.
`genwrite.scm' has a generic-write which is used by pp.scm,
pp2str.scm and obj2str.scm
`printf.scm' has printf, fprintf, and sprintf compatible with C.
`scanf.scm' has scanf, fscanf, and sscanf compatible by C.
`lineio' has line oriented input/output functions.
`qp.scm' has printer safe for circular structures.
`break.scm' has break and continue.
`trace.scm' has trace and untrace for tracing function execution.
`debug.scm' has handy higher level debugging aids.
`strport.scm' has routines for string-ports.
`strsrch.scm' search for chars or substrings in strings and ports.
`alist.scm' has functions accessing and modifying association lists.
`hash.scm' defines hash, hashq, and hashv.
`hashtab.scm' has hash tables.
`sierpinski.scm' 2-dimensional coordinate hash.
`soundex.scm' English name hash.
`logical.scm' emulates 2's complement logical operations.
`random.scm' has random number generator compatible with Common Lisp.
`randinex.scm' has inexact real number distributions.
`primes.scm' has primes and probably-prime?.
`factor.scm' has factor.
`root.scm' has Newton's and Laguerre's methods for finding roots.
`minimize.scm' has Golden Section Search for minimum value.
`cring.scm' extend + and * to custom commutative rings.
`selfset.scm' sets single letter identifiers to their symbols.
`determ.scm' compute determinant of list of lists.
`charplot.scm' has procedure for plotting on character screens.
`plottest.scm' has code to test charplot.scm.
`tek40.scm' has routines for Tektronix 4000 series graphics.
`tek41.scm' has routines for Tektronix 4100 series graphics.
`getopt.scm' has posix-like getopt for parsing command line arguments.
`psxtime.scm' has Posix time conversion routines.
`cltime.scm' has Common-Lisp time conversion routines.
`timezone.scm' has the default time-zone, UTC.
`tzfile.scm' reads sysV style (binary) timezone file.
`comparse.scm' has shell-like command parsing.
`rdms.scm' has code to construct a relational database from a base
table implementation.
`alistab.scm' has association list base tables.
`dbutil.scm' has utilities for creating and manipulating relational
databases.
`htmlform.scm' generates HTML-3.2 with forms.
`db2html.scm' convert relational database to hyperlinked tables and
pages.
`http-cgi.scm' serves WWW pages with HTTP or CGI.
`uri.scm' encodes and decodes Uniform Resource Identifiers.
`dbrowse.scm' browses relational databases.
`paramlst.scm' has procedures for passing parameters by name.
`getparam.scm' has procedures for converting getopt to parameters.
`report.scm' prints database reports.
`schmooz.scm' is a simple, lightweight markup language for
interspersing Texinfo documentation with Scheme source code.
`glob.scm' has filename matching and manipulation.
`batch.scm' Group and execute commands on various operating systems.
`makcrc.scm' Create Scheme procedure to calculate POSIX.2 checksums
or other CRCs.
`record.scm' a MITScheme user-definable datatypes package
`promise.scm' has code from R4RS for supporting DELAY and FORCE.
`repl.scm' has a read-eval-print-loop.
`defmacex.scm' has defmacro:expand*.
`mbe.scm' has "Macro by Example" define-syntax.
`scmacro.scm' is a syntactic closure R4RS macro package.
r4rsyn.scm, synclo.scm, synrul.scm have syntax definitions
and support.
`scmactst.scm' is code for testing SYNTACTIC CLOSURE macros.
`scainit.scm' is a syntax-case R4RS macro package.
scaglob.scm scamacr.scm scaoutp.scm scaexpp.scm have
syntax definitions and support. `syncase.sh' is a shell
script for producing the SLIB version from the original.
`macwork.scm' is a "Macros that work" package.
mwexpand.scm mwdenote.scm mwsynrul.scm have support.
`macrotst.scm' is code from R4RS for testing macros.
`values.scm' is multiple values.
`queue.scm' has queues and stacks.
`object.scm' is an object system.
`yasyn.scm' defines (syntax-rules) macros for object oriented programming.
`collect.scm' is collection operators (like CL sequences).
`priorque.scm' has code and documentation for priority queues.
`wttree.scm' has weight-balanced trees.
`wttest.scm' tests weight-balanced trees.
`process.scm' has multi-processing primitives.
`array.scm' has multi-dimensional arrays and sub-arrays.
`arraymap.scm' has array-map!, array-for-each, and array-indexes.
`sort.scm' has sorted?, sort, sort!, merge, and merge!.
`tsort.scm' has topological-sort.
`comlist.scm' has many common list and mapping procedures.
`tree.scm' has functions dealing with trees.
`coerce.scm' has coerce and type-of from Common-Lisp.
`chap.scm' has functions which compare and create strings in
"chapter order".
`sc4opt.scm' has optional rev4 procedures.
`sc4sc3.scm' has procedures to make a rev3 implementation run rev4
code.
`sc2.scm' has rev2 procedures eliminated in subsequent versions.
`mularg.scm' redefines - and / to take more than 2 arguments.
`mulapply.scm' redefines apply to take more than 2 arguments.
`ratize.scm' has function rationalize from Revised^4 spec.
`trnscrpt.scm' has transcript-on and transcript-off from Revised^4 spec.
`withfile.scm' has with-input-from-file and with-output-to-file from R4RS.
`dynwind.scm' has dynamic-wind from R5RS.
`eval.scm' has eval with environments from R5RS.
`dwindtst.scm' has routines for characterizing dynamic-wind.
`dynamic.scm' has DYNAMIC data type [obsolete].
`fluidlet.scm' has fluid-let syntax.
`struct.scm' has defmacros which implement RECORDS from the book:
"Essentials of Programming Languages".
`structure.scm' has syntax-case macros for the same.
`structst.scm' has test code for struct.scm.
`byte.scm' has arrays of small integers.
`nclients.scm' provides a Scheme interface to FTP and WWW Browsers.
`pnm.scm' provides a Scheme interface to "portable bitmap" files.
`simetrix.scm' provides SI Metric Interchange Format.
INSTALLATION INSTRUCTIONS
Check the manifest in `README' to find a configuration file for your
Scheme implementation. Initialization files for most IEEE P1178
compliant Scheme Implementations are included with this distribution.
If the Scheme implementation supports `getenv', then the value of the
shell environment variable SCHEME_LIBRARY_PATH will be used for
`(library-vicinity)' if it is defined. Currently, Chez, Elk,
MITScheme, scheme->c, VSCM, and SCM support `getenv'. Scheme48
supports `getenv' but does not use it for determining
`library-vicinity'. (That is done from the Makefile.)
You should check the definitions of `software-type',
`scheme-implementation-version', `implementation-vicinity', and
`library-vicinity' in the initialization file. There are comments in
the file for how to configure it.
Once this is done you can modify the startup file for your Scheme
implementation to `load' this initialization file. SLIB is then
installed.
Multiple implementations of Scheme can all use the same SLIB
directory. Simply configure each implementation's initialization file
as outlined above.
- Implementation: SCM
The SCM implementation does not require any initialization file as
SLIB support is already built into SCM. See the documentation
with SCM for installation instructions.
- Implementation: VSCM
From: Matthias Blume <blume@cs.Princeton.EDU>
Date: Tue, 1 Mar 1994 11:42:31 -0500
Disclaimer: The code below is only a quick hack. If I find some
time to spare I might get around to make some more things work.
You have to provide `vscm.init' as an explicit command line
argument. Since this is not very nice I would recommend the
following installation procedure:
1. run scheme
2. `(load "vscm.init")'
3. `(slib:dump "dumpfile")'
4. mv dumpfile place-where-vscm-standard-bootfile-resides e.g.
mv dumpfile /usr/local/vscm/lib/scheme-boot (In this case
vscm should have been compiled with flag
-DDEFAULT_BOOTFILE='"/usr/local/vscm/lib/scheme-boot"'. See
Makefile (definition of DDP) for details.)
- Implementation: Scheme48
To make a Scheme48 image for an installation under `<prefix>',
1. `cd' to the SLIB directory
2. type `make prefix=<prefix> slib48'.
3. To install the image, type `make prefix=<prefix> install48'.
This will also create a shell script with the name `slib48'
which will invoke the saved image.
- Implementation: PLT Scheme
- Implementation: DrScheme
- Implementation: MzScheme
Date: Mon, 2 Oct 2000 21:29:48 -0400 (EDT)
From: Shriram Krishnamurthi <sk@cs.brown.edu>
We distribute an SLIB init file for our system. If you have PLT
Scheme (our preferred name for the entire suite, which includes
DrScheme, MzScheme and other implementations) installed, you ought
to be able to run "help-desk", or run `drscheme' and choose Help
Desk from the Help menu; in Help Desk, type `slib'. This will give
instructions for how to load the SLIB init file.
PORTING INSTRUCTIONS
If there is no initialization file for your Scheme implementation, you
will have to create one. Your Scheme implementation must be largely
compliant with
`IEEE Std 1178-1990',
`Revised(4) Report on the Algorithmic Language Scheme', or
`Revised(5) Report on the Algorithmic Language Scheme'
in order to support SLIB.
`Template.scm' is an example configuration file. The comments inside
will direct you on how to customize it to reflect your system. Give
your new initialization file the implementation's name with `.init'
appended. For instance, if you were porting `foo-scheme' then the
initialization file might be called `foo.init'.
Your customized version should then be loaded as part of your scheme
implementation's initialization. It will load `require.scm' from the
library; this will allow the use of `provide', `provided?', and
`require' along with the "vicinity" functions. The rest of the
library will then be accessible in a system independent fashion.
Please mail new working configuration files to `jaffer@ai.mit.edu' so
that they can be included in the SLIB distribution.
CODING GUIDELINES
All library packages are written in IEEE P1178 Scheme and assume that
a configuration file and `require.scm' package have already been
loaded. Other versions of Scheme can be supported in library packages
as well by using, for example, `(provided? 'rev3-report)' or `(require
'rev3-report)'.
`require.scm' defines `*catalog*', an association list of module
names and filenames. When a new package is added to the library, an
entry should be added to `require.scm'. Local packages can also be
added to `*catalog*' and even shadow entries already in the table.
The module name and `:' should prefix each symbol defined in the
package. Definitions for external use should then be exported by having
`(define foo module-name:foo)'.
Submitted packages should not duplicate routines which are already in
SLIB files. Use `require' to force those features to be supported in
your package. Care should be taken that there are no circularities in
the `require's and `load's between the library packages.
Documentation should be provided in Emacs Texinfo format if possible,
But documentation must be provided.

290
module/slib/RScheme.init
View file

@ -1,290 +0,0 @@
;;;"RScheme.init" Initialization for SLIB for RScheme -*-scheme-*-
;;;; From http://www.rscheme.org/rs/pg1/RScheme.scm
;;; Author: Aubrey Jaffer
;;;
;;; This code is in the public domain.
;;;
;;; adapted for RScheme by Donovan Kolbly -- (v1 1997-09-14)
;;;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;;; (software-type) should be set to the generic operating system type.
;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
(define (software-type) 'UNIX)
;;; (scheme-implementation-type) should return the name of the scheme
;;; implementation loading this file.
(define (scheme-implementation-type) 'RScheme)
;;; (scheme-implementation-home-page) should return a (string) URI
;;; (Uniform Resource Identifier) for this scheme implementation's home
;;; page; or false if there isn't one.
(define (scheme-implementation-home-page) "http://www.rscheme.org/")
;;; (scheme-implementation-version) should return a string describing
;;; the version the scheme implementation loading this file.
(define (scheme-implementation-version) "0.7.1")
;;; (implementation-vicinity) should be defined to be the pathname of
;;; the directory where any auxillary files to your Scheme
;;; implementation reside.
(define (implementation-vicinity)
(case (software-type)
((UNIX) "/usr/local/lib/rs/0.7.1/")
((VMS) "scheme$src:")
((MS-DOS) "C:\\scheme\\")))
;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
(define library-vicinity
(let ((library-path
(or
;; Use this getenv if your implementation supports it.
(getenv "SCHEME_LIBRARY_PATH")
;; Use this path if your scheme does not support GETENV
;; or if SCHEME_LIBRARY_PATH is not set.
(case (software-type)
((UNIX) "/usr/lib/slib/")
((VMS) "lib$scheme:")
((MS-DOS) "C:\\SLIB\\")
(else "")))))
(lambda () library-path)))
;;; *FEATURES* should be set to a list of symbols describing features
;;; of this implementation. Suggestions for features are:
(define *features*
'(
source ;can load scheme source files
;(slib:load-source "filename")
; compiled ;can load compiled files
;(slib:load-compiled "filename")
rev4-report ;conforms to
; rev3-report ;conforms to
; ieee-p1178 ;conforms to
; sicp ;runs code from Structure and
;Interpretation of Computer
;Programs by Abelson and Sussman.
rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
;LIST->STRING, STRING-COPY,
;STRING-FILL!, LIST->VECTOR,
;VECTOR->LIST, and VECTOR-FILL!
; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
;SUBSTRING-FILL!,
;STRING-NULL?, APPEND!, 1+,
;-1+, <?, <=?, =?, >?, >=?
multiarg/and- ;/ and - can take more than 2 args.
multiarg-apply ;APPLY can take more than 2 args.
; rationalize
delay ;has DELAY and FORCE
with-file ;has WITH-INPUT-FROM-FILE and
;WITH-OUTPUT-FROM-FILE
string-port ;has CALL-WITH-INPUT-STRING and
;CALL-WITH-OUTPUT-STRING
; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
char-ready?
; macro ;has R4RS high level macros
; defmacro ;has Common Lisp DEFMACRO
; eval ;SLIB:EVAL is single argument eval
; record ;has user defined data structures
; values ;proposed multiple values
; dynamic-wind ;proposed dynamic-wind
; ieee-floating-point ;conforms to
full-continuation ;can return multiple times
; object-hash ;has OBJECT-HASH
; sort
; queue ;queues
; pretty-print
; object->string
; format
; trace ;has macros: TRACE and UNTRACE
; compiler ;has (COMPILER)
; ed ;(ED) is editor
; system ;posix (system <string>)
getenv ;posix (getenv <string>)
; program-arguments ;returns list of strings (argv)
; Xwindows ;X support
; curses ;screen management package
; termcap ;terminal description package
; terminfo ;sysV terminal description
; current-time ;returns time in seconds since 1/1/1970
))
;;; (OUTPUT-PORT-WIDTH <port>)
(define (output-port-width . arg) 79)
;;; (OUTPUT-PORT-HEIGHT <port>)
(define (output-port-height . arg) 24)
;;; (CURRENT-ERROR-PORT)
;(define current-error-port
; (let ((port (current-output-port)))
; (lambda () port)))
;;; (TMPNAM) makes a temporary file name.
(define tmpnam (let ((cntr 100))
(lambda () (set! cntr (+ 1 cntr))
(string-append "slib_" (number->string cntr)))))
;;; (FILE-EXISTS? <string>)
(define (file-exists? f) (os-file-exists? f))
;;; (DELETE-FILE <string>)
(define (delete-file f) #f)
;;; FORCE-OUTPUT flushes any pending output on optional arg output port
;;; use this definition if your system doesn't have such a procedure.
(define (force-output . arg)
(flush-output-port (if (null? arg)
(current-output-port)
(car arg))))
;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
;;; port versions of CALL-WITH-*PUT-FILE.
;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
;;; be returned by CHAR->INTEGER.
(define char-code-limit 65536)
;;; MOST-POSITIVE-FIXNUM is used in modular.scm
(define most-positive-fixnum #x1FFFFFFF)
;;; Return argument
;;(define (identity x) x)
;;; If your implementation provides eval SLIB:EVAL is single argument
;;; eval using the top-level (user) environment.
(define slib:eval eval)
;;; If your implementation provides R4RS macros:
;(define macro:eval slib:eval)
;(define macro:load load)
(define *defmacros*
(list (cons 'defmacro
(lambda (name parms . body)
`(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body))
*defmacros*))))))
(define (defmacro? m) (and (assq m *defmacros*) #t))
(define (macroexpand-1 e)
(if (pair? e) (let ((a (car e)))
(cond ((symbol? a) (set! a (assq a *defmacros*))
(if a (apply (cdr a) (cdr e)) e))
(else e)))
e))
(define (macroexpand e)
(if (pair? e) (let ((a (car e)))
(cond ((symbol? a)
(set! a (assq a *defmacros*))
(if a (macroexpand (apply (cdr a) (cdr e))) e))
(else e)))
e))
(define gentemp
(let ((*gensym-counter* -1))
(lambda ()
(set! *gensym-counter* (+ *gensym-counter* 1))
(string->symbol
(string-append "slib:G" (number->string *gensym-counter*))))))
(define base:eval slib:eval)
(define (defmacro:eval x) (base:eval (defmacro:expand* x)))
(define (defmacro:expand* x)
(require 'defmacroexpand) (apply defmacro:expand* x '()))
(define (defmacro:load <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))))
(call-with-input-file <pathname>
(lambda (port)
(let ((old-load-pathname *load-pathname*))
(set! *load-pathname* <pathname>)
(do ((o (read port) (read port)))
((eof-object? o))
(evl o))
(set! *load-pathname* old-load-pathname)))))
(define slib:warn
(lambda args
(let ((cep (current-error-port)))
(if (provided? 'trace) (print-call-stack cep))
(display "Warn: " cep)
(for-each (lambda (x) (display x cep)) args))))
;;; define an error procedure for the library
(define (slib:error msg . args)
(if (provided? 'trace) (print-call-stack (current-error-port)))
(error "~a ~j" msg args))
;;; define these as appropriate for your system.
(define slib:tab (integer->char 9))
(define slib:form-feed (integer->char 12))
;;; Support for older versions of Scheme. Not enough code for its own file.
;(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))
(define t #t)
(define nil #f)
;;; Define these if your implementation's syntax can support it and if
;;; they are not already defined.
;(define (1+ n) (+ n 1))
;(define (-1+ n) (+ n -1))
;(define 1- -1+)
(define in-vicinity string-append)
;;; Define SLIB:EXIT to be the implementation procedure to exit or
;;; return if exitting not supported.
(define slib:exit (lambda args (process-exit 0)))
;;; Here for backward compatability
(define scheme-file-suffix
(let ((suffix (case (software-type)
((NOSVE) "_scm")
(else ".scm"))))
(lambda () suffix)))
;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
;;; suffix all the module files in SLIB have. See feature 'SOURCE.
(define (slib:load-source f) (load (string-append f ".scm")))
;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
;;; by compiling "foo.scm" if this implementation can compile files.
;;; See feature 'COMPILED.
(define slib:load-compiled load)
;;; At this point SLIB:LOAD must be able to load SLIB files.
(define slib:load slib:load-source)
(slib:load (in-vicinity (library-vicinity) "require"))

256
module/slib/STk.init
View file

@ -1,256 +0,0 @@
;;;"STk.init" SLIB Initialization for STk -*-scheme-*-
;;; Authors: Erick Gallesio (eg@unice.fr) and Aubrey Jaffer.
;;;
;;; This code is in the public domain.
(require "unix")
;;; (software-type) should be set to the generic operating system type.
;;; UNIX, VMS, MACOS, AMIGA and MSDOS are supported.
(define (software-type) 'UNIX)
;;; (scheme-implementation-type) should return the name of the scheme
;;; implementation loading this file.
(define (scheme-implementation-type) '|STk|)
;;; (scheme-implementation-home-page) should return a (string) URI
;;; (Uniform Resource Identifier) for this scheme implementation's home
;;; page; or false if there isn't one.
(define (scheme-implementation-home-page)
"http://kaolin.unice.fr/STk/STk.html")
;;; (scheme-implementation-version) should return a string describing
;;; the version the scheme implementation loading this file.
(define (scheme-implementation-version) (version))
;;; (implementation-vicinity) should be defined to be the pathname of
;;; the directory where any auxillary files to your Scheme
;;; implementation reside.
(define (implementation-vicinity) "/usr/local/lib/stk/3.99.3/")
;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
(define library-vicinity
(let ((library-path (or (getenv "SCHEME_LIBRARY_PATH") "/usr/local/lib/slib/")))
(lambda () library-path)))
;;;
;;;
(define home-vicinity
(let ((home-path (or (getenv "HOME") "/")))
(lambda () home-path)))
;;; *FEATURES* should be set to a list of symbols describing features
;;; of this implementation. Suggestions for features are:
(define *features*
'(
source ;can load scheme source files
;(slib:load-source "filename")
compiled ;can load compiled files
;(slib:load-compiled "filename")
rev4-report ;conforms to
; rev3-report ;conforms to
; ieee-p1178 ;conforms to
; sicp ;runs code from Structure and
;Interpretation of Computer
;Programs by Abelson and Sussman.
rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
;LIST->STRING, STRING-COPY,
;STRING-FILL!, LIST->VECTOR,
;VECTOR->LIST, and VECTOR-FILL!
; rev3-procedures ;LAST-PAIR, T, and NIL
; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
;SUBSTRING-FILL!,
;STRING-NULL?, APPEND!, 1+,
;-1+, <?, <=?, =?, >?, >=?
multiarg/and- ;/ and - can take more than 2 args.
multiarg-apply ;APPLY can take more than 2 args.
; rationalize
delay ;has DELAY and FORCE
with-file ;has WITH-INPUT-FROM-FILE and
;WITH-OUTPUT-FROM-FILE
string-port ;has CALL-WITH-INPUT-STRING and
;CALL-WITH-OUTPUT-STRING
; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
; char-ready?
; macro ;has R4RS high level macros
; defmacro ;has Common Lisp DEFMACRO
eval ;SLIB:EVAL is single argument eval
; record ;has user defined data structures
; values ;proposed multiple values
dynamic-wind ;proposed dynamic-wind
ieee-floating-point ;conforms to
full-continuation ;can return multiple times
; object-hash ;has OBJECT-HASH
; sort ; commented because icomplete
; queue ;queues
; pretty-print
; object->string
; format
; compiler ;has (COMPILER)
ed ;(ED) is editor
system ;posix (system <string>)
getenv ;posix (getenv <string>)
; program-arguments ;returns list of strings (argv)
; Xwindows ;X support
; curses ;screen management package
; termcap ;terminal description package
; terminfo ;sysV terminal description
))
;;; (OUTPUT-PORT-WIDTH <port>)
(define (output-port-width . arg) 79)
;;; (OUTPUT-PORT-HEIGHT <port>)
(define (output-port-height . arg) 24)
;;; (TMPNAM) makes a temporary file name.
(define tmpnam (let ((cntr 100))
(lambda () (set! cntr (+ 1 cntr))
(string-append "slib_" (number->string cntr)))))
;;; (DELETE-FILE <string>)
(define (delete-file f) (system (format #f "/bin/rm ~A" f)))
;;; FORCE-OUTPUT flushes any pending output on optional arg output port
;;; use this definition if your system doesn't have such a procedure.
(define (force-output . arg) (apply flush arg))
;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
;;; be returned by CHAR->INTEGER.
(define char-code-limit 256)
;;; MOST-POSITIVE-FIXNUM is used in modular.scm
(define most-positive-fixnum #x0fffffff)
;;; If your implementation provides eval SLIB:EVAL is single argument
;;; eval using the top-level (user) environment.
(define slib:eval eval)
;;; If your implementation provides R4RS macros:
;(define macro:eval slib:eval)
;(define macro:load load)
(define *macros* '())
(define-macro (defmacro name args . body)
`(begin
(define-macro (,name ,@args) ,@body)
(set! *macros* (cons ,name *macros*))))
(define (defmacro? m) (and (memv m *macros*) #t))
(define macroexpand-1 MACRO-EXPAND-1)
(define macroexpand MACRO-EXPAND)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define gentemp GENSYM)
(define base:eval slib:eval)
(define (defmacro:eval x) (base:eval (defmacro:expand* x)))
(define (defmacro:expand* x)
(require 'defmacroexpand) (apply defmacro:expand* x '()))
(define (defmacro:load <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))))
(call-with-input-file <pathname>
(lambda (port)
(let ((old-load-pathname *load-pathname*))
(set! *load-pathname* <pathname>)
(do ((o (read port) (read port)))
((eof-object? o))
(evl o))
(set! *load-pathname* old-load-pathname)))))
(define slib:warn
(lambda args
(let ((cep (current-error-port)))
(if (provided? 'trace) (print-call-stack cep))
(display "Warn: " cep)
(for-each (lambda (x) (display x cep)) args))))
;;; define an error procedure for the library
(define (slib:error . args)
(if (provided? 'trace) (print-call-stack (current-error-port)))
(error (apply string-append (map (lambda (x) (format #f " ~a" x)) args))))
;;; define these as appropriate for your system.
(define slib:tab (integer->char 9))
(define slib:form-feed (integer->char 12))
;;; Define these if your implementation's syntax can support it and if
;;; they are not already defined.
(define -1+ 1-)
(define in-vicinity string-append)
;;; Define SLIB:EXIT to be the implementation procedure to exit or
;;; return if exitting not supported.
(define slib:exit exit)
;;; Here for backward compatability
(define scheme-file-suffix
(let ((suffix (case (software-type)
((NOSVE) "_scm")
(else ".scm"))))
(lambda () suffix)))
;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
;;; suffix all the module files in SLIB have. See feature 'SOURCE.
(define slib:load-source LOAD)
;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
;;; by compiling "foo.scm" if this implementation can compile files.
;;; See feature 'COMPILED.
(define slib:load-compiled load)
;;;
;;; Retain original require/provide before loading "require.scm"
;;;
(define stk:require require)
(define stk:provide provide)
(define stk:provided? provided?)
(define slib:load slib:load-source)
(slib:load (in-vicinity (library-vicinity) "require"))
;;;
;;; Redefine require/provide so that symbols use SLIB one and strings use STk one
;;;
(define require
(let ((slib:require require))
(lambda (item)
((if (symbol? item) slib:require stk:require) item ))))
(define provide
(let ((slib:provide provide))
(lambda (item)
((if (symbol? item) slib:provide stk:provide) item))))
(define provided?
(let ((slib:provided? provided?))
(lambda (item)
((if (symbol? item) slib:provided? stk:provided?) item))))
(define identity (lambda (x) x))

282
module/slib/Template.scm
View file

@ -1,282 +0,0 @@
;;; "Template.scm" configuration template of *features* for Scheme -*-scheme-*-
;;; Author: Aubrey Jaffer
;;;
;;; This code is in the public domain.
;;; (software-type) should be set to the generic operating system type.
;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
(define (software-type) 'UNIX)
;;; (scheme-implementation-type) should return the name of the scheme
;;; implementation loading this file.
(define (scheme-implementation-type) 'Template)
;;; (scheme-implementation-home-page) should return a (string) URI
;;; (Uniform Resource Identifier) for this scheme implementation's home
;;; page; or false if there isn't one.
(define (scheme-implementation-home-page) #f)
;;; (scheme-implementation-version) should return a string describing
;;; the version the scheme implementation loading this file.
(define (scheme-implementation-version) "?")
;;; (implementation-vicinity) should be defined to be the pathname of
;;; the directory where any auxillary files to your Scheme
;;; implementation reside.
(define (implementation-vicinity)
(case (software-type)
((UNIX) "/usr/local/src/scheme/")
((VMS) "scheme$src:")
((MS-DOS) "C:\\scheme\\")))
;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
(define library-vicinity
(let ((library-path
(or
;; Use this getenv if your implementation supports it.
(getenv "SCHEME_LIBRARY_PATH")
;; Use this path if your scheme does not support GETENV
;; or if SCHEME_LIBRARY_PATH is not set.
(case (software-type)
((UNIX) "/usr/local/lib/slib/")
((VMS) "lib$scheme:")
((MS-DOS) "C:\\SLIB\\")
(else "")))))
(lambda () library-path)))
;;; (home-vicinity) should return the vicinity of the user's HOME
;;; directory, the directory which typically contains files which
;;; customize a computer environment for a user.
(define home-vicinity
(let ((home-path (getenv "HOME")))
(lambda () home-path)))
;;; *FEATURES* should be set to a list of symbols describing features
;;; of this implementation. Suggestions for features are:
(define *features*
'(
source ;can load scheme source files
;(slib:load-source "filename")
; compiled ;can load compiled files
;(slib:load-compiled "filename")
; rev4-report ;conforms to
; rev3-report ;conforms to
; ieee-p1178 ;conforms to
; sicp ;runs code from Structure and
;Interpretation of Computer
;Programs by Abelson and Sussman.
; rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
;LIST->STRING, STRING-COPY,
;STRING-FILL!, LIST->VECTOR,
;VECTOR->LIST, and VECTOR-FILL!
; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
;SUBSTRING-FILL!,
;STRING-NULL?, APPEND!, 1+,
;-1+, <?, <=?, =?, >?, >=?
; multiarg/and- ;/ and - can take more than 2 args.
; multiarg-apply ;APPLY can take more than 2 args.
; rationalize
; delay ;has DELAY and FORCE
; with-file ;has WITH-INPUT-FROM-FILE and
;WITH-OUTPUT-FROM-FILE
; string-port ;has CALL-WITH-INPUT-STRING and
;CALL-WITH-OUTPUT-STRING
; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
; char-ready?
; macro ;has R4RS high level macros
; defmacro ;has Common Lisp DEFMACRO
; eval ;R5RS two-argument eval
; record ;has user defined data structures
; values ;proposed multiple values
; dynamic-wind ;proposed dynamic-wind
; ieee-floating-point ;conforms to
full-continuation ;can return multiple times
; object-hash ;has OBJECT-HASH
; sort
; queue ;queues
; pretty-print
; object->string
; format
; trace ;has macros: TRACE and UNTRACE
; compiler ;has (COMPILER)
; ed ;(ED) is editor
; system ;posix (system <string>)
getenv ;posix (getenv <string>)
; program-arguments ;returns list of strings (argv)
; Xwindows ;X support
; curses ;screen management package
; termcap ;terminal description package
; terminfo ;sysV terminal description
; current-time ;returns time in seconds since 1/1/1970
))
;;; (OUTPUT-PORT-WIDTH <port>)
(define (output-port-width . arg) 79)
;;; (OUTPUT-PORT-HEIGHT <port>)
(define (output-port-height . arg) 24)
;;; (CURRENT-ERROR-PORT)
(define current-error-port
(let ((port (current-output-port)))
(lambda () port)))
;;; (TMPNAM) makes a temporary file name.
(define tmpnam (let ((cntr 100))
(lambda () (set! cntr (+ 1 cntr))
(string-append "slib_" (number->string cntr)))))
;;; (FILE-EXISTS? <string>)
(define (file-exists? f) #f)
;;; (DELETE-FILE <string>)
(define (delete-file f) #f)
;;; FORCE-OUTPUT flushes any pending output on optional arg output port
;;; use this definition if your system doesn't have such a procedure.
(define (force-output . arg) #t)
;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
;;; port versions of CALL-WITH-*PUT-FILE.
;;; "rationalize" adjunct procedures.
;;(define (find-ratio x e)
;; (let ((rat (rationalize x e)))
;; (list (numerator rat) (denominator rat))))
;;(define (find-ratio-between x y)
;; (find-ratio (/ (+ x y) 2) (/ (- x y) 2)))
;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
;;; be returned by CHAR->INTEGER.
(define char-code-limit 256)
;;; MOST-POSITIVE-FIXNUM is used in modular.scm
(define most-positive-fixnum #x0FFFFFFF)
;;; Return argument
(define (identity x) x)
;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
(define slib:eval eval)
;;; If your implementation provides R4RS macros:
;(define macro:eval slib:eval)
;(define macro:load load)
(define *defmacros*
(list (cons 'defmacro
(lambda (name parms . body)
`(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body))
*defmacros*))))))
(define (defmacro? m) (and (assq m *defmacros*) #t))
(define (macroexpand-1 e)
(if (pair? e) (let ((a (car e)))
(cond ((symbol? a) (set! a (assq a *defmacros*))
(if a (apply (cdr a) (cdr e)) e))
(else e)))
e))
(define (macroexpand e)
(if (pair? e) (let ((a (car e)))
(cond ((symbol? a)
(set! a (assq a *defmacros*))
(if a (macroexpand (apply (cdr a) (cdr e))) e))
(else e)))
e))
(define gentemp
(let ((*gensym-counter* -1))
(lambda ()
(set! *gensym-counter* (+ *gensym-counter* 1))
(string->symbol
(string-append "slib:G" (number->string *gensym-counter*))))))
(define base:eval slib:eval)
(define (defmacro:eval x) (base:eval (defmacro:expand* x)))
(define (defmacro:expand* x)
(require 'defmacroexpand) (apply defmacro:expand* x '()))
(define (slib:eval-load <pathname> evl)
(if (not (file-exists? <pathname>))
(set! <pathname> (string-append <pathname> (scheme-file-suffix))))
(call-with-input-file <pathname>
(lambda (port)
(let ((old-load-pathname *load-pathname*))
(set! *load-pathname* <pathname>)
(do ((o (read port) (read port)))
((eof-object? o))
(evl o))
(set! *load-pathname* old-load-pathname)))))
(define (defmacro:load <pathname>)
(slib:eval-load <pathname> defmacro:eval))
(define slib:warn
(lambda args
(let ((cep (current-error-port)))
(if (provided? 'trace) (print-call-stack cep))
(display "Warn: " cep)
(for-each (lambda (x) (display x cep)) args))))
;;; define an error procedure for the library
(define (slib:error . args)
(if (provided? 'trace) (print-call-stack (current-error-port)))
(apply error args))
;;; define these as appropriate for your system.
(define slib:tab (integer->char 9))
(define slib:form-feed (integer->char 12))
;;; Support for older versions of Scheme. Not enough code for its own file.
(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))
(define t #t)
(define nil #f)
;;; Define these if your implementation's syntax can support it and if
;;; they are not already defined.
;(define (1+ n) (+ n 1))
;(define (-1+ n) (+ n -1))
;(define 1- -1+)
(define in-vicinity string-append)
;;; Define SLIB:EXIT to be the implementation procedure to exit or
;;; return if exitting not supported.
(define slib:exit (lambda args #f))
;;; Here for backward compatability
(define scheme-file-suffix
(let ((suffix (case (software-type)
((NOSVE) "_scm")
(else ".scm"))))
(lambda () suffix)))
;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
;;; suffix all the module files in SLIB have. See feature 'SOURCE.
(define (slib:load-source f) (load (string-append f ".scm")))
;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
;;; by compiling "foo.scm" if this implementation can compile files.
;;; See feature 'COMPILED.
(define slib:load-compiled load)
;;; At this point SLIB:LOAD must be able to load SLIB files.
(define slib:load slib:load-source)
(slib:load (in-vicinity (library-vicinity) "require"))

66
module/slib/alist.scm
View file

@ -1,66 +0,0 @@
;;;"alist.scm", alist functions for Scheme.
;;;Copyright (c) 1992, 1993 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(define (predicate->asso pred)
(cond ((eq? eq? pred) assq)
((eq? = pred) assv)
((eq? eqv? pred) assv)
((eq? char=? pred) assv)
((eq? equal? pred) assoc)
((eq? string=? pred) assoc)
(else (lambda (key alist)
(let l ((al alist))
(cond ((null? al) #f)
((pred key (caar al)) (car al))
(else (l (cdr al)))))))))
(define (alist-inquirer pred)
(let ((assofun (predicate->asso pred)))
(lambda (alist key)
(let ((pair (assofun key alist)))
(and pair (cdr pair))))))
(define (alist-associator pred)
(let ((assofun (predicate->asso pred)))
(lambda (alist key val)
(let* ((pair (assofun key alist)))
(cond (pair (set-cdr! pair val)
alist)
(else (cons (cons key val) alist)))))))
(define (alist-remover pred)
(lambda (alist key)
(cond ((null? alist) alist)
((pred key (caar alist)) (cdr alist))
((null? (cdr alist)) alist)
((pred key (caadr alist))
(set-cdr! alist (cddr alist)) alist)
(else
(let l ((al (cdr alist)))
(cond ((null? (cdr al)) alist)
((pred key (caadr al))
(set-cdr! al (cddr al)) alist)
(else (l (cdr al)))))))))
(define (alist-map proc alist)
(map (lambda (pair) (cons (car pair) (proc (car pair) (cdr pair))))
alist))
(define (alist-for-each proc alist)
(for-each (lambda (pair) (proc (car pair) (cdr pair))) alist))

352
module/slib/alistab.scm
View file

@ -1,352 +0,0 @@
;;; "alistab.scm" database tables using association lists (assoc)
; Copyright 1994, 1997 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;;; LLDB is (filename . alist-table)
;;; HANDLE is (#(table-name key-dim) . TABLE)
;;; TABLE is an alist of (Primary-key . ROW)
;;; ROW is a list of non-primary VALUEs
(require 'common-list-functions)
(define alist-table
(let ((catalog-id 0)
(resources '*base-resources*)
(make-list-keyifier (lambda (prinum types) identity))
(make-keyifier-1 (lambda (type) list))
(make-key->list (lambda (prinum types) identity))
(make-key-extractor (lambda (primary-limit column-type-list index)
(let ((i (+ -1 index)))
(lambda (lst) (list-ref lst i))))))
(define keyify-1 (make-keyifier-1 'atom))
(define (make-base filename dim types)
(list filename
(list catalog-id)
(list resources (list 'free-id 1))))
(define (open-base infile writable)
(and (or (input-port? infile) (file-exists? infile))
(cons (if (input-port? infile) #f infile)
((lambda (fun)
(if (input-port? infile)
(fun infile)
(call-with-input-file infile fun)))
read))))
(define (write-base lldb outfile)
((lambda (fun)
(cond ((output-port? outfile) (fun outfile))
((string? outfile) (call-with-output-file outfile fun))
(else #f)))
(lambda (port)
(display (string-append
";;; \"" outfile "\" SLIB alist-table database -*-scheme-*-")
port)
(newline port) (newline port)
(display "(" port) (newline port)
(for-each
(lambda (table)
(display " (" port)
(write (car table) port) (newline port)
(for-each
(lambda (row)
(display " " port) (write row port) (newline port))
(cdr table))
(display " )" port) (newline port))
(cdr lldb))
(display ")" port) (newline port)
; (require 'pretty-print)
; (pretty-print (cdr lldb) port)
(set-car! lldb (if (string? outfile) outfile #f))
#t)))
(define (sync-base lldb)
(cond ((car lldb) (write-base lldb (car lldb)) #t)
(else
;;; (display "sync-base: database filename not known")
#f)))
(define (close-base lldb)
(cond ((car lldb) (write-base lldb (car lldb))
(set-cdr! lldb #f)
(set-car! lldb #f) #t)
((cdr lldb) (set-cdr! lldb #f)
(set-car! lldb #f) #t)
(else
;;; (display "close-base: database not open")
#f)))
(define (make-table lldb dim types)
(let ((free-hand (open-table lldb resources 1 '(atom integer))))
(and free-hand
(let* ((row (assoc* (keyify-1 'free-id) (handle->alist free-hand)))
(table-id #f))
(cond (row
(set! table-id (cadr row))
(set-car! (cdr row) (+ 1 table-id))
(set-cdr! lldb (cons (list table-id) (cdr lldb)))
table-id)
(else #f))))))
(define (open-table lldb base-id dim types)
(assoc base-id (cdr lldb)))
(define (kill-table lldb base-id dim types)
(define ckey (list base-id))
(let ((pair (assoc* ckey (cdr lldb))))
(and pair (set-cdr! lldb (delete-assoc ckey (cdr lldb))))
(and pair (not (assoc* ckey (cdr lldb))))))
(define handle->alist cdr)
(define set-handle-alist! set-cdr!)
(define (assoc* keys alist)
(let ((pair (assoc (car keys) alist)))
(cond ((not pair) #f)
((null? (cdr keys)) pair)
(else (assoc* (cdr keys) (cdr pair))))))
(define (make-assoc* keys alist vals)
(let ((pair (assoc (car keys) alist)))
(cond ((not pair) (cons (cons (car keys)
(if (null? (cdr keys))
vals
(make-assoc* (cdr keys) '() vals)))
alist))
(else (set-cdr! pair (if (null? (cdr keys))
vals
(make-assoc* (cdr keys) (cdr pair) vals)))
alist))))
(define (delete-assoc ckey alist)
(cond
((null? ckey) '())
((assoc (car ckey) alist)
=> (lambda (match)
(let ((adl (delete-assoc (cdr ckey) (cdr match))))
(cond ((null? adl) (delete match alist))
(else (set-cdr! match adl) alist)))))
(else alist)))
(define (delete-assoc* ckey alist)
(cond
((every not ckey) '()) ;includes the null case.
((not (car ckey))
(delete '()
(map (lambda (fodder)
(let ((adl (delete-assoc* (cdr ckey) (cdr fodder))))
(if (null? adl) '() (cons (car fodder) adl))))
alist)))
((procedure? (car ckey))
(delete '()
(map (lambda (fodder)
(if ((car ckey) (car fodder))
(let ((adl (delete-assoc* (cdr ckey) (cdr fodder))))
(if (null? adl) '() (cons (car fodder) adl)))
fodder))
alist)))
((assoc (car ckey) alist)
=> (lambda (match)
(let ((adl (delete-assoc* (cdr ckey) (cdr match))))
(cond ((null? adl) (delete match alist))
(else (set-cdr! match adl) alist)))))
(else alist)))
(define (assoc*-for-each proc bkey ckey alist)
(cond ((null? ckey) (proc (reverse bkey)))
((not (car ckey))
(for-each (lambda (alist)
(assoc*-for-each proc
(cons (car alist) bkey)
(cdr ckey)
(cdr alist)))
alist))
((procedure? (car ckey))
(for-each (lambda (alist)
(if ((car ckey) (car alist))
(assoc*-for-each proc
(cons (car alist) bkey)
(cdr ckey)
(cdr alist))))
alist))
((assoc (car ckey) alist)
=> (lambda (match)
(assoc*-for-each proc
(cons (car match) bkey)
(cdr ckey)
(cdr match))))))
(define (assoc*-map proc bkey ckey alist)
(cond ((null? ckey) (list (proc (reverse bkey))))
((not (car ckey))
(apply append
(map (lambda (alist)
(assoc*-map proc
(cons (car alist) bkey)
(cdr ckey)
(cdr alist)))
alist)))
((procedure? (car ckey))
(apply append
(map (lambda (alist)
(if ((car ckey) (car alist))
(assoc*-map proc
(cons (car alist) bkey)
(cdr ckey)
(cdr alist))
'()))
alist)))
((assoc (car ckey) alist)
=> (lambda (match)
(assoc*-map proc
(cons (car match) bkey)
(cdr ckey)
(cdr match))))
(else '())))
(define (sorted-assoc*-for-each proc bkey ckey alist)
(cond ((null? ckey) (proc (reverse bkey)))
((not (car ckey))
(for-each (lambda (alist)
(sorted-assoc*-for-each proc
(cons (car alist) bkey)
(cdr ckey)
(cdr alist)))
(alist-sort! alist)))
((procedure? (car ckey))
(sorted-assoc*-for-each proc
bkey
(cons #f (cdr ckey))
(remove-if-not (lambda (pair)
((car ckey) (car pair)))
alist)))
((assoc (car ckey) alist)
=> (lambda (match)
(sorted-assoc*-for-each proc
(cons (car match) bkey)
(cdr ckey)
(cdr match))))))
(define (alist-sort! alist)
(define (key->sortable k)
(cond ((number? k) k)
((string? k) k)
((symbol? k) (symbol->string k))
((vector? k) (map key->sortable (vector->list k)))
(else (slib:error "unsortable key" k))))
;; This routine assumes that the car of its operands are either
;; numbers or strings (or lists of those).
(define (car-key-< x y)
(key-< (car x) (car y)))
(define (key-< x y)
(cond ((and (number? x) (number? y)) (< x y))
((number? x) #t)
((number? y) #f)
((string? x) (string<? x y))
((key-< (car x) (car y)) #t)
((key-< (car y) (car x)) #f)
(else (key-< (cdr x) (cdr y)))))
(require 'sort)
(map cdr (sort! (map (lambda (p)
(cons (key->sortable (car p)) p))
alist)
car-key-<)))
(define (present? handle ckey)
(assoc* ckey (handle->alist handle)))
(define (make-putter prinum types)
(lambda (handle ckey restcols)
(set-handle-alist! handle
(make-assoc* ckey (handle->alist handle) restcols))))
(define (make-getter prinum types)
(lambda (handle ckey)
(let ((row (assoc* ckey (handle->alist handle))))
(and row (cdr row)))))
(define (for-each-key handle operation primary-limit column-type-list match-keys)
(assoc*-for-each operation
'()
match-keys
(handle->alist handle)))
(define (map-key handle operation primary-limit column-type-list match-keys)
(assoc*-map operation
'()
match-keys
(handle->alist handle)))
(define (ordered-for-each-key handle operation
primary-limit column-type-list match-keys)
(sorted-assoc*-for-each operation
'()
match-keys
(handle->alist handle)))
(define (supported-type? type)
(case type
((base-id atom integer boolean string symbol expression number) #t)
(else #f)))
(define (supported-key-type? type)
(case type
((atom integer number symbol string) #t)
(else #f)))
;;make-table open-table remover assoc* make-assoc*
;;(trace assoc*-for-each assoc*-map sorted-assoc*-for-each)
(lambda (operation-name)
(case operation-name
((make-base) make-base)
((open-base) open-base)
((write-base) write-base)
((sync-base) sync-base)
((close-base) close-base)
((catalog-id) catalog-id)
((make-table) make-table)
((open-table) open-table)
((kill-table) kill-table)
((make-keyifier-1) make-keyifier-1)
((make-list-keyifier) make-list-keyifier)
((make-key->list) make-key->list)
((make-key-extractor) make-key-extractor)
((supported-type?) supported-type?)
((supported-key-type?) supported-key-type?)
((present?) present?)
((make-putter) make-putter)
((make-getter) make-getter)
((delete)
(lambda (handle ckey)
(set-handle-alist! handle
(delete-assoc ckey (handle->alist handle)))))
((delete*)
(lambda (handle primary-limit column-type-list match-keys)
(set-handle-alist! handle
(delete-assoc* match-keys
(handle->alist handle)))))
((for-each-key) for-each-key)
((map-key) map-key)
((ordered-for-each-key) ordered-for-each-key)
(else #f)))
))
;; #f (trace-all "/home/jaffer/slib/alistab.scm") (untrace alist-table) (set! *qp-width* 333)

279
module/slib/array.scm
View file

@ -1,279 +0,0 @@
;;;;"array.scm" Arrays for Scheme
; Copyright (C) 1993 Alan Bawden
;
; Permission to copy this software, to redistribute it, and to use it
; for any purpose is granted, subject to the following restrictions and
; understandings.
;
; 1. Any copy made of this software must include this copyright notice
; in full.
;
; 2. Users of this software agree to make their best efforts (a) to
; return to me any improvements or extensions that they make, so that
; these may be included in future releases; and (b) to inform me of
; noteworthy uses of this software.
;
; 3. I have made no warrantee or representation that the operation of
; this software will be error-free, and I am under no obligation to
; provide any services, by way of maintenance, update, or otherwise.
;
; 4. In conjunction with products arising from the use of this material,
; there shall be no use of my name in any advertising, promotional, or
; sales literature without prior written consent in each case.
;
; Alan Bawden
; MIT Room NE43-510
; 545 Tech. Sq.
; Cambridge, MA 02139
; Alan@LCS.MIT.EDU
(require 'record)
;(declare (usual-integrations))
(define array:rtd
(make-record-type "Array"
'(indexer ; Must be a -linear- function!
shape ; Inclusive bounds: ((lower upper) ...)
vector ; The actual contents
)))
(define array:indexer (record-accessor array:rtd 'indexer))
(define array-shape (record-accessor array:rtd 'shape))
(define array:vector (record-accessor array:rtd 'vector))
(define array? (record-predicate array:rtd))
(define (array-rank obj)
(if (array? obj) (length (array-shape obj)) 0))
(define (array-dimensions ra)
(map (lambda (ind) (if (zero? (car ind)) (+ 1 (cadr ind)) ind))
(array-shape ra)))
(define array:construct
(record-constructor array:rtd '(shape vector indexer)))
(define (array:compute-shape specs)
(map (lambda (spec)
(cond ((and (integer? spec)
(< 0 spec))
(list 0 (- spec 1)))
((and (pair? spec)
(pair? (cdr spec))
(null? (cddr spec))
(integer? (car spec))
(integer? (cadr spec))
(<= (car spec) (cadr spec)))
spec)
(else (slib:error "array: Bad array dimension: " spec))))
specs))
(define (make-array initial-value . specs)
(let ((shape (array:compute-shape specs)))
(let loop ((size 1)
(indexer (lambda () 0))
(l (reverse shape)))
(if (null? l)
(array:construct shape
(make-vector size initial-value)
(array:optimize-linear-function indexer shape))
(loop (* size (+ 1 (- (cadar l) (caar l))))
(lambda (first-index . rest-of-indices)
(+ (* size (- first-index (caar l)))
(apply indexer rest-of-indices)))
(cdr l))))))
(define (make-shared-array array mapping . specs)
(let ((new-shape (array:compute-shape specs))
(old-indexer (array:indexer array)))
(let check ((indices '())
(bounds (reverse new-shape)))
(cond ((null? bounds)
(array:check-bounds array (apply mapping indices)))
(else
(check (cons (caar bounds) indices) (cdr bounds))
(check (cons (cadar bounds) indices) (cdr bounds)))))
(array:construct new-shape
(array:vector array)
(array:optimize-linear-function
(lambda indices
(apply old-indexer (apply mapping indices)))
new-shape))))
(define (array:in-bounds? array indices)
(let loop ((indices indices)
(shape (array-shape array)))
(if (null? indices)
(null? shape)
(let ((index (car indices)))
(and (not (null? shape))
(integer? index)
(<= (caar shape) index (cadar shape))
(loop (cdr indices) (cdr shape)))))))
(define (array:check-bounds array indices)
(or (array:in-bounds? array indices)
(slib:error "array: Bad indices for " array indices)))
(define (array-ref array . indices)
(array:check-bounds array indices)
(vector-ref (array:vector array)
(apply (array:indexer array) indices)))
(define (array-set! array new-value . indices)
(array:check-bounds array indices)
(vector-set! (array:vector array)
(apply (array:indexer array) indices)
new-value))
(define (array-in-bounds? array . indices)
(array:in-bounds? array indices))
; Fast versions of ARRAY-REF and ARRAY-SET! that do no error checking,
; and don't cons intermediate lists of indices:
(define (array-1d-ref a i0)
(vector-ref (array:vector a) ((array:indexer a) i0)))
(define (array-2d-ref a i0 i1)
(vector-ref (array:vector a) ((array:indexer a) i0 i1)))
(define (array-3d-ref a i0 i1 i2)
(vector-ref (array:vector a) ((array:indexer a) i0 i1 i2)))
(define (array-1d-set! a v i0)
(vector-set! (array:vector a) ((array:indexer a) i0) v))
(define (array-2d-set! a v i0 i1)
(vector-set! (array:vector a) ((array:indexer a) i0 i1) v))
(define (array-3d-set! a v i0 i1 i2)
(vector-set! (array:vector a) ((array:indexer a) i0 i1 i2) v))
; STOP! Do not read beyond this point on your first reading of
; this code -- you should simply assume that the rest of this file
; contains only the following single definition:
;
; (define (array:optimize-linear-function f l) f)
;
; Of course everything would be pretty inefficient if this were really the
; case, but it isn't. The following code takes advantage of the fact that
; you can learn everything there is to know from a linear function by
; simply probing around in its domain and observing its values -- then a
; more efficient equivalent can be constructed.
(define (array:optimize-linear-function f l)
(let ((d (length l)))
(cond
((= d 0)
(array:0d-c (f)))
((= d 1)
(let ((c (f 0)))
(array:1d-c0 c (- (f 1) c))))
((= d 2)
(let ((c (f 0 0)))
(array:2d-c01 c (- (f 1 0) c) (- (f 0 1) c))))
((= d 3)
(let ((c (f 0 0 0)))
(array:3d-c012 c (- (f 1 0 0) c) (- (f 0 1 0) c) (- (f 0 0 1) c))))
(else
(let* ((v (map (lambda (x) 0) l))
(c (apply f v)))
(let loop ((p v)
(old-val c)
(coefs '()))
(cond ((null? p)
(array:Nd-c* c (reverse coefs)))
(else
(set-car! p 1)
(let ((new-val (apply f v)))
(loop (cdr p)
new-val
(cons (- new-val old-val) coefs)))))))))))
; 0D cases:
(define (array:0d-c c)
(lambda () c))
; 1D cases:
(define (array:1d-c c)
(lambda (i0) (+ c i0)))
(define (array:1d-0 n0)
(cond ((= 1 n0) +)
(else (lambda (i0) (* n0 i0)))))
(define (array:1d-c0 c n0)
(cond ((= 0 c) (array:1d-0 n0))
((= 1 n0) (array:1d-c c))
(else (lambda (i0) (+ c (* n0 i0))))))
; 2D cases:
(define (array:2d-0 n0)
(lambda (i0 i1) (+ (* n0 i0) i1)))
(define (array:2d-1 n1)
(lambda (i0 i1) (+ i0 (* n1 i1))))
(define (array:2d-c0 c n0)
(lambda (i0 i1) (+ c (* n0 i0) i1)))
(define (array:2d-c1 c n1)
(lambda (i0 i1) (+ c i0 (* n1 i1))))
(define (array:2d-01 n0 n1)
(cond ((= 1 n0) (array:2d-1 n1))
((= 1 n1) (array:2d-0 n0))
(else (lambda (i0 i1) (+ (* n0 i0) (* n1 i1))))))
(define (array:2d-c01 c n0 n1)
(cond ((= 0 c) (array:2d-01 n0 n1))
((= 1 n0) (array:2d-c1 c n1))
((= 1 n1) (array:2d-c0 c n0))
(else (lambda (i0 i1) (+ c (* n0 i0) (* n1 i1))))))
; 3D cases:
(define (array:3d-01 n0 n1)
(lambda (i0 i1 i2) (+ (* n0 i0) (* n1 i1) i2)))
(define (array:3d-02 n0 n2)
(lambda (i0 i1 i2) (+ (* n0 i0) i1 (* n2 i2))))
(define (array:3d-12 n1 n2)
(lambda (i0 i1 i2) (+ i0 (* n1 i1) (* n2 i2))))
(define (array:3d-c12 c n1 n2)
(lambda (i0 i1 i2) (+ c i0 (* n1 i1) (* n2 i2))))
(define (array:3d-c02 c n0 n2)
(lambda (i0 i1 i2) (+ c (* n0 i0) i1 (* n2 i2))))
(define (array:3d-c01 c n0 n1)
(lambda (i0 i1 i2) (+ c (* n0 i0) (* n1 i1) i2)))
(define (array:3d-012 n0 n1 n2)
(cond ((= 1 n0) (array:3d-12 n1 n2))
((= 1 n1) (array:3d-02 n0 n2))
((= 1 n2) (array:3d-01 n0 n1))
(else (lambda (i0 i1 i2) (+ (* n0 i0) (* n1 i1) (* n2 i2))))))
(define (array:3d-c012 c n0 n1 n2)
(cond ((= 0 c) (array:3d-012 n0 n1 n2))
((= 1 n0) (array:3d-c12 c n1 n2))
((= 1 n1) (array:3d-c02 c n0 n2))
((= 1 n2) (array:3d-c01 c n0 n1))
(else (lambda (i0 i1 i2) (+ c (* n0 i0) (* n1 i1) (* n2 i2))))))
; ND cases:
(define (array:Nd-* coefs)
(lambda indices (apply + (map * coefs indices))))
(define (array:Nd-c* c coefs)
(cond ((= 0 c) (array:Nd-* coefs))
(else (lambda indices (apply + c (map * coefs indices))))))

78
module/slib/arraymap.scm
View file

@ -1,78 +0,0 @@
;;;; "arraymap.scm", applicative routines for arrays in Scheme.
;;; Copyright (c) 1993 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'array)
(define (array-map! ra0 proc . ras)
(define (ramap rshape inds)
(if (null? (cdr rshape))
(do ((i (cadar rshape) (+ -1 i))
(is (cons (cadar rshape) inds)
(cons (+ -1 i) inds)))
((< i (caar rshape)))
(apply array-set! ra0
(apply proc (map (lambda (ra) (apply array-ref ra is))
ras))
is))
(let ((crshape (cdr rshape))
(ll (caar rshape)))
(do ((i (cadar rshape) (+ -1 i)))
((< i ll))
(ramap crshape (cons i inds))))))
(ramap (reverse (array-shape ra0)) '()))
(define (array-for-each proc . ras)
(define (rafe rshape inds)
(if (null? (cdr rshape))
(do ((i (caar rshape) (+ 1 i)))
((> i (cadar rshape)))
(apply proc
(map (lambda (ra)
(apply array-ref ra (reverse (cons i inds)))) ras)))
(let ((crshape (cdr rshape))
(ll (cadar rshape)))
(do ((i (caar rshape) (+ 1 i)))
((> i ll))
(rafe crshape (cons i inds))))))
(rafe (array-shape (car ras)) '()))
(define (array-index-map! ra fun)
(define (ramap rshape inds)
(if (null? (cdr rshape))
(do ((i (cadar rshape) (+ -1 i))
(is (cons (cadar rshape) inds)
(cons (+ -1 i) inds)))
((< i (caar rshape)))
(apply array-set! ra (apply fun is) is))
(let ((crshape (cdr rshape))
(ll (caar rshape)))
(do ((i (cadar rshape) (+ -1 i)))
((< i ll))
(ramap crshape (cons i inds))))))
(if (zero? (array-rank ra))
(array-set! ra (fun))
(ramap (reverse (array-shape ra)) '())))
(define (array-indexes ra)
(let ((ra0 (apply make-array '() (array-shape ra))))
(array-index-map! ra0 list)
ra0))
(define (array-copy! source dest)
(array-map! dest identity source))

454
module/slib/batch.scm
View file

@ -1,454 +0,0 @@
;;; "batch.scm" Group and execute commands on various systems.
;Copyright (C) 1994, 1995, 1997 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'line-i/o) ;Just for write-line
(require 'parameters)
(require 'database-utilities)
(require 'string-port)
(require 'tree)
(define system
(if (provided? 'system)
system
(lambda (str) 1)))
(define system:success?
(case (software-type)
((VMS) (lambda (int) (eqv? 1 int)))
(else zero?)))
;;(trace system system:success? exit quit slib:exit)
(define (batch:port parms)
(let ((bp (parameter-list-ref parms 'batch-port)))
(cond ((or (not (pair? bp)) (not (output-port? (car bp))))
(slib:warn 'batch-line "missing batch-port parameter" bp)
(current-output-port))
(else (car bp)))))
(define (batch:dialect parms) ; was batch-family
(car (parameter-list-ref parms 'batch-dialect)))
(define (write-batch-line str line-limit port)
(cond ((and line-limit (>= (string-length str) line-limit))
(slib:warn 'write-batch-line 'too-long
(string-length str) '> line-limit)
#f)
(else (write-line str port) #t)))
(define (batch-line parms str)
(write-batch-line str (batch:line-length-limit parms) (batch:port parms)))
;;; add a Scheme batch-dialect?
(define (batch:try-chopped-command parms . args)
(define args-but-last (batch:flatten (butlast args 1)))
(define line-limit (batch:line-length-limit parms))
(let loop ((fodder (car (last-pair args))))
(let ((str (batch:glued-line parms
(batch:flatten
(append args-but-last (list fodder))))))
(cond ((< (string-length str) line-limit)
(batch:try-command parms str))
((< (length fodder) 2)
(slib:warn 'batch:try-chopped-command "can't fit in " line-limit
(cons proc (append args-but-last (list fodder))))
#f)
(else (let ((hlen (quotient (length fodder) 2)))
(and (loop (last fodder hlen))
(loop (butlast fodder hlen)))))))))
(define (batch:glued-line parms strings)
(case (batch:dialect parms)
((vms) (apply string-join " " "$" strings))
((unix dos amigados system *unknown*) (apply string-join " " strings))
(else #f)))
(define (batch:try-command parms . strings)
(set! strings (batch:flatten strings))
(let ((line (batch:glued-line parms strings)))
(and line
(case (batch:dialect parms)
((unix dos vms amigados) (batch-line parms line))
((system)
(let ((port (batch:port parms)))
(write `(system ,line) port) (newline port)
(and (provided? 'system) (system:success? (system line)))))
((*unknown*)
(let ((port (batch:port parms)))
(write `(system ,line) port) (newline port) #t))
(else #f)))))
(define (batch:command parms . strings)
(cond ((apply batch:try-command parms strings))
(else (slib:error 'batch:command 'failed strings))))
(define (batch:run-script parms name . strings)
(case (batch:dialect parms strings)
((vms) (batch:command parms (string-append "@" name) strings))
(else (batch:command parms name strings))))
(define (batch:write-comment-line dialect line port)
(case dialect
((unix) (write-batch-line (string-append "# " line) #f port))
((dos) (write-batch-line (string-append "rem " line) #f port))
((vms) (write-batch-line (string-append "$! " line) #f port))
((amigados) (write-batch-line (string-append "; " line) #f port))
((system) (write-batch-line (string-append "; " line) #f port))
((*unknown*) (write-batch-line (string-append ";;; " line) #f port)
;;(newline port)
#f)))
(define (batch:comment parms . lines)
(define port (batch:port parms))
(define dialect (batch:dialect parms))
(set! lines (batch:flatten lines))
(every (lambda (line)
(batch:write-comment-line dialect line port))
lines))
(define (batch:lines->file parms file . lines)
(define port (batch:port parms))
(set! lines (batch:flatten lines))
(case (or (batch:dialect parms) '*unknown*)
((unix) (batch-line parms (string-append "rm -f " file))
(every
(lambda (string)
(batch-line parms (string-append "echo '" string "'>>" file)))
lines))
((dos) (batch-line parms (string-append "DEL " file))
(every
(lambda (string)
(batch-line parms
(string-append "ECHO" (if (equal? "" string) "." " ")
string ">>" file)))
lines))
((vms) (and (batch-line parms (string-append "$DELETE " file))
(batch-line parms (string-append "$CREATE " file))
(batch-line parms (string-append "$DECK"))
(every (lambda (string) (batch-line parms string))
lines)
(batch-line parms (string-append "$EOD"))))
((amigados) (batch-line parms (string-append "delete force " file))
(every
(lambda (str)
(letrec ((star-quote
(lambda (str)
(if (equal? "" str)
str
(let* ((ch (string-ref str 0))
(s (if (char=? ch #\")
(string #\* ch)
(string ch))))
(string-append
s
(star-quote
(substring str 1 (string-length str)))))))))
(batch-line parms (string-append "echo \"" (star-quote str)
"\" >> " file))))
lines))
((system) (write `(delete-file ,file) port) (newline port)
(delete-file file)
(require 'pretty-print)
(pretty-print `(call-with-output-file ,file
(lambda (fp)
(for-each
(lambda (string) (write-line string fp))
',lines)))
port)
(call-with-output-file file
(lambda (fp) (for-each (lambda (string) (write-line string fp))
lines)))
#t)
((*unknown*)
(write `(delete-file ,file) port) (newline port)
(require 'pretty-print)
(pretty-print
`(call-with-output-file ,file
(lambda (fp)
(for-each
(lambda (string)
(write-line string fp))
,lines)))
port)
#f)))
(define (batch:delete-file parms file)
(define port (batch:port parms))
(case (batch:dialect parms)
((unix) (batch-line parms (string-append "rm -f " file))
#t)
((dos) (batch-line parms (string-append "DEL " file))
#t)
((vms) (batch-line parms (string-append "$DELETE " file))
#t)
((amigados) (batch-line parms (string-append "delete force " file))
#t)
((system) (write `(delete-file ,file) port) (newline port)
(delete-file file)) ; SLIB provides
((*unknown*) (write `(delete-file ,file) port) (newline port)
#f)))
(define (batch:rename-file parms old-name new-name)
(define port (batch:port parms))
(case (batch:dialect parms)
((unix) (batch-line parms (string-join " " "mv -f" old-name new-name)))
;;((dos) (batch-line parms (string-join " " "REN" old-name new-name)))
((dos) (batch-line parms (string-join " " "MOVE" "/Y" old-name new-name)))
((vms) (batch-line parms (string-join " " "$RENAME" old-name new-name)))
((amigados) (batch-line parms (string-join " " "failat 21"))
(batch-line parms (string-join " " "delete force" new-name))
(batch-line parms (string-join " " "rename" old-name new-name)))
((system) (batch:extender 'rename-file batch:rename-file))
((*unknown*) (write `(rename-file ,old-name ,new-name) port)
(newline port)
#f)))
(define (batch:write-header-comment dialect name port)
(batch:write-comment-line
dialect
(string-append (if (string? name)
(string-append "\"" name "\"")
(case dialect
((system *unknown*) "Scheme")
((vms) "VMS")
((dos) "DOS")
((default-for-platform) "??")
(else (symbol->string dialect))))
" script created by SLIB/batch "
(cond ((provided? 'bignum)
(require 'posix-time)
(let ((ct (ctime (current-time))))
(substring ct 0 (+ -1 (string-length ct)))))
(else "")))
port))
(define (batch:call-with-output-script parms name proc)
(define dialect (batch:dialect parms))
(case dialect
((unix) ((cond ((and (string? name) (provided? 'system))
(lambda (proc)
(let ((ans (call-with-output-file name proc)))
(system (string-append "chmod +x " name))
ans)))
((output-port? name) (lambda (proc) (proc name)))
(else (lambda (proc) (proc (current-output-port)))))
(lambda (port)
(write-line "#!/bin/sh" port)
(batch:write-header-comment dialect name port)
(proc port))))
((dos) ((cond ((string? name)
(lambda (proc)
(call-with-output-file (string-append name ".bat") proc)))
((output-port? name) (lambda (proc) (proc name)))
(else (lambda (proc) (proc (current-output-port)))))
(lambda (port)
(batch:write-header-comment dialect name port)
(proc port))))
((vms) ((cond ((string? name)
(lambda (proc)
(call-with-output-file (string-append name ".COM") proc)))
((output-port? name) (lambda (proc) (proc name)))
(else (lambda (proc) (proc (current-output-port)))))
(lambda (port)
(batch:write-header-comment dialect name port)
;;(write-line "$DEFINE/USER SYS$OUTPUT BUILD.LOG" port)
(proc port))))
((amigados) ((cond ((and (string? name) (provided? 'system))
(lambda (proc)
(let ((ans (call-with-output-file name proc)))
(system (string-append "protect " name " rswd"))
ans)))
((output-port? name) (lambda (proc) (proc name)))
(else (lambda (proc) (proc (current-output-port)))))
(lambda (port)
(batch:write-header-comment dialect name port)
(proc port))))
((system) ((cond ((and (string? name) (provided? 'system))
(lambda (proc)
(let ((ans (call-with-output-file name
(lambda (port) (proc name)))))
(system (string-append "chmod +x " name))
ans)))
((output-port? name) (lambda (proc) (proc name)))
(else (lambda (proc) (proc (current-output-port)))))
(lambda (port)
(batch:write-header-comment dialect name port)
(proc port))))
((*unknown*) ((cond ((and (string? name) (provided? 'system))
(lambda (proc)
(let ((ans (call-with-output-file name
(lambda (port) (proc name)))))
(system (string-append "chmod +x " name))
ans)))
((output-port? name) (lambda (proc) (proc name)))
(else (lambda (proc) (proc (current-output-port)))))
(lambda (port)
(batch:write-header-comment dialect name port)
(proc port))))))
;;; This little ditty figures out how to use a Scheme extension or
;;; SYSTEM to execute a command that is not available in the batch
;;; mode chosen.
(define (batch:extender NAME BATCHER)
(lambda (parms . args)
(define port (batch:port parms))
(cond
((provided? 'i/o-extensions) ; SCM specific
(write `(,NAME ,@args) port)
(newline port)
(apply (slib:eval NAME) args))
((not (provided? 'system)) #f)
(else
(let ((pl (make-parameter-list (map car parms))))
(adjoin-parameters!
pl (cons 'batch-dialect (os->batch-dialect
(parameter-list-ref parms 'platform))))
(system
(call-with-output-string
(lambda (port)
(batch:call-with-output-script
port
(lambda (batch-port)
(define new-parms (copy-tree pl))
(adjoin-parameters! new-parms (list 'batch-port batch-port))
(apply BATCHER new-parms args)))))))))))
(define (truncate-up-to str chars)
(define (tut str)
(do ((i (string-length str) (+ -1 i)))
((or (zero? i) (memv (string-ref str (+ -1 i)) chars))
(substring str i (string-length str)))))
(cond ((char? chars) (set! chars (list chars)))
((string? chars) (set! chars (string->list chars))))
(if (string? str) (tut str) (map tut str)))
(define (must-be-first firsts lst)
(append (remove-if-not (lambda (i) (member i lst)) firsts)
(remove-if (lambda (i) (member i firsts)) lst)))
(define (must-be-last lst lasts)
(append (remove-if (lambda (i) (member i lasts)) lst)
(remove-if-not (lambda (i) (member i lst)) lasts)))
(define (string-join joiner . args)
(if (null? args) ""
(apply string-append
(car args)
(map (lambda (s) (string-append joiner s)) (cdr args)))))
(define (batch:flatten strings)
(apply
append (map
(lambda (obj)
(cond ((eq? "" obj) '())
((string? obj) (list obj))
((eq? #f obj) '())
((null? obj) '())
((list? obj) (batch:flatten obj))
(else (slib:error 'batch:flatten "unexpected type"
obj "in" strings))))
strings)))
(define batch:platform (software-type))
(cond ((and (eq? 'unix batch:platform) (provided? 'system))
(let ((file-name (tmpnam)))
(system (string-append "uname > " file-name))
(set! batch:platform (call-with-input-file file-name read))
(delete-file file-name))))
(define batch:database #f)
(define os->batch-dialect #f)
(define batch-dialect->line-length-limit #f)
(define (batch:line-length-limit parms)
(let ((bl (parameter-list-ref parms 'batch-line-length-limit)))
(if bl (car bl) (batch-dialect->line-length-limit (batch:dialect parms)))))
(define (batch:initialize! database)
(set! batch:database database)
(define-tables database
'(batch-dialect
((family atom))
((line-length-limit number))
((unix 1023)
(dos 127)
(vms 1023)
(amigados 511)
(system 1023)
(*unknown* -1)))
'(operating-system
((name symbol))
((os-family batch-dialect))
(;;(3b1 *unknown*)
(*unknown* *unknown*)
(acorn *unknown*)
(aix unix)
(alliant *unknown*)
(amiga amigados)
(apollo unix)
(apple2 *unknown*)
(arm *unknown*)
(atari.st *unknown*)
(cdc *unknown*)
(celerity *unknown*)
(concurrent *unknown*)
(convex *unknown*)
(encore *unknown*)
(harris *unknown*)
(hp-ux unix)
(hp48 *unknown*)
(irix unix)
(isis *unknown*)
(linux unix)
(mac *unknown*)
(masscomp unix)
(mips *unknown*)
(ms-dos dos)
(ncr *unknown*)
(newton *unknown*)
(next unix)
(novell *unknown*)
(os/2 dos)
(osf1 unix)
(prime *unknown*)
(psion *unknown*)
(pyramid *unknown*)
(sequent *unknown*)
(sgi *unknown*)
(stratus *unknown*)
(sunos unix)
(transputer *unknown*)
(unicos unix)
(unix unix)
(vms vms)
)))
((database 'add-domain) '(operating-system operating-system #f symbol #f))
(set! os->batch-dialect (((batch:database 'open-table) 'operating-system #f)
'get 'os-family))
(set! batch-dialect->line-length-limit
(((batch:database 'open-table) 'batch-dialect #f)
'get 'line-length-limit))
)

263
module/slib/bigloo.init
View file

@ -1,263 +0,0 @@
;; "bigloo.init" Initialization for SLIB for Bigloo -*-scheme-*-
;; Copyright 1994 Robert Sanders
;; Copyright 1991, 1992, 1993 Aubrey Jaffer
;; Copyright 1991 David Love
;;
;; Permission to copy this software, to redistribute it, and to use it
;; for any purpose is granted, subject to the following restrictions and
;; understandings.
;;
;; 1. Any copy made of this software must include this copyright notice
;; in full.
;;
;; 2. I have made no warrantee or representation that the operation of
;; this software will be error-free, and I am under no obligation to
;; provide any services, by way of maintenance, update, or otherwise.
;;
;; 3. In conjunction with products arising from the use of this
;; material, there shall be no use of my name in any advertising,
;; promotional, or sales literature without prior written consent in
;; each case.
(define (software-type) 'UNIX)
;;; (scheme-implementation-type) should return the name of the scheme
;;; implementation loading this file.
(define (scheme-implementation-type) 'Bigloo)
;;; (scheme-implementation-version) should return a string describing
;;; the version the scheme implementation loading this file.
;;; (scheme-implementation-home-page) should return a (string) URI
;;; (Uniform Resource Identifier) for this scheme implementation's home
;;; page; or false if there isn't one.
(define (scheme-implementation-home-page)
"http://kaolin.unice.fr/~serrano/bigloo/bigloo.html")
(define (scheme-implementation-version) "2.0c")
;;; (implementation-vicinity) should be defined to be the pathname of
;;; the directory where any auxillary files to your Scheme
;;; implementation reside.
(define (implementation-vicinity)
(case (software-type)
((UNIX) "/usr/unsup/lib/bigloo/")
((VMS) "scheme$src:")
((MSDOS) "C:\\scheme\\")))
;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
(define library-vicinity
(let ((library-path
(or
;; Use this getenv if your implementation supports it.
(getenv "SCHEME_LIBRARY_PATH")
;; Use this path if your scheme does not support GETENV
;; or if SCHEME_LIBRARY_PATH is not set.
(case (software-type)
((UNIX) "/home/bambam/leavens/unsup-src/scheme/scm/slib/")
((VMS) "lib$scheme:")
((MSDOS) "C:\\SLIB\\")
(else "")))))
(lambda () library-path)))
;;; (home-vicinity) should return the vicinity of the user's HOME
;;; directory, the directory which typically contains files which
;;; customize a computer environment for a user.
(define home-vicinity
(let ((home-path (getenv "HOME")))
(lambda () home-path)))
;;; *FEATURES* should be set to a list of symbols describing features
;;; of this implementation. See Template.scm for the list of feature
;;; names.
(define *features*
'(
source ;can load scheme source files
;(slib:load-source "filename")
rev4-report ;conforms to
rev3-report ;conforms to
ieee-p1178 ;conforms to
rev4-optional-procedures
rev3-procedures
multiarg/and-
multiarg-apply
rationalize
object-hash
delay
promise
with-file
transcript
ieee-floating-point
eval
pretty-print
object->string
string-case
string-port
system
getenv
defmacro
;;full-continuation ;not without the -call/cc switch
))
(define pretty-print pp)
(define (object->string x) (obj->string x))
;;; Define these if your implementation's syntax can support it and if
;;; they are not already defined.
(define (1+ n) (+ n 1))
(define (-1+ n) (+ n -1))
(define 1- -1+)
;;; (OUTPUT-PORT-WIDTH <port>)
(define (output-port-width . arg) 79)
;;; (OUTPUT-PORT-HEIGHT <port>)
(define (output-port-height . arg) 24)
;;; (TMPNAM) makes a temporary file name.
(define tmpnam
(let ((cntr 100))
(lambda ()
(set! cntr (+ 1 cntr))
(let ((tmp (string-append "slib_" (number->string cntr))))
(if (file-exists? tmp) (tmpnam) tmp)))))
;;; FORCE-OUTPUT flushes any pending output on optional arg output port
;;; use this definition if your system doesn't have such a procedure.
(define (force-output . args)
(flush-output-port (if (pair? args) (car args) (current-output-port))))
;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
;;; port versions of CALL-WITH-*PUT-FILE.
(define (call-with-output-string f)
(let ((outsp (open-output-string)))
(f outsp)
(close-output-port outsp)))
(define (call-with-input-string s f)
(let* ((insp (open-input-string s))
(res (f insp)))
(close-input-port insp)
res))
;;; "rationalize" adjunct procedures.
(define (find-ratio x e)
(let ((rat (rationalize x e)))
(list (numerator rat) (denominator rat))))
(define (find-ratio-between x y)
(find-ratio (/ (+ x y) 2) (/ (- x y) 2)))
;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
;;; be returned by CHAR->INTEGER.
(define char-code-limit 256)
;; MOST-POSITIVE-FIXNUM is used in modular.scm
(define most-positive-fixnum 536870911)
;;; Return argument
(define (identity x) x)
;; define an error procedure for the library
;;; If your implementation provides eval, SLIB:EVAL is single argument
;;; eval using the top-level (user) environment.
(define slib:eval eval)
(define-macro (defmacro name . forms)
`(define-macro (,name . ,(car forms)) ,@(cdr forms)))
(define (defmacro? m) (get-eval-expander m))
(define (macroexpand-1 body) (expand-once body))
(define (macroexpand body) (expand body))
(define (gentemp) (gensym))
(define (slib:eval-load <pathname> evl)
(if (not (file-exists? <pathname>))
(set! <pathname> (string-append <pathname> (scheme-file-suffix))))
(call-with-input-file <pathname>
(lambda (port)
(let ((old-load-pathname *load-pathname*))
(set! *load-pathname* <pathname>)
(do ((o (read port) (read port)))
((eof-object? o))
(evl o))
(set! *load-pathname* old-load-pathname)))))
(define slib:warn
(lambda args
(let ((cep (current-error-port)))
(if (provided? 'trace) (print-call-stack cep))
(display "Warn: " cep)
(for-each (lambda (x) (display x cep)) args))))
(define (slib:error . args)
(if (provided? 'trace) (print-call-stack (current-error-port)))
(error 'slib:error "" args))
;; define these as appropriate for your system.
(define slib:tab (integer->char 9))
(define slib:form-feed (integer->char 12))
;;; records
(defmacro define-record forms
(let* ((name (car forms))
(maker-name (symbol-append 'make- name)))
`(begin
(define-struct ,name ,@(cadr forms))
(define ,maker-name ,name))
))
(define (promise:force p) (force p))
;;; (implementation-vicinity) should be defined to be the pathname of
;;; the directory where any auxillary files to your Scheme
;;; implementation reside.
(define in-vicinity string-append)
;;; Define SLIB:EXIT to be the implementation procedure to exit or
;;; return if exitting not supported.
(define slib:exit (lambda args (exit 0)))
;;; Here for backward compatability
(define scheme-file-suffix
(let ((suffix (case (software-type)
((NOSVE) "_scm")
(else ".scm"))))
(lambda () suffix)))
;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
;;; suffix all the module files in SLIB have. See feature 'SOURCE.
(define (slib:load-source f) (loadq (string-append f (scheme-file-suffix))))
;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
;;; by compiling "foo.scm" if this implementation can compile files.
;;; See feature 'COMPILED.
(define slib:load-compiled loadq)
;;; At this point SLIB:LOAD must be able to load SLIB files.
(define slib:load slib:load-source)
(define defmacro:eval slib:eval)
(define defmacro:load slib:load)
;;; If your implementation provides R4RS macros:
;(define macro:eval slib:eval)
;(define macro:load load)
(slib:load (in-vicinity (library-vicinity) "require"))
; eof

149
module/slib/break.scm
View file

@ -1,149 +0,0 @@
;;;; "break.scm" Breakpoints for debugging in Scheme.
;;; Copyright (C) 1991, 1992, 1993, 1995 Aubrey Jaffer.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'qp)
;;;; BREAKPOINTS
;;; Typing (init-debug) at top level sets up a continuation for
;;; breakpoint. When (breakpoint arg1 ...) is then called it returns
;;; from the top level continuation and pushes the continuation from
;;; which it was called on breakpoint:continuation-stack. If
;;; (continue) is later called, it pops the topmost continuation off
;;; of breakpoint:continuation-stack and returns #f to it.
(define breakpoint:continuation-stack '())
(define debug:breakpoint
(let ((call-with-current-continuation call-with-current-continuation)
(apply apply) (qpn qpn)
(cons cons) (length length))
(lambda args
(if (provided? 'trace) (print-call-stack (current-error-port)))
(apply qpn "BREAKPOINT:" args)
(let ((ans
(call-with-current-continuation
(lambda (x)
(set! breakpoint:continuation-stack
(cons x breakpoint:continuation-stack))
(debug:top-continuation
(length breakpoint:continuation-stack))))))
(cond ((not (eq? ans breakpoint:continuation-stack)) ans))))))
(define debug:continue
(let ((null? null?) (car car) (cdr cdr))
(lambda args
(cond ((null? breakpoint:continuation-stack)
(display "; no break to continue from")
(newline))
(else
(let ((cont (car breakpoint:continuation-stack)))
(set! breakpoint:continuation-stack
(cdr breakpoint:continuation-stack))
(if (null? args) (cont #f)
(apply cont args))))))))
(define debug:top-continuation
(if (provided? 'abort)
(lambda (val) (display val) (newline) (abort))
(begin (display "; type (init-debug)") #f)))
(define (init-debug)
(call-with-current-continuation
(lambda (x) (set! debug:top-continuation x))))
(define breakpoint debug:breakpoint)
(define bkpt debug:breakpoint)
(define continue debug:continue)
(define breakf
(let ((null? null?) ;These bindings are so that
(not not) ;breakf will not break on parts
(car car) (cdr cdr) ;of itself.
(eq? eq?) (+ +) (zero? zero?) (modulo modulo)
(apply apply) (display display) (breakpoint debug:breakpoint))
(lambda (function . optname)
;; (set! trace:indent 0)
(let ((name (if (null? optname) function (car optname))))
(lambda args
(cond ((and (not (null? args))
(eq? (car args) 'debug:unbreak-object)
(null? (cdr args)))
function)
(else
(breakpoint name args)
(apply function args))))))))
;;; the reason I use a symbol for debug:unbreak-object is so
;;; that functions can still be unbreaked if this file is read in twice.
(define (unbreakf function)
;; (set! trace:indent 0)
(function 'debug:unbreak-object))
;;;;The break: functions wrap around the debug: functions to provide
;;; niceties like keeping track of breakd functions and dealing with
;;; redefinition.
(require 'alist)
(define break:adder (alist-associator eq?))
(define break:deler (alist-remover eq?))
(define *breakd-procedures* '())
(define (break:breakf fun sym)
(cond ((not (procedure? fun))
(display "WARNING: not a procedure " (current-error-port))
(display sym (current-error-port))
(newline (current-error-port))
(set! *breakd-procedures* (break:deler *breakd-procedures* sym))
fun)
(else
(let ((p (assq sym *breakd-procedures*)))
(cond ((and p (eq? (cdr p) fun))
fun)
(else
(let ((tfun (breakf fun sym)))
(set! *breakd-procedures*
(break:adder *breakd-procedures* sym tfun))
tfun)))))))
(define (break:unbreakf fun sym)
(let ((p (assq sym *breakd-procedures*)))
(set! *breakd-procedures* (break:deler *breakd-procedures* sym))
(cond ((not (procedure? fun)) fun)
((not p) fun)
((eq? (cdr p) fun)
(unbreakf fun))
(else fun))))
;;;; Finally, the macros break and unbreak
(defmacro break xs
(if (null? xs)
`(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x)))
(map car *breakd-procedures*))
(map car *breakd-procedures*))
`(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x))) xs))))
(defmacro unbreak xs
(if (null? xs)
(slib:eval
`(begin ,@(map (lambda (x) `(set! ,x (break:unbreakf ,x ',x)))
(map car *breakd-procedures*))
'',(map car *breakd-procedures*)))
`(begin ,@(map (lambda (x) `(set! ,x (break:unbreakf ,x ',x))) xs))))

15
module/slib/byte.scm
View file

@ -1,15 +0,0 @@
;;; "byte.scm" small integers, not necessarily chars.
(define (byte-ref str ind) (char->integer (string-ref str ind)))
(define (byte-set! str ind val) (string-set! str ind (integer->char val)))
(define (make-bytes len . opt)
(if (null? opt) (make-string len)
(make-string len (integer->char (car opt)))))
(define bytes-length string-length)
(define (write-byte byt . opt) (apply write-char (integer->char byt) opt))
(define (read-byte . opt)
(let ((c (apply read-char opt)))
(if (eof-object? c) c (char->integer c))))
(define (bytes . args) (list->bytes args))
(define (bytes->list bts) (map char->integer (string->list bts)))
(define (list->bytes lst) (list->string (map integer->char lst)))

150
module/slib/chap.scm
View file

@ -1,150 +0,0 @@
;;;; "chap.scm" Chapter ordering -*-scheme-*-
;;; Copyright 1992, 1993, 1994 Aubrey Jaffer.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;;; The CHAP: functions deal with strings which are ordered like
;;; chapters in a book. For instance, a_9 < a_10 and 4c < 4aa. Each
;;; section of the string consists of consecutive numeric or
;;; consecutive aphabetic characters.
(define (chap:string<? s1 s2)
(let ((l1 (string-length s1))
(l2 (string-length s2)))
(define (match-so-far i ctypep)
(cond ((>= i l1) (not (>= i l2)))
((>= i l2) #f)
(else
(let ((c1 (string-ref s1 i))
(c2 (string-ref s2 i)))
(cond ((char=? c1 c2)
(if (ctypep c1)
(match-so-far (+ 1 i) ctypep)
(delimited i)))
((ctypep c1)
(if (ctypep c2)
(length-race (+ 1 i) ctypep (char<? c1 c2))
#f))
((ctypep c2) #t)
(else
(let ((ctype1 (ctype c1)))
(cond
((and ctype1 (eq? ctype1 (ctype c2)))
(length-race (+ 1 i) ctype1 (char<? c1 c2)))
(else (char<? c1 c2))))))))))
(define (length-race i ctypep def)
(cond ((>= i l1) (if (>= i l2) def #t))
((>= i l2) #f)
(else
(let ((c1 (string-ref s1 i))
(c2 (string-ref s2 i)))
(cond ((ctypep c1)
(if (ctypep c2)
(length-race (+ 1 i) ctypep def)
#f))
((ctypep c2) #t)
(else def))))))
(define (ctype c1)
(cond
((char-numeric? c1) char-numeric?)
((char-lower-case? c1) char-lower-case?)
((char-upper-case? c1) char-upper-case?)
(else #f)))
(define (delimited i)
(cond ((>= i l1) (not (>= i l2)))
((>= i l2) #f)
(else
(let* ((c1 (string-ref s1 i))
(c2 (string-ref s2 i))
(ctype1 (ctype c1)))
(cond ((char=? c1 c2)
(if ctype1 (match-so-far (+ i 1) ctype1)
(delimited (+ i 1))))
((and ctype1 (eq? ctype1 (ctype c2)))
(length-race (+ 1 i) ctype1 (char<? c1 c2)))
(else (char<? c1 c2)))))))
(delimited 0)))
(define chap:char-incr (- (char->integer #\2) (char->integer #\1)))
(define (chap:inc-string s p)
(let ((c (string-ref s p)))
(cond ((char=? c #\z)
(string-set! s p #\a)
(cond ((zero? p) (string-append "a" s))
((char-lower-case? (string-ref s (+ -1 p)))
(chap:inc-string s (+ -1 p)))
(else
(string-append
(substring s 0 p)
"a"
(substring s p (string-length s))))))
((char=? c #\Z)
(string-set! s p #\A)
(cond ((zero? p) (string-append "A" s))
((char-upper-case? (string-ref s (+ -1 p)))
(chap:inc-string s (+ -1 p)))
(else
(string-append
(substring s 0 p)
"A"
(substring s p (string-length s))))))
((char=? c #\9)
(string-set! s p #\0)
(cond ((zero? p) (string-append "1" s))
((char-numeric? (string-ref s (+ -1 p)))
(chap:inc-string s (+ -1 p)))
(else
(string-append
(substring s 0 p)
"1"
(substring s p (string-length s))))))
((or (char-alphabetic? c) (char-numeric? c))
(string-set! s p (integer->char
(+ chap:char-incr
(char->integer (string-ref s p)))))
s)
(else (slib:error "inc-string error" s p)))))
(define (chap:next-string s)
(do ((i (+ -1 (string-length s)) (+ -1 i)))
((or (negative? i)
(char-numeric? (string-ref s i))
(char-alphabetic? (string-ref s i)))
(if (negative? i) (string-append s "0")
(chap:inc-string (string-copy s) i)))))
;;; testing utilities
;(define (ns s1) (chap:next-string s1))
;(define (ts s1 s2)
; (let ((s< (chap:string<? s1 s2))
; (s> (chap:string<? s2 s1)))
; (cond (s<
; (display s1)
; (display " < ")
; (display s2)
; (newline)))
; (cond (s>
; (display s1)
; (display " > ")
; (display s2)
; (newline)))))
(define (chap:string>? s1 s2) (chap:string<? s2 s1))
(define (chap:string>=? s1 s2) (not (chap:string<? s1 s2)))
(define (chap:string<=? s1 s2) (not (chap:string<? s2 s1)))

171
module/slib/charplot.scm
View file

@ -1,171 +0,0 @@
;;;; "charplot.scm", plotting on character devices for Scheme
;;; Copyright (C) 1992, 1993 Aubrey Jaffer.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'sort)
(require 'printf)
(require 'array)
(require 'array-for-each)
(define charplot:rows 24)
(define charplot:columns (output-port-width (current-output-port)))
(define charplot:xborder #\_)
(define charplot:yborder #\|)
(define charplot:xaxchar #\-)
(define charplot:yaxchar #\:)
(define charplot:curve1 #\*)
(define charplot:xtick #\.)
(define charplot:height (- charplot:rows 5))
(define charplot:width (- charplot:columns 15))
(define (charplot:printn! n char)
(cond ((positive? n)
(write-char char)
(charplot:printn! (+ n -1) char))))
(define (charplot:center-print! str width)
(let ((lpad (quotient (- width (string-length str)) 2)))
(charplot:printn! lpad #\ )
(display str)
(charplot:printn! (- width (+ (string-length str) lpad)) #\ )))
(define (charplot:number->string x)
(sprintf #f "%g" x))
(define (charplot:scale-it z scale)
(if (and (exact? z) (integer? z))
(quotient (* z (car scale)) (cadr scale))
(inexact->exact (round (/ (* z (car scale)) (cadr scale))))))
(define (charplot:find-scale isize delta)
(define (fs2)
(cond ((< (* delta 8) isize) 8)
((< (* delta 6) isize) 6)
((< (* delta 5) isize) 5)
((< (* delta 4) isize) 4)
((< (* delta 3) isize) 3)
((< (* delta 2) isize) 2)
(else 1)))
(cond ((zero? delta) (set! delta 1))
((inexact? delta) (set! isize (exact->inexact isize))))
(do ((d 1 (* d 10)))
((<= delta isize)
(do ((n 1 (* n 10)))
((>= (* delta 10) isize)
(list (* n (fs2)) d))
(set! delta (* delta 10))))
(set! isize (* isize 10))))
(define (charplot:iplot! data xlabel ylabel xmin xscale ymin yscale)
(define xaxis (- (charplot:scale-it ymin yscale)))
(define yaxis (- (charplot:scale-it xmin xscale)))
(charplot:center-print! ylabel 11)
(charplot:printn! (+ charplot:width 1) charplot:xborder)
(newline)
(set! data (sort! data (lambda (x y) (if (= (cdr x) (cdr y))
(< (car x) (car y))
(> (cdr x) (cdr y))))))
(do ((ht (- charplot:height 1) (- ht 1)))
((negative? ht))
(let ((a (make-string (+ charplot:width 1)
(if (= ht xaxis) charplot:xaxchar #\ )))
(ystep (if (= 1 (gcd (car yscale) 3)) 2 3)))
(string-set! a charplot:width charplot:yborder)
(if (< -1 yaxis charplot:width) (string-set! a yaxis charplot:yaxchar))
(do ()
((or (null? data) (not (>= (cdar data) ht))))
(string-set! a (caar data) charplot:curve1)
(set! data (cdr data)))
(if (zero? (modulo (- ht xaxis) ystep))
(let* ((v (charplot:number->string (/ (* (- ht xaxis) (cadr yscale))
(car yscale))))
(l (string-length v)))
(if (> l 10)
(display (substring v 0 10))
(begin
(charplot:printn! (- 10 l) #\ )
(display v)))
(display charplot:yborder)
(display charplot:xaxchar))
(begin
(charplot:printn! 10 #\ )
(display charplot:yborder)
(display #\ )))
(display a) (newline)))
(let* ((xstep (if (= 1 (gcd (car xscale) 3)) 10 12))
(xstep/2 (quotient (- xstep 2) 2))
(fudge (modulo yaxis xstep)))
(charplot:printn! 10 #\ ) (display charplot:yborder)
(charplot:printn! (+ 1 fudge) charplot:xborder)
(display charplot:yaxchar)
(do ((i fudge (+ i xstep)))
((> (+ i xstep) charplot:width)
(charplot:printn! (modulo (- charplot:width (+ i 1)) xstep)
charplot:xborder))
(charplot:printn! xstep/2 charplot:xborder)
(display charplot:xtick)
(charplot:printn! xstep/2 charplot:xborder)
(display charplot:yaxchar))
(display charplot:yborder) (newline)
(charplot:center-print! xlabel (+ 12 fudge (- xstep/2)))
(do ((i fudge (+ i xstep)))
((>= i charplot:width))
(charplot:center-print! (charplot:number->string
(/ (* (- i yaxis) (cadr xscale))
(car xscale)))
xstep))
(newline)))
(define (charplot:plot! data xlabel ylabel)
(cond ((array? data)
(case (array-rank data)
((1) (set! data (map cons
(let ((ra (apply make-array #f
(array-shape data))))
(array-index-map! ra identity)
(array->list ra))
(array->list data))))
((2) (set! data (map (lambda (lst) (cons (car lst) (cadr lst)))
(array->list data)))))))
(let* ((xmax (apply max (map car data)))
(xmin (apply min (map car data)))
(xscale (charplot:find-scale charplot:width (- xmax xmin)))
(ymax (apply max (map cdr data)))
(ymin (apply min (map cdr data)))
(yscale (charplot:find-scale charplot:height (- ymax ymin)))
(ixmin (charplot:scale-it xmin xscale))
(iymin (charplot:scale-it ymin yscale)))
(charplot:iplot! (map (lambda (p)
(cons (- (charplot:scale-it (car p) xscale) ixmin)
(- (charplot:scale-it (cdr p) yscale) iymin)))
data)
xlabel ylabel xmin xscale ymin yscale)))
(define (plot-function! func vlo vhi . npts)
(set! npts (if (null? npts) 100 (car npts)))
(let ((dats (make-array 0.0 npts 2)))
(array-index-map! (make-shared-array dats (lambda (idx) (list idx 0)) npts)
(lambda (idx) (+ vlo (* (- vhi vlo) (/ idx npts)))))
(array-map! (make-shared-array dats (lambda (idx) (list idx 1)) npts)
func
(make-shared-array dats (lambda (idx) (list idx 0)) npts))
(charplot:plot! dats "" "")))
(define plot! charplot:plot!)

396
module/slib/chez.init
View file

@ -1,396 +0,0 @@
;;;"chez.init" Initialization file for SLIB for Chez Scheme 6.0a -*-scheme-*-
;;; Authors: dorai@cs.rice.edu (Dorai Sitaram) and Aubrey Jaffer.
;;;
;;; This code is in the public domain.
;;; Adapted to version 5.0c by stone@math.grin.edu (John David Stone) 1997
;;; Adapted to version 6.0a by Gary T. Leavens <leavens@cs.iastate.edu>, 1999
;;; (software-type) should be set to the generic operating system type.
;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
(define (software-type) 'UNIX)
;;; (scheme-implementation-type) should return the name of the scheme
;;; implementation loading this file.
(define (scheme-implementation-type) 'chez)
;;; (scheme-implementation-home-page) should return a (string) URI
;;; (Uniform Resource Identifier) for this scheme implementation's home
;;; page; or false if there isn't one.
(define (scheme-implementation-home-page)
"http://www.cs.indiana.edu/chezscheme/")
;;; (scheme-implementation-version) should return a string describing
;;; the version the scheme implementation loading this file.
(define (scheme-implementation-version) "6.0a")
;;; (implementation-vicinity) should be defined to be the pathname of
;;; the directory where any auxillary files to your Scheme
;;; implementation reside.
(define implementation-vicinity
(lambda () "/usr/unsup/scheme/chez/"))
;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
(define library-vicinity
(let ((library-path
(or
;; Use this getenv if your implementation supports it.
(getenv "SCHEME_LIBRARY_PATH")
;; Use this path if your scheme does not support GETENV
;; or if SCHEME_LIBRARY_PATH is not set.
(case (software-type)
((UNIX) "/usr/local/lib/slib/")
((VMS) "lib$scheme:")
((MS-DOS) "C:\\SLIB\\")
(else "")))))
(lambda () library-path)))
;;; (home-vicinity) should return the vicinity of the user's HOME
;;; directory, the directory which typically contains files which
;;; customize a computer environment for a user.
(define home-vicinity
(let ((home-path (getenv "HOME")))
(lambda () home-path)))
;;; *FEATURES* should be set to a list of symbols describing features
;;; of this implementation. Suggestions for features are:
(define *features*
'(
source ; Chez Scheme can load Scheme source files, with the
; command (slib:load-source "filename") -- see below.
compiled ; Chez Scheme can also load compiled Scheme files, with the
; command (slib:load-compiled "filename") -- see below.
rev4-report ;conforms to
rev3-report ;conforms to
ieee-p1178 ;conforms to
; sicp ;runs code from Structure and
;Interpretation of Computer
;Programs by Abelson and Sussman.
rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
;LIST->STRING, STRING-COPY,
;STRING-FILL!, LIST->VECTOR,
;VECTOR->LIST, and VECTOR-FILL!
; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
;SUBSTRING-FILL!,
;STRING-NULL?, APPEND!, 1+,
;-1+, <?, <=?, =?, >?, >=?
multiarg/and- ;/ and - can take more than 2 args.
multiarg-apply ;APPLY can take more than 2 args.
rationalize
delay ;has DELAY and FORCE
with-file ;has WITH-INPUT-FROM-FILE and
;WITH-OUTPUT-FROM-FILE
string-port ;has CALL-WITH-INPUT-STRING and
;CALL-WITH-OUTPUT-STRING
transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
char-ready?
macro ;has R4RS high level macros
; defmacro ;has Common Lisp DEFMACRO
eval ;R5RS two-argument eval
record ;has user defined data structures
values ;proposed multiple values
dynamic-wind ;proposed dynamic-wind
; ieee-floating-point ;conforms to
full-continuation ;can return multiple times
; object-hash ;has OBJECT-HASH
sort
; queue ;queues
pretty-print
; object->string
format
trace ;has macros: TRACE and UNTRACE
; compiler ;has (COMPILER)
; ed ;(ED) is editor
system ;posix (system <string>)
getenv ;posix (getenv <string>)
; program-arguments ;returns list of strings (argv)
; Xwindows ;X support
; curses ;screen management package
; termcap ;terminal description package
; terminfo ;sysV terminal description
; current-time ;returns time in seconds since 1/1/1970
fluid-let
random
rev3-procedures
))
;;; (OUTPUT-PORT-WIDTH <port>) returns the number of graphic characters
;;; that can reliably be displayed on one line of the standard output port.
(define output-port-width
(lambda arg
(let ((env-width-string (getenv "COLUMNS")))
(if (and env-width-string
(let loop ((remaining (string-length env-width-string)))
(or (zero? remaining)
(let ((next (- remaining 1)))
(and (char-numeric? (string-ref env-width-string
next))
(loop next))))))
(- (string->number env-width-string) 1)
79))))
;;; (OUTPUT-PORT-HEIGHT <port>) returns the number of lines of text that
;;; can reliably be displayed simultaneously in the standard output port.
(define output-port-height
(lambda arg
(let ((env-height-string (getenv "LINES")))
(if (and env-height-string
(let loop ((remaining (string-length env-height-string)))
(or (zero? remaining)
(let ((next (- remaining 1)))
(and (char-numeric? (string-ref env-height-string
next))
(loop next))))))
(string->number env-height-string)
24))))
;;; (CURRENT-ERROR-PORT)
(define current-error-port
(let ((port (console-output-port))) ; changed from current-output-port
(lambda () port)))
;;; (TMPNAM) makes a temporary file name.
(define tmpnam
(let ((cntr 100))
(lambda ()
(set! cntr (+ 1 cntr))
(let ((tmp (string-append "slib_" (number->string cntr))))
(if (file-exists? tmp) (tmpnam) tmp)))))
;;; (FILE-EXISTS? <string>) is built-in to Chez Scheme
;;; (DELETE-FILE <string>) is built-in to Chez Scheme
;; The FORCE-OUTPUT requires buffered output that has been written to a
;; port to be transferred all the way out to its ultimate destination.
(define force-output flush-output-port)
;;; "rationalize" adjunct procedures.
(define (find-ratio x e)
(let ((rat (rationalize x e)))
(list (numerator rat) (denominator rat))))
(define (find-ratio-between x y)
(find-ratio (/ (+ x y) 2) (/ (- x y) 2)))
;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
;;; be returned by CHAR->INTEGER.
(define char-code-limit 256)
;;; MOST-POSITIVE-FIXNUM is used in modular.scm
;; Chez's MOST-POSITIVE-FIXNUM is a thunk rather than a number.
(if (procedure? most-positive-fixnum)
(set! most-positive-fixnum (most-positive-fixnum)))
;;; Return argument
(define (identity x) x)
;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
(define slib:eval eval)
;;; define an error procedure for the library
(define slib:error
(lambda args
(let ((cep (current-error-port)))
(if (provided? 'trace) (print-call-stack cep))
(display "Error: " cep)
(for-each (lambda (x) (display x cep)) args)
(error #f ""))))
;;; define these as appropriate for your system.
(define slib:tab #\tab)
(define slib:form-feed #\page)
;;; Support for older versions of Scheme. Not enough code for its own file.
;;; last-pair is built-in to Chez Scheme
(define t #t)
(define nil #f)
;;; Define these if your implementation's syntax can support it and if
;;; they are not already defined.
;;; 1+, -1+, and 1- are built-in to Chez Scheme
;(define (1+ n) (+ n 1))
;(define (-1+ n) (+ n -1))
;(define 1- -1+)
;;; (IN-VICINITY <string>) is simply STRING-APPEND, conventionally used
;;; to attach a directory pathname to the name of a file that is expected to
;;; be in that directory.
(define in-vicinity string-append)
;;; Define SLIB:EXIT to be the implementation procedure to exit or
;;; return if exitting not supported.
(define slib:chez:quit
(let ((arg (call-with-current-continuation identity)))
(cond ((procedure? arg) arg)
(arg (exit))
(else (exit 1)))))
(define slib:exit
(lambda args
(cond ((null? args) (slib:chez:quit #t))
((eqv? #t (car args)) (slib:chez:quit #t))
((eqv? #f (car args)) (slib:chez:quit #f))
((zero? (car args)) (slib:chez:quit #t))
(else (slib:chez:quit #f)))))
;;; For backward compatability, the SCHEME-FILE-SUFFIX procedure is defined
;;; to return the string ".scm". Note, however, that ".ss" is a common Chez
;;; file suffix.
(define scheme-file-suffix
(let ((suffix (case (software-type)
((NOSVE) "_scm")
(else ".scm"))))
(lambda () suffix)))
;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
;;; suffix all the module files in SLIB have. See feature 'SOURCE.
(define (slib:load-source f) (load (string-append f ".scm")))
;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
;;; by compiling "foo.scm" if this implementation can compile files.
;;; See feature 'COMPILED.
(define slib:load-compiled load)
;;; At this point SLIB:LOAD must be able to load SLIB files.
(define slib:load slib:load-source)
;;; The following make procedures in Chez Scheme compatible with
;;; the assumptions of SLIB.
;;; Chez's sorting routines take parameters in the order opposite to SLIB's.
;;; The following definitions override the predefined procedures with the
;;; parameters-reversed versions. See the SORT feature.
(define chez:sort sort)
(define chez:sort! sort!)
(define chez:merge merge)
(define chez:merge! merge!)
(define sort
(lambda (s p)
(chez:sort p s)))
(define sort!
(lambda (s p)
(chez:sort! p s)))
(define merge
(lambda (s1 s2 p)
(chez:merge p s1 s2)))
(define merge!
(lambda (s1 s2 p)
(chez:merge! p s1 s2)))
;;; Chez's (FORMAT F . A) corresponds to SLIB's (FORMAT #F F . A)
;;; See the FORMAT feature.
(define chez:format format)
(define format
(lambda (where how . args)
(let ((str (apply chez:format how args)))
(cond ((not where) str)
((eq? where #t) (display str))
(else (display str where))))))
;; The following definitions implement a few widely useful procedures that
;; Chez Scheme does not provide or provides under a different name.
;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
;;; port versions of CALL-WITH-INPUT-FILE and CALL-WITH-OUTPUT-FILE.
;;; See the STRING-PORT feature.
(define call-with-output-string
(lambda (f)
(let ((outsp (open-output-string)))
(f outsp)
(let ((s (get-output-string outsp)))
(close-output-port outsp)
s))))
(define call-with-input-string
(lambda (s f)
(let* ((insp (open-input-string s))
(res (f insp)))
(close-input-port insp)
res)))
;;; If your implementation provides R4RS macros:
(define macro:eval slib:eval)
;;; macro:load also needs the default suffix.
(define macro:load slib:load-source)
(define *defmacros*
(list (cons 'defmacro
(lambda (name parms . body)
`(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body))
*defmacros*))))))
(define (defmacro? m) (and (assq m *defmacros*) #t))
(define (macroexpand-1 e)
(if (pair? e) (let ((a (car e)))
(cond ((symbol? a) (set! a (assq a *defmacros*))
(if a (apply (cdr a) (cdr e)) e))
(else e)))
e))
(define (macroexpand e)
(if (pair? e) (let ((a (car e)))
(cond ((symbol? a)
(set! a (assq a *defmacros*))
(if a (macroexpand (apply (cdr a) (cdr e))) e))
(else e)))
e))
;;; According to Kent Dybvig, you can improve the Chez Scheme init
;;; file by defining gentemp to be gensym in Chez Scheme.
(define gentemp gensym)
(define base:eval slib:eval)
(define (defmacro:eval x) (base:eval (defmacro:expand* x)))
(define (defmacro:expand* x)
(require 'defmacroexpand) (apply defmacro:expand* x '()))
(define (slib:eval-load <pathname> evl)
(if (not (file-exists? <pathname>))
(set! <pathname> (string-append <pathname> (scheme-file-suffix))))
(call-with-input-file <pathname>
(lambda (port)
(let ((old-load-pathname *load-pathname*))
(set! *load-pathname* <pathname>)
(do ((o (read port) (read port)))
((eof-object? o))
(evl o))
(set! *load-pathname* old-load-pathname)))))
(define (defmacro:load <pathname>)
(slib:eval-load <pathname> defmacro:eval))
(define slib:warn
(lambda args
(let ((cep (current-error-port)))
(if (provided? 'trace) (print-call-stack cep))
(display "Warn: " cep)
(for-each (lambda (x) (display x cep)) args))))
;;; Load the REQUIRE package.
(slib:load (in-vicinity (library-vicinity) "require"))
;; end of chez.init

67
module/slib/cltime.scm
View file

@ -1,67 +0,0 @@
;;;; "cltime.scm" Common-Lisp time conversion routines.
;;; Copyright (C) 1994, 1997 Aubrey Jaffer.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'values)
(require 'time-zone)
(require 'posix-time)
(define time:1900 (time:invert time:gmtime '#(0 0 0 1 0 0 #f #f 0 0 "GMT")))
(define (get-decoded-time)
(decode-universal-time (get-universal-time)))
(define (get-universal-time)
(difftime (current-time) time:1900))
(define (decode-universal-time utime . tzarg)
(let ((tv (apply time:split
(offset-time time:1900 utime)
(if (null? tzarg)
(tz:params utime (tzset))
(list 0 (* 3600 (car tzarg)) "???")))))
(values
(vector-ref tv 0) ;second [0..59]
(vector-ref tv 1) ;minute [0..59]
(vector-ref tv 2) ;hour [0..23]
(vector-ref tv 3) ;date [1..31]
(+ 1 (vector-ref tv 4)) ;month [1..12]
(+ 1900 (vector-ref tv 5)) ;year [0....]
(modulo (+ -1 (vector-ref tv 6)) 7) ;day-of-week [0..6] (0 is Monday)
(eqv? 1 (vector-ref tv 8)) ;daylight-saving-time?
(if (provided? 'inexact)
(inexact->exact (/ (vector-ref tv 9) 3600))
(/ (vector-ref tv 9) 3600)) ;time-zone [-24..24]
)))
(define (encode-universal-time second minute hour date month year . tzarg)
(let* ((tz (if (null? tzarg)
(tzset)
(time-zone (string-append
"???" (number->string (car tzarg))))))
(tv (vector second
minute
hour
date
(+ -1 month)
(+ -1900 year)
#f ;ignored
#f ;ignored
)))
(difftime (time:invert localtime tv) time:1900)))

107
module/slib/coerce.scm
View file

@ -1,107 +0,0 @@
;;"coerce.scm" Scheme Implementation of COMMON-LISP COERCE and TYPE-OF.
; Copyright (C) 1995, 2001 Aubrey Jaffer.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;;@body
;;Returns a symbol name for the type of @1.
(define (type-of obj)
(cond
;;((null? obj) 'null)
((boolean? obj) 'boolean)
((char? obj) 'char)
((number? obj) 'number)
((string? obj) 'string)
((symbol? obj) 'symbol)
((input-port? obj) 'port)
((output-port? obj) 'port)
((procedure? obj) 'procedure)
((eof-object? obj) 'eof-object)
((list? obj) 'list)
((pair? obj) 'pair)
((and (provided? 'array) (array? obj)) 'array)
((and (provided? 'record) (record? obj)) 'record)
((vector? obj) 'vector)
(else '?)))
;;@body
;;Converts and returns @1 of type @code{char}, @code{number},
;;@code{string}, @code{symbol}, @code{list}, or @code{vector} to
;;@2 (which must be one of these symbols).
(define (coerce obj result-type)
(define (err) (slib:error 'coerce 'not obj '-> result-type))
(define obj-type (type-of obj))
(cond
((eq? obj-type result-type) obj)
(else
(case obj-type
((char) (case result-type
((number integer) (char->integer obj))
((string) (string obj))
((symbol) (string->symbol (string obj)))
((list) (list obj))
((vector) (vector obj))
(else (err))))
((number) (case result-type
((char) (integer->char obj))
((atom) obj)
((integer) obj)
((string) (number->string obj))
((symbol) (string->symbol (number->string obj)))
((list) (string->list (number->string obj)))
((vector) (list->vector (string->list (number->string obj))))
(else (err))))
((string) (case result-type
((char) (if (= 1 (string-length obj)) (string-ref obj 0)
(err)))
((atom) (or (string->number obj) (string->symbol obj)))
((number integer) (or (string->number obj) (err)))
((symbol) (string->symbol obj))
((list) (string->list obj))
((vector) (list->vector (string->list obj)))
(else (err))))
((symbol) (case result-type
((char) (coerce (symbol->string obj) 'char))
((number integer) (coerce (symbol->string obj) 'number))
((string) (symbol->string obj))
((atom) obj)
((list) (string->list (symbol->string obj)))
((vector) (list->vector (string->list (symbol->string obj))))
(else (err))))
((list) (case result-type
((char) (if (and (= 1 (length obj))
(char? (car obj)))
(car obj)
(err)))
((number integer)
(or (string->number (list->string obj)) (err)))
((string) (list->string obj))
((symbol) (string->symbol (list->string obj)))
((vector) (list->vector obj))
(else (err))))
((vector) (case result-type
((char) (if (and (= 1 (vector-length obj))
(char? (vector-ref obj 0)))
(vector-ref obj 0)
(err)))
((number integer)
(or (string->number (coerce obj string)) (err)))
((string) (list->string (vector->list obj)))
((symbol) (string->symbol (coerce obj string)))
((list) (list->vector obj))
(else (err))))
(else (err))))))

12
module/slib/coerce.txi
View file

@ -1,12 +0,0 @@
@defun type-of obj
Returns a symbol name for the type of @var{obj}.
@end defun
@defun coerce obj result-type
Converts and returns @var{obj} of type @code{char}, @code{number},
@code{string}, @code{symbol}, @code{list}, or @code{vector} to
@var{result-type} (which must be one of these symbols).
@end defun

236
module/slib/collect.scm
View file

@ -1,236 +0,0 @@
;"collect.scm" Sample collection operations
; COPYRIGHT (c) Kenneth Dickey 1992
;
; This software may be used for any purpose whatever
; without warrantee of any kind.
; AUTHOR Ken Dickey
; DATE 1992 September 1
; LAST UPDATED 1992 September 2
; NOTES Expository (optimizations & checks elided).
; Requires YASOS (Yet Another Scheme Object System).
(require 'yasos)
(define-operation (collect:collection? obj)
;; default
(cond
((or (list? obj) (vector? obj) (string? obj)) #t)
(else #f)
) )
(define (collect:empty? collection) (zero? (yasos:size collection)))
(define-operation (collect:gen-elts <collection>) ;; return element generator
;; default behavior
(cond ;; see utilities, below, for generators
((vector? <collection>) (collect:vector-gen-elts <collection>))
((list? <collection>) (collect:list-gen-elts <collection>))
((string? <collection>) (collect:string-gen-elts <collection>))
(else
(slib:error "Operation not supported: GEN-ELTS " (yasos:print obj #f)))
) )
(define-operation (collect:gen-keys collection)
(if (or (vector? collection) (list? collection) (string? collection))
(let ( (max+1 (yasos:size collection)) (index 0) )
(lambda ()
(cond
((< index max+1)
(set! index (collect:add1 index))
(collect:sub1 index))
(else (slib:error "no more keys in generator"))
) ) )
(slib:error "Operation not handled: GEN-KEYS " collection)
) )
(define (collect:do-elts <proc> . <collections>)
(let ( (max+1 (yasos:size (car <collections>)))
(generators (map collect:gen-elts <collections>))
)
(let loop ( (counter 0) )
(cond
((< counter max+1)
(apply <proc> (map (lambda (g) (g)) generators))
(loop (collect:add1 counter))
)
(else 'unspecific) ; done
) )
) )
(define (collect:do-keys <proc> . <collections>)
(let ( (max+1 (yasos:size (car <collections>)))
(generators (map collect:gen-keys <collections>))
)
(let loop ( (counter 0) )
(cond
((< counter max+1)
(apply <proc> (map (lambda (g) (g)) generators))
(loop (collect:add1 counter))
)
(else 'unspecific) ; done
) )
) )
(define (collect:map-elts <proc> . <collections>)
(let ( (max+1 (yasos:size (car <collections>)))
(generators (map collect:gen-elts <collections>))
(vec (make-vector (yasos:size (car <collections>))))
)
(let loop ( (index 0) )
(cond
((< index max+1)
(vector-set! vec index (apply <proc> (map (lambda (g) (g)) generators)))
(loop (collect:add1 index))
)
(else vec) ; done
) )
) )
(define (collect:map-keys <proc> . <collections>)
(let ( (max+1 (yasos:size (car <collections>)))
(generators (map collect:gen-keys <collections>))
(vec (make-vector (yasos:size (car <collections>))))
)
(let loop ( (index 0) )
(cond
((< index max+1)
(vector-set! vec index (apply <proc> (map (lambda (g) (g)) generators)))
(loop (collect:add1 index))
)
(else vec) ; done
) )
) )
(define-operation (collect:for-each-key <collection> <proc>)
;; default
(collect:do-keys <proc> <collection>) ;; talk about lazy!
)
(define-operation (collect:for-each-elt <collection> <proc>)
(collect:do-elts <proc> <collection>)
)
(define (collect:reduce <proc> <seed> . <collections>)
(let ( (max+1 (yasos:size (car <collections>)))
(generators (map collect:gen-elts <collections>))
)
(let loop ( (count 0) )
(cond
((< count max+1)
(set! <seed>
(apply <proc> <seed> (map (lambda (g) (g)) generators)))
(loop (collect:add1 count))
)
(else <seed>)
) )
) )
;; pred true for every elt?
(define (collect:every? <pred?> . <collections>)
(let ( (max+1 (yasos:size (car <collections>)))
(generators (map collect:gen-elts <collections>))
)
(let loop ( (count 0) )
(cond
((< count max+1)
(if (apply <pred?> (map (lambda (g) (g)) generators))
(loop (collect:add1 count))
#f)
)
(else #t)
) )
) )
;; pred true for any elt?
(define (collect:any? <pred?> . <collections>)
(let ( (max+1 (yasos:size (car <collections>)))
(generators (map collect:gen-elts <collections>))
)
(let loop ( (count 0) )
(cond
((< count max+1)
(if (apply <pred?> (map (lambda (g) (g)) generators))
#t
(loop (collect:add1 count))
))
(else #f)
) )
) )
;; MISC UTILITIES
(define (collect:add1 obj) (+ obj 1))
(define (collect:sub1 obj) (- obj 1))
;; Nota Bene: list-set! is bogus for element 0
(define (collect:list-set! <list> <index> <value>)
(define (set-loop last this idx)
(cond
((zero? idx)
(set-cdr! last (cons <value> (cdr this)))
<list>
)
(else (set-loop (cdr last) (cdr this) (collect:sub1 idx)))
) )
;; main
(if (zero? <index>)
(cons <value> (cdr <list>)) ;; return value
(set-loop <list> (cdr <list>) (collect:sub1 <index>)))
)
(add-setter list-ref collect:list-set!) ; for (setter list-ref)
;; generator for list elements
(define (collect:list-gen-elts <list>)
(lambda ()
(if (null? <list>)
(slib:error "No more list elements in generator")
(let ( (elt (car <list>)) )
(set! <list> (cdr <list>))
elt))
) )
;; generator for vector elements
(define (collect:make-vec-gen-elts <accessor>)
(lambda (vec)
(let ( (max+1 (yasos:size vec))
(index 0)
)
(lambda ()
(cond ((< index max+1)
(set! index (collect:add1 index))
(<accessor> vec (collect:sub1 index))
)
(else #f)
) )
) )
)
(define collect:vector-gen-elts (collect:make-vec-gen-elts vector-ref))
(define collect:string-gen-elts (collect:make-vec-gen-elts string-ref))
;;; exports:
(define collection? collect:collection?)
(define empty? collect:empty?)
(define gen-keys collect:gen-keys)
(define gen-elts collect:gen-elts)
(define do-elts collect:do-elts)
(define do-keys collect:do-keys)
(define map-elts collect:map-elts)
(define map-keys collect:map-keys)
(define for-each-key collect:for-each-key)
(define for-each-elt collect:for-each-elt)
(define reduce collect:reduce) ; reduce is also in comlist.scm
(define every? collect:every?)
(define any? collect:any?)
;; --- E O F "collect.oo" --- ;;

328
module/slib/comlist.scm
View file

@ -1,328 +0,0 @@
;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme
; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer.
; Copyright (C) 2000 Colin Walters
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;;; Some of these functions may be already defined in your Scheme.
;;; Comment out those definitions for functions which are already defined.
;;;; LIST FUNCTIONS FROM COMMON LISP
;;; Some tail-recursive optimizations made by
;;; Colin Walters <walters@cis.ohio-state.edu>
;;;From: hugh@ear.mit.edu (Hugh Secker-Walker)
(define (comlist:make-list k . init)
(set! init (if (pair? init) (car init)))
(do ((k k (+ -1 k))
(result '() (cons init result)))
((<= k 0) result)))
(define (comlist:copy-list lst) (append lst '()))
(define (comlist:adjoin e l) (if (memv e l) l (cons e l)))
(define (comlist:union l1 l2)
(cond ((null? l1) l2)
((null? l2) l1)
(else (comlist:union (cdr l1) (comlist:adjoin (car l1) l2)))))
(define (comlist:intersection l1 l2)
;; optimization
(if (null? l2)
l2
(let build-intersection ((l1 l1)
(result '()))
(cond ((null? l1)
result)
((memv (car l1) l2) (build-intersection (cdr l1) (cons (car l1) result)))
(else (build-intersection (cdr l1) result))))))
(define (comlist:set-difference l1 l2)
;; optimization
(if (null? l2)
l1
(let build-difference ((l1 l1)
(result '()))
(cond ((null? l1)
result)
((memv (car l1) l2) (build-difference (cdr l1) result))
(else (build-difference (cdr l1) (cons (car l1) result)))))))
(define (comlist:position obj lst)
(letrec ((pos (lambda (n lst)
(cond ((null? lst) #f)
((eqv? obj (car lst)) n)
(else (pos (+ 1 n) (cdr lst)))))))
(pos 0 lst)))
(define (comlist:reduce-init p init l)
(if (null? l)
init
(comlist:reduce-init p (p init (car l)) (cdr l))))
(define (comlist:reduce p l)
(cond ((null? l) l)
((null? (cdr l)) (car l))
(else (comlist:reduce-init p (car l) (cdr l)))))
(define (comlist:some pred l . rest)
(cond ((null? rest)
(let mapf ((l l))
(and (not (null? l))
(or (pred (car l)) (mapf (cdr l))))))
(else (let mapf ((l l) (rest rest))
(and (not (null? l))
(or (apply pred (car l) (map car rest))
(mapf (cdr l) (map cdr rest))))))))
(define (comlist:every pred l . rest)
(cond ((null? rest)
(let mapf ((l l))
(or (null? l)
(and (pred (car l)) (mapf (cdr l))))))
(else (let mapf ((l l) (rest rest))
(or (null? l)
(and (apply pred (car l) (map car rest))
(mapf (cdr l) (map cdr rest))))))))
(define (comlist:notany pred . ls) (not (apply comlist:some pred ls)))
(define (comlist:notevery pred . ls) (not (apply comlist:every pred ls)))
(define (comlist:list-of?? predicate . bound)
(define (errout) (apply slib:error 'list-of?? predicate bound))
(case (length bound)
((0)
(lambda (obj)
(and (list? obj)
(every predicate obj))))
((1)
(set! bound (car bound))
(cond ((negative? bound)
(set! bound (- bound))
(lambda (obj)
(and (list? obj)
(<= bound (length obj))
(every predicate obj))))
(else
(lambda (obj)
(and (list? obj)
(<= (length obj) bound)
(every predicate obj))))))
((2)
(let ((low (car bound))
(high (cadr bound)))
(cond ((or (negative? low) (negative? high)) (errout))
((< high low)
(set! high (car bound))
(set! low (cadr bound))))
(lambda (obj)
(and (list? obj)
(<= low (length obj) high)
(every predicate obj)))))
(else (errout))))
(define (comlist:find-if t l)
(cond ((null? l) #f)
((t (car l)) (car l))
(else (comlist:find-if t (cdr l)))))
(define (comlist:member-if t l)
(cond ((null? l) #f)
((t (car l)) l)
(else (comlist:member-if t (cdr l)))))
(define (comlist:remove p l)
(let remove ((l l)
(result '()))
(cond ((null? l) result)
((eqv? p (car l)) (remove (cdr l) result))
(else (remove (cdr l) (cons (car l) result))))))
(define (comlist:remove-if p l)
(let remove-if ((l l)
(result '()))
(cond ((null? l) result)
((p (car l)) (remove-if (cdr l) result))
(else (remove-if (cdr l) (cons (car l) result))))))
(define (comlist:remove-if-not p l)
(let remove-if-not ((l l)
(result '()))
(cond ((null? l) result)
((p (car l)) (remove-if-not (cdr l) (cons (car l) result)))
(else (remove-if-not (cdr l) result)))))
(define comlist:nconc
(if (provided? 'rev2-procedures) append!
(lambda args
(cond ((null? args) '())
((null? (cdr args)) (car args))
((null? (car args)) (apply comlist:nconc (cdr args)))
(else
(set-cdr! (last-pair (car args))
(apply comlist:nconc (cdr args)))
(car args))))))
;;;From: hugh@ear.mit.edu (Hugh Secker-Walker)
(define (comlist:nreverse rev-it)
;;; Reverse order of elements of LIST by mutating cdrs.
(cond ((null? rev-it) rev-it)
((not (list? rev-it))
(slib:error "nreverse: Not a list in arg1" rev-it))
(else (do ((reved '() rev-it)
(rev-cdr (cdr rev-it) (cdr rev-cdr))
(rev-it rev-it rev-cdr))
((begin (set-cdr! rev-it reved) (null? rev-cdr)) rev-it)))))
(define (comlist:last lst n)
(comlist:nthcdr (- (length lst) n) lst))
(define (comlist:butlast lst n)
(letrec ((l (- (length lst) n))
(bl (lambda (lst n)
(let build-until-zero ((lst lst)
(n n)
(result '()))
(cond ((null? lst) (reverse result))
((positive? n)
(build-until-zero (cdr lst) (- n 1) (cons (car lst) result)))
(else (reverse result)))))))
(bl lst (if (negative? n)
(slib:error "negative argument to butlast" n)
l))))
(define (comlist:nthcdr n lst)
(if (zero? n) lst (comlist:nthcdr (+ -1 n) (cdr lst))))
(define (comlist:butnthcdr n lst)
(letrec ((bl (lambda (lst n)
(let build-until-zero ((lst lst)
(n n)
(result '()))
(cond ((null? lst) (reverse result))
((positive? n)
(build-until-zero (cdr lst) (- n 1) (cons (car lst) result)))
(else (reverse result)))))))
(bl lst (if (negative? n)
(slib:error "negative argument to butnthcdr" n)
n))))
;;;; CONDITIONALS
(define (comlist:and? . args)
(cond ((null? args) #t)
((car args) (apply comlist:and? (cdr args)))
(else #f)))
(define (comlist:or? . args)
(cond ((null? args) #f)
((car args) #t)
(else (apply comlist:or? (cdr args)))))
;;; Checks to see if a list has any duplicate MEMBERs.
(define (comlist:has-duplicates? lst)
(cond ((null? lst) #f)
((member (car lst) (cdr lst)) #t)
(else (comlist:has-duplicates? (cdr lst)))))
;;; remove duplicates of MEMBERs of a list
(define (comlist:remove-duplicates lst)
(letrec ((rem-dup
(lambda (lst nlst)
(cond ((null? lst) nlst)
((member (car lst) nlst) (rem-dup (cdr lst) nlst))
(else (rem-dup (cdr lst) (cons (car lst) nlst)))))))
(rem-dup lst '())))
(define (comlist:list* x . y)
(define (list*1 x)
(if (null? (cdr x))
(car x)
(cons (car x) (list*1 (cdr x)))))
(if (null? y)
x
(cons x (list*1 y))))
(define (comlist:atom? a)
(not (pair? a)))
(define (comlist:delete obj list)
(let delete ((list list))
(cond ((null? list) '())
((equal? obj (car list)) (delete (cdr list)))
(else
(set-cdr! list (delete (cdr list)))
list))))
(define (comlist:delete-if pred list)
(let delete-if ((list list))
(cond ((null? list) '())
((pred (car list)) (delete-if (cdr list)))
(else
(set-cdr! list (delete-if (cdr list)))
list))))
(define (comlist:delete-if-not pred list)
(let delete-if ((list list))
(cond ((null? list) '())
((not (pred (car list))) (delete-if (cdr list)))
(else
(set-cdr! list (delete-if (cdr list)))
list))))
;;; exports
(define make-list comlist:make-list)
(define copy-list comlist:copy-list)
(define adjoin comlist:adjoin)
(define union comlist:union)
(define intersection comlist:intersection)
(define set-difference comlist:set-difference)
(define position comlist:position)
(define reduce-init comlist:reduce-init)
(define reduce comlist:reduce) ; reduce is also in collect.scm
(define some comlist:some)
(define every comlist:every)
(define notevery comlist:notevery)
(define notany comlist:notany)
(define find-if comlist:find-if)
(define member-if comlist:member-if)
(define remove comlist:remove)
(define remove-if comlist:remove-if)
(define remove-if-not comlist:remove-if-not)
(define nconc comlist:nconc)
(define nreverse comlist:nreverse)
(define last comlist:last)
(define butlast comlist:butlast)
(define nthcdr comlist:nthcdr)
(define butnthcdr comlist:butnthcdr)
(define and? comlist:and?)
(define or? comlist:or?)
(define has-duplicates? comlist:has-duplicates?)
(define remove-duplicates comlist:remove-duplicates)
(define delete-if-not comlist:delete-if-not)
(define delete-if comlist:delete-if)
(define delete comlist:delete)
(define comlist:atom comlist:atom?)
(define atom comlist:atom?)
(define atom? comlist:atom?)
(define list* comlist:list*)
(define list-of?? comlist:list-of??)

99
module/slib/comparse.scm
View file

@ -1,99 +0,0 @@
;;; "comparse.scm" Break command line into arguments.
;Copyright (C) 1995, 1997 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;;;; This is a simple command-line reader. It could be made fancier
;;; to handle lots of `shell' syntaxes.
;;; Albert L. Ting points out that a similar process can be used for
;;; reading files of options -- therefore READ-OPTIONS-FILE.
(require 'string-port)
(define (read-command-from-port port nl-term?)
(define argv '())
(define obj "")
(define chars '())
(define readc (lambda () (read-char port)))
(define peekc (lambda () (peek-char port)))
(define s-expression
(lambda ()
(splice-arg (call-with-output-string
(lambda (p) (display (slib:eval (read port)) p))))))
(define backslash
(lambda (goto)
(readc)
(let ((c (readc)))
(cond ((eqv? #\newline c) (goto (peekc)))
((and (char-whitespace? c) (eqv? #\newline (peekc))
(eqv? 13 (char->integer c)))
(readc) (goto (peekc)))
(else (set! chars (cons c chars)) (build-token (peekc)))))))
(define loop
(lambda (c)
(case c
((#\\) (backslash loop))
((#\") (splice-arg (read port)))
((#\( #\') (s-expression))
((#\#) (do ((c (readc) (readc)))
((or (eof-object? c) (eqv? #\newline c))
(if nl-term? c (loop (peekc))))))
((#\;) (readc))
((#\newline) (readc) (and (not nl-term?) (loop (peekc))))
(else (cond ((eof-object? c) c)
((char-whitespace? c) (readc) (loop (peekc)))
(else (build-token c)))))))
(define splice-arg
(lambda (arg)
(set! obj (string-append obj (list->string (reverse chars)) arg))
(set! chars '())
(build-token (peekc))))
(define buildit
(lambda ()
(readc)
(set! argv (cons (string-append obj (list->string (reverse chars)))
argv))))
(define build-token
(lambda (c)
(case c
((#\") (splice-arg (read port)))
((#\() (s-expression))
((#\\) (backslash build-token))
((#\;) (buildit))
(else (cond ((or (eof-object? c) (char-whitespace? c))
(buildit)
(cond ((not (and nl-term? (eqv? c #\newline)))
(set! obj "")
(set! chars '())
(loop (peekc)))))
(else (set! chars (cons (readc) chars))
(build-token (peekc))))))))
(let ((c (loop (peekc))))
(cond ((and (null? argv) (eof-object? c)) c)
(else (reverse argv)))))
(define (read-command . port)
(read-command-from-port (cond ((null? port) (current-input-port))
((= 1 (length port)) (car port))
(else
(slib:error 'read-command
"Wrong Number of ARGs:" port)))
#t))
(define (read-options-file filename)
(call-with-input-file filename
(lambda (port) (read-command-from-port port #f))))

470
module/slib/cring.scm
View file

@ -1,470 +0,0 @@
;;;"cring.scm" Extend Scheme numerics to any commutative ring.
;Copyright (C) 1997, 1998 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'common-list-functions)
(require 'relational-database)
(require 'database-utilities)
(require 'sort)
(define cring:db (create-database #f 'alist-table))
(define (make-ruleset . rules)
(define name #f)
(cond ((and (not (null? rules)) (symbol? (car rules)))
(set! name (car rules))
(set! rules (cdr rules)))
(else (set! name (gentemp))))
(define-tables cring:db
(list name
'((op symbol)
(sub-op1 symbol)
(sub-op2 symbol))
'((reduction expression))
rules))
(let ((table ((cring:db 'open-table) name #t)))
(and table
(list (table 'get 'reduction)
(table 'row:update)
table))))
(define *ruleset* (make-ruleset 'default))
(define (cring:define-rule . args)
(if *ruleset*
((cadr *ruleset*) args)
(slib:warn "No ruleset in *ruleset*")))
(define (combined-rulesets . rulesets)
(define name #f)
(cond ((symbol? (car rulesets))
(set! name (car rulesets))
(set! rulesets (cdr rulesets)))
(else (set! name (gentemp))))
(apply make-ruleset name
(apply append
(map (lambda (ruleset) (((caddr ruleset) 'row:retrieve*)))
rulesets))))
;;; Distribute * over + (and -)
(define distribute*
(make-ruleset
'distribute*
`(* + identity
,(lambda (exp1 exp2)
;;(print 'distributing '* '+ exp1 exp2 '==>)
(apply + (map (lambda (trm) (* trm exp2)) (cdr exp1)))))
`(* - identity
,(lambda (exp1 exp2)
;;(print 'distributing '* '- exp1 exp2 '==>)
(apply - (map (lambda (trm) (* trm exp2)) (cdr exp1)))))))
;;; Distribute / over + (and -)
(define distribute/
(make-ruleset
'distribute/
`(/ + identity
,(lambda (exp1 exp2)
;;(print 'distributing '/ '+ exp1 exp2 '==>)
(apply + (map (lambda (trm) (/ trm exp2)) (cdr exp1)))))
`(/ - identity
,(lambda (exp1 exp2)
;;(print 'distributing '/ '- exp1 exp2 '==>)
(apply - (map (lambda (trm) (/ trm exp2)) (cdr exp1)))))))
(define (symbol-alpha? sym)
(char-alphabetic? (string-ref (symbol->string sym) 0)))
(define (expression-< x y)
(cond ((and (number? x) (number? y)) (> x y)) ;want negatives last
((number? x) #t)
((number? y) #f)
((and (symbol? x) (symbol? y))
(cond ((eqv? (symbol-alpha? x) (symbol-alpha? y))
(string<? (symbol->string x) (symbol->string y)))
(else (symbol-alpha? x))))
((symbol? x) #t)
((symbol? y) #f)
((null? x) #t)
((null? y) #f)
((expression-< (car x) (car y)) #t)
((expression-< (car y) (car x)) #f)
(else (expression-< (cdr x) (cdr y)))))
(define (expression-sort seq) (sort! seq expression-<))
(define number* *)
(define number+ +)
(define number- -)
(define number/ /)
(define number^ integer-expt)
(define is-term-op? (lambda (term op) (and (pair? term) (eq? op (car term)))))
;;(define (sign x) (if (positive? x) 1 (if (negative? x) -1 0)))
(define number0? zero?)
(define (zero? x) (and (number? x) (number0? x)))
;; To convert to CR internal form, NUMBER-op all the `numbers' in the
;; argument list and remove them from the argument list. Collect the
;; remaining arguments into equivalence classes, keeping track of the
;; number of arguments in each class. The returned list is thus:
;; (<numeric> (<expression1> . <exp1>) ...)
;;; Converts * argument list to CR internal form
(define (cr*-args->fcts args)
;;(print (cons 'cr*-args->fcts args) '==>)
(let loop ((args args) (pow 1) (nums 1) (arg.exps '()))
;;(print (list 'loop args pow nums denoms arg.exps) '==>)
(cond ((null? args) (cons nums arg.exps))
((number? (car args))
(let ((num^pow (number^ (car args) (abs pow))))
(if (negative? pow)
(loop (cdr args) pow (number/ (number* num^pow nums))
arg.exps)
(loop (cdr args) pow (number* num^pow nums) arg.exps))))
;; Associative Rule
((is-term-op? (car args) '*) (loop (append (cdar args) (cdr args))
pow nums arg.exps))
;; Do singlet -
((and (is-term-op? (car args) '-) (= 2 (length (car args))))
;;(print 'got-here (car args))
(set! arg.exps (loop (cdar args) pow (number- nums) arg.exps))
(loop (cdr args) pow
(car arg.exps)
(cdr arg.exps)))
((and (is-term-op? (car args) '/) (= 2 (length (car args))))
;; Do singlet /
;;(print 'got-here=cr+ (car args))
(set! arg.exps (loop (cdar args) (number- pow) nums arg.exps))
(loop (cdr args) pow
(car arg.exps)
(cdr arg.exps)))
((is-term-op? (car args) '/)
;; Do multi-arg /
;;(print 'doing '/ (cddar args) (number- pow))
(set! arg.exps
(loop (cddar args) (number- pow) nums arg.exps))
;;(print 'finishing '/ (cons (cadar args) (cdr args)) pow)
(loop (cons (cadar args) (cdr args))
pow
(car arg.exps)
(cdr arg.exps)))
;; Pull out numeric exponents as powers
((and (is-term-op? (car args) '^)
(= 3 (length (car args)))
(number? (caddar args)))
(set! arg.exps (loop (list (cadar args))
(number* pow (caddar args))
nums
arg.exps))
(loop (cdr args) pow (car arg.exps) (cdr arg.exps)))
;; combine with same terms
((assoc (car args) arg.exps)
=> (lambda (pair) (set-cdr! pair (number+ pow (cdr pair)))
(loop (cdr args) pow nums arg.exps)))
;; Add new term to arg.exps
(else (loop (cdr args) pow nums
(cons (cons (car args) pow) arg.exps))))))
;;; Converts + argument list to CR internal form
(define (cr+-args->trms args)
(let loop ((args args) (cof 1) (numbers 0) (arg.exps '()))
(cond ((null? args) (cons numbers arg.exps))
((number? (car args))
(loop (cdr args)
cof
(number+ (number* (car args) cof) numbers)
arg.exps))
;; Associative Rule
((is-term-op? (car args) '+) (loop (append (cdar args) (cdr args))
cof
numbers
arg.exps))
;; Idempotent singlet *
((and (is-term-op? (car args) '*) (= 2 (length (car args))))
(loop (cons (cadar args) (cdr args))
cof
numbers
arg.exps))
((and (is-term-op? (car args) '-) (= 2 (length (car args))))
;; Do singlet -
(set! arg.exps (loop (cdar args) (number- cof) numbers arg.exps))
(loop (cdr args) cof (car arg.exps) (cdr arg.exps)))
;; Pull out numeric factors as coefficients
((and (is-term-op? (car args) '*) (some number? (cdar args)))
;;(print 'got-here (car args) '=> (cons '* (remove-if number? (cdar args))))
(set! arg.exps
(loop (list (cons '* (remove-if number? (cdar args))))
(apply number* cof (remove-if-not number? (cdar args)))
numbers
arg.exps))
(loop (cdr args) cof (car arg.exps) (cdr arg.exps)))
((is-term-op? (car args) '-)
;; Do multi-arg -
(set! arg.exps (loop (cddar args) (number- cof) numbers arg.exps))
(loop (cons (cadar args) (cdr args))
cof
(car arg.exps)
(cdr arg.exps)))
;; combine with same terms
((assoc (car args) arg.exps)
=> (lambda (pair) (set-cdr! pair (number+ cof (cdr pair)))
(loop (cdr args) cof numbers arg.exps)))
;; Add new term to arg.exps
(else (loop (cdr args) cof numbers
(cons (cons (car args) cof) arg.exps))))))
;;; Converts + or * internal form to Scheme expression
(define (cr-terms->form op ident inv-op higher-op res.cofs)
(define (negative-cof? fct.cof)
(negative? (cdr fct.cof)))
(define (finish exprs)
(if (null? exprs) ident
(if (null? (cdr exprs))
(car exprs)
(cons op exprs))))
(define (do-terms sign fct.cofs)
(expression-sort
(map (lambda (fct.cof)
(define cof (number* sign (cdr fct.cof)))
(cond ((eqv? 1 cof) (car fct.cof))
((number? (car fct.cof)) (number* cof (car fct.cof)))
((is-term-op? (car fct.cof) higher-op)
(if (eq? higher-op '^)
(list '^ (cadar fct.cof) (* cof (caddar fct.cof)))
(cons higher-op (cons cof (cdar fct.cof)))))
((eqv? -1 cof) (list inv-op (car fct.cof)))
(else (list higher-op (car fct.cof) cof))))
fct.cofs)))
(let* ((all.cofs (remove-if (lambda (fct.cof)
(or (zero? (cdr fct.cof))
(eqv? ident (car fct.cof))))
res.cofs))
(cofs (map cdr all.cofs))
(some-positive? (some positive? cofs)))
;;(print op 'positive? some-positive? 'negative? (some negative? cofs) all.cofs)
(cond ((and some-positive? (some negative? cofs))
(append (list inv-op
(finish (do-terms
1 (remove-if negative-cof? all.cofs))))
(do-terms -1 (remove-if-not negative-cof? all.cofs))))
(some-positive? (finish (do-terms 1 all.cofs)))
((not (some negative? cofs)) ident)
(else (list inv-op (finish (do-terms -1 all.cofs)))))))
(define (* . args)
(cond
((null? args) 1)
;;This next line is commented out so ^ will collapse numerical expressions.
;;((null? (cdr args)) (car args))
(else
(let ((in (cr*-args->fcts args)))
(cond
((zero? (car in)) 0)
(else
(if (null? (cdr in))
(set-cdr! in (list (cons 1 1))))
(let* ((num #f)
(ans (cr-terms->form
'* 1 '/ '^
(apply
(lambda (numeric red.cofs res.cofs)
(set! num numeric)
(append
;;(list (cons (abs numeric) 1))
red.cofs
res.cofs))
(cr1 '* number* '^ '/ (car in) (cdr in))))))
(cond ((number0? (+ -1 num)) ans)
((number? ans) (number* num ans))
((number0? (+ 1 num))
(if (and (list? ans) (= 2 (length ans)) (eq? '- (car ans)))
(cadr ans)
(list '- ans)))
((not (pair? ans)) (list '* num ans))
(else
(case (car ans)
((*) (append (list '* num) (cdr ans)))
((+) (apply + (map (lambda (mon) (* num mon)) (cdr ans))))
((-) (apply - (map (lambda (mon) (* num mon)) (cdr ans))))
(else (list '* num ans))))))))))))
(define (+ . args)
(cond ((null? args) 0)
;;((null? (cdr args)) (car args))
(else
(let ((in (cr+-args->trms args)))
(if (null? (cdr in))
(car in)
(cr-terms->form
'+ 0 '- '*
(apply (lambda (numeric red.cofs res.cofs)
(append
(list (if (and (number? numeric)
(negative? numeric))
(cons (abs numeric) -1)
(cons numeric 1)))
red.cofs
res.cofs))
(cr1 '+ number+ '* '- (car in) (cdr in)))))))))
(define (- arg1 . args)
(if (null? args)
(if (number? arg1) (number- arg1)
(* -1 arg1) ;(list '- arg1)
)
(+ arg1 (* -1 (apply + args)))))
;;(print `(/ ,arg1 ,@args) '=> )
(define (/ arg1 . args)
(if (null? args)
(^ arg1 -1)
(* arg1 (^ (apply * args) -1))))
(define (^ arg1 arg2)
(cond ((and (number? arg2) (integer? arg2))
(* (list '^ arg1 arg2)))
(else (list '^ arg1 arg2))))
;; TRY-EACH-PAIR-ONCE algorithm. I think this does the minimum
;; number of rule lookups given no information about how to sort
;; terms.
;; Pick equivalence classes one at a time and move them into the
;; result set of equivalence classes by searching for rules to
;; multiply an element of the chosen class by itself (if multiple) and
;; the element of each class already in the result group. Each
;; (multiplicative) term resulting from rule application would be put
;; in the result class, if that class exists; or put in an argument
;; class if not.
(define (cr1 op number-op hop inv-op numeric in)
(define red.pows '())
(define res.pows '())
(define (cring:apply-rule->terms exp1 exp2) ;(display op)
(let ((ans (cring:apply-rule op exp1 exp2)))
(cond ((not ans) #f)
((number? ans) (list ans))
(else (list (cons ans 1))))))
(define (cring:apply-inv-rule->terms exp1 exp2) ;(display inv-op)
(let ((ans (cring:apply-rule inv-op exp1 exp2)))
(cond ((not ans) #f)
((number? ans) (list ans))
(else (list (cons ans 1))))))
(let loop.arg.pow.s ((arg (caar in)) (pow (cdar in)) (arg.pows (cdr in)))
(define (arg-loop arg.pows)
(cond ((not (null? arg.pows))
(loop.arg.pow.s (caar arg.pows) (cdar arg.pows) (cdr arg.pows)))
(else (list numeric red.pows res.pows)))) ; Actually return!
(define (merge-res tmp.pows multiplicity)
(cond ((null? tmp.pows))
((number? (car tmp.pows))
(do ((m (number+ -1 (abs multiplicity)) (number+ -1 m))
(n numeric (number-op n (abs (car tmp.pows)))))
((negative? m) (set! numeric n)))
(merge-res (cdr tmp.pows) multiplicity))
((or (assoc (car tmp.pows) res.pows)
(assoc (car tmp.pows) arg.pows))
=> (lambda (pair)
(set-cdr! pair (number+
pow (number-op multiplicity (cdar tmp.pows))))
(merge-res (cdr tmp.pows) multiplicity)))
((assoc (car tmp.pows) red.pows)
=> (lambda (pair)
(set! arg.pows
(cons (cons (caar tmp.pows)
(number+
(cdr pair)
(number* multiplicity (cdar tmp.pows))))
arg.pows))
(set-cdr! pair 0)
(merge-res (cdr tmp.pows) multiplicity)))
(else (set! arg.pows
(cons (cons (caar tmp.pows)
(number* multiplicity (cdar tmp.pows)))
arg.pows))
(merge-res (cdr tmp.pows) multiplicity))))
(define (try-fct.pow fct.pow)
;;(print 'try-fct.pow fct.pow op 'arg arg 'pow pow)
(cond ((or (zero? (cdr fct.pow)) (number? (car fct.pow))) #f)
((not (and (number? pow) (number? (cdr fct.pow))
(integer? pow) ;(integer? (cdr fct.pow))
))
#f)
;;((zero? pow) (slib:error "Don't try exp-0 terms") #f)
;;((or (number? arg) (number? (car fct.pow)))
;; (slib:error 'found-number arg fct.pow) #f)
((and (positive? pow) (positive? (cdr fct.pow))
(or (cring:apply-rule->terms arg (car fct.pow))
(cring:apply-rule->terms (car fct.pow) arg)))
=> (lambda (terms)
;;(print op op terms)
(let ((multiplicity (min pow (cdr fct.pow))))
(set-cdr! fct.pow (number- (cdr fct.pow) multiplicity))
(set! pow (number- pow multiplicity))
(merge-res terms multiplicity))))
((and (negative? pow) (negative? (cdr fct.pow))
(or (cring:apply-rule->terms arg (car fct.pow))
(cring:apply-rule->terms (car fct.pow) arg)))
=> (lambda (terms)
;;(print inv-op inv-op terms)
(let ((multiplicity (max pow (cdr fct.pow))))
(set-cdr! fct.pow (number+ (cdr fct.pow) multiplicity))
(set! pow (number+ pow multiplicity))
(merge-res terms multiplicity))))
((and (positive? pow) (negative? (cdr fct.pow))
(cring:apply-inv-rule->terms arg (car fct.pow)))
=> (lambda (terms)
;;(print op inv-op terms)
(let ((multiplicity (min pow (number- (cdr fct.pow)))))
(set-cdr! fct.pow (number+ (cdr fct.pow) multiplicity))
(set! pow (number- pow multiplicity))
(merge-res terms multiplicity))))
((and (negative? pow) (positive? (cdr fct.pow))
(cring:apply-inv-rule->terms (car fct.pow) arg))
=> (lambda (terms)
;;(print inv-op op terms)
(let ((multiplicity (max (number- pow) (cdr fct.pow))))
(set-cdr! fct.pow (number- (cdr fct.pow) multiplicity))
(set! pow (number+ pow multiplicity))
(merge-res terms multiplicity))))
(else #f)))
;;(print op numeric 'arg arg 'pow pow 'arg.pows arg.pows 'red.pows red.pows 'res.pows res.pows)
;;(trace arg-loop cring:apply-rule->terms merge-res try-fct.pow) (set! *qp-width* 333)
(cond ((or (zero? pow) (eqv? 1 arg)) ;(number? arg) arg seems to always be 1
(arg-loop arg.pows))
((assoc arg res.pows) => (lambda (pair)
(set-cdr! pair (number+ pow (cdr pair)))
(arg-loop arg.pows)))
((and (> (abs pow) 1) (cring:apply-rule->terms arg arg))
=> (lambda (terms)
(merge-res terms (quotient pow 2))
(if (odd? pow)
(loop.arg.pow.s arg 1 arg.pows)
(arg-loop arg.pows))))
((or (some try-fct.pow res.pows) (some try-fct.pow arg.pows))
(loop.arg.pow.s arg pow arg.pows))
(else (set! res.pows (cons (cons arg pow) res.pows))
(arg-loop arg.pows)))))
(define (cring:try-rule op sop1 sop2 exp1 exp2)
(and *ruleset*
(let ((rule ((car *ruleset*) op sop1 sop2)))
(and rule (rule exp1 exp2)))))
(define (cring:apply-rule op exp1 exp2)
(and (pair? exp1)
(or (and (pair? exp2)
(cring:try-rule op (car exp1) (car exp2) exp1 exp2))
(cring:try-rule op (car exp1) 'identity exp1 exp2))))
;;(begin (trace cr-terms->form) (set! *qp-width* 333))

463
module/slib/db2html.scm
View file

@ -1,463 +0,0 @@
;"db2html.scm" Convert relational database to hyperlinked pages.
; Copyright 1997, 1998, 2000, 2001 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'uri)
(require 'html-form)
(require 'net-clients)
(require 'string-search)
;;@code{(require 'db->html)}
;;@body
(define (html:table options . rows)
(apply string-append
(sprintf #f "<TABLE %s>\\n" (or options ""))
(append rows (list (sprintf #f "</TABLE>\\n")))))
;;@args caption align
;;@args caption
;;@2 can be @samp{top} or @samp{bottom}.
(define (html:caption caption . align)
(if (null? align)
(sprintf #f " <CAPTION>%s</CAPTION>\\n"
(html:plain caption))
(sprintf #f " <CAPTION ALIGN=%s>%s</CAPTION>\\n"
(car align)
(html:plain caption))))
;;@body Outputs a heading row for the currently-started table.
(define (html:heading columns)
(sprintf #f " <TR VALIGN=\"TOP\">\\n%s </TR>\\n"
(apply string-append
(map (lambda (datum)
(sprintf #f " <TH>%s</TH>\\n" (or datum "")))
columns))))
;;@body Outputs a heading row with column-names @1 linked to URIs @2.
(define (html:href-heading columns uris)
(html:heading
(map (lambda (column uri)
(if uri
(html:link uri column)
column))
columns uris)))
(define (row->anchor pkl row)
(sprintf #f "<A NAME=\"%s\"></A>" (uri:make-path (butnthcdr pkl row))))
;;@args k foreigns
;;
;;The positive integer @1 is the primary-key-limit (number of
;;primary-keys) of the table. @2 is a list of the filenames of
;;foreign-key field pages and #f for non foreign-key fields.
;;
;;@0 returns a procedure taking a row for its single argument. This
;;returned procedure returns the html string for that table row.
(define (html:linked-row-converter pkl foreigns)
(define idxs (do ((idx (length foreigns) (+ -1 idx))
(nats '() (cons idx nats)))
((not (positive? idx)) nats)))
(require 'pretty-print)
(lambda (row)
(define (present datum)
(if (or (string? datum) (symbol? datum))
(html:plain datum)
(let* ((str (pretty-print->string datum))
(len (+ -1 (string-length str))))
(cond ((eqv? (string-index str #\newline) len)
(string-append "<TT>" (substring str 0 len) "</TT>"))
(else (html:pre str))))))
(sprintf #f " <TR VALIGN=TOP>\\n%s </TR>\\n"
(apply string-append
(map (lambda (idx datum foreign)
(sprintf
#f " <TD>%s%s</TD>\\n"
(if (eqv? 1 idx) (row->anchor pkl row) "")
(cond ((or (not datum) (null? datum)) "")
((not foreign) (present datum))
((equal? "catalog-data.html" foreign)
(html:link (make-uri
(table-name->filename datum)
#f #f)
(present datum)))
(else (html:link (make-uri foreign #f datum)
(present datum))))))
idxs row foreigns)))))
;;@body
;;Returns the symbol @1 converted to a filename.
(define (table-name->filename table-name)
(and table-name (string-append
(string-subst (symbol->string table-name) "*" "" ":" "_")
".html")))
(define (table-name->column-table-name db table-name)
((((db 'open-table) '*catalog-data* #f) 'get 'coltab-name)
table-name))
;;@args caption db table-name match-key1 @dots{}
;;Returns HTML string for @2 table @3. Every foreign-key value is
;;linked to the page (of the table) defining that key.
;;
;;The optional @4 @dots{} arguments restrict actions to a subset of
;;the table. @xref{Table Operations, match-key}.
(define (table->linked-html caption db table-name . args)
(let* ((table ((db 'open-table) table-name #f))
(foreigns (table 'column-foreigns))
(tags (map table-name->filename foreigns))
(names (table 'column-names))
(primlim (table 'primary-limit)))
(apply html:table "CELLSPACING=0 BORDER=1"
(html:caption caption 'BOTTOM)
(html:href-heading
names
(append (make-list primlim
(table-name->filename
(table-name->column-table-name db table-name)))
(make-list (- (length names) primlim) #f)))
(html:heading (table 'column-domains))
(html:href-heading foreigns tags)
(html:heading (table 'column-types))
(map (html:linked-row-converter primlim tags)
(apply (table 'row:retrieve*) args)))))
;;@body
;;Returns a complete HTML page. The string @3 names the page which
;;refers to this one.
;;
;;The optional @4 @dots{} arguments restrict actions to a subset of
;;the table. @xref{Table Operations, match-key}.
(define (table->linked-page db table-name index-filename . args)
(string-append
(if index-filename
(html:head table-name
(html:link (make-uri index-filename #f table-name)
(html:plain table-name)))
(html:head table-name))
(html:body (apply table->linked-html table-name db table-name args))))
(define (html:catalog-row-converter row foreigns)
(sprintf #f " <TR VALIGN=TOP>\\n%s </TR>\\n"
(apply string-append
(map (lambda (datum foreign)
(sprintf #f " <TD>%s%s</TD>\\n"
(html:anchor (sprintf #f "%s" datum))
(html:link (make-uri foreign #f #f) datum)))
row foreigns))))
;;@body
;;Returns HTML string for the catalog table of @1.
(define (catalog->html db caption . args)
(apply html:table "BORDER=1"
(html:caption caption 'BOTTOM)
(html:heading '(table columns))
(map (lambda (row)
(cond ((and (eq? '*columns* (caddr row))
(not (eq? '*columns* (car row))))
"")
(else (html:catalog-row-converter
(list (car row) (caddr row))
(list (table-name->filename (car row))
(table-name->filename (caddr row)))))))
(apply (((db 'open-table) '*catalog-data* #f) 'row:retrieve*)
args))))
;;Returns complete HTML page (string) for the catalog table of @1.
(define (catalog->page db caption . args)
(string-append (html:head caption)
(html:body (apply catalog->html db caption args))))
;;@subsection HTML editing tables
;;@noindent A client can modify one row of an editable table at a time.
;;For any change submitted, these routines check if that row has been
;;modified during the time the user has been editing the form. If so,
;;an error page results.
;;
;;@noindent The behavior of edited rows is:
;;
;;@itemize @bullet
;;@item
;;If no fields are changed, then no change is made to the table.
;;@item
;;If the primary keys equal null-keys (parameter defaults), and no other
;;user has modified that row, then that row is deleted.
;;@item
;;If only primary keys are changed, there are non-key fields, and no
;;row with the new keys is in the table, then the old row is
;;deleted and one with the new keys is inserted.
;;@item
;;If only non-key fields are changed, and that row has not been
;;modified by another user, then the row is changed to reflect the
;;fields.
;;@item
;;If both keys and non-key fields are changed, and no row with the
;;new keys is in the table, then a row is created with the new
;;keys and fields.
;;@item
;;If fields are changed, all fields are primary keys, and no row with
;;the new keys is in the table, then a row is created with the new
;;keys.
;;@end itemize
;;
;;@noindent After any change to the table, a @code{sync-database} of the
;;database is performed.
;;@args table-name null-keys update delete retrieve
;;@args table-name null-keys update delete
;;@args table-name null-keys update
;;@args table-name null-keys
;;
;;Returns procedure (of @var{db}) which returns procedure to modify row
;;of @1. @2 is the list of @dfn{null} keys which indicate that the row
;;is to be deleted. Optional arguments @3, @4, and @5 default to the
;;@code{row:update}, @code{row:delete}, and @code{row:retrieve} of @1 in
;;@var{db}.
(define (command:modify-table table-name null-keys . args)
(define argc (length args))
(lambda (rdb)
(define table ((rdb 'open-table) table-name #t))
(let ((table:update (or (and (> argc 0) (car args)) (table 'row:update)))
(table:delete (or (and (> argc 1) (cadr args)) (table 'row:delete)))
(table:retrieve (or (and (> argc 2) (caddr args)) (table 'row:retrieve)))
(pkl (length null-keys)))
(define ptypes (butnthcdr pkl (table 'column-types)))
(if (> argc 4) (slib:error 'command:modify-table 'too-many-args
table-name null-keys args))
(lambda (*keys* *row-hash* . new-row)
(let* ((new-pkeys (butnthcdr pkl new-row))
(pkeys (uri:path->keys (uri:split-fields *keys* #\/) ptypes))
(row (apply table:retrieve pkeys))
(same-nonkeys? (equal? (nthcdr pkl new-row) (nthcdr pkl row))))
(cond ((equal? pkeys new-pkeys) ;did not change keys
(cond ((not row) '("Row deleted by other user"))
((equal? (crc:hash-obj row) *row-hash*)
(table:update new-row)
((rdb 'sync-database)) #t)
(else '("Row changed by other user"))))
((equal? null-keys new-pkeys) ;blanked keys
(cond ((not row) #t)
((equal? (crc:hash-obj row) *row-hash*)
;;(slib:warn (sprintf #f "Removing key: %#a => %#a" new-pkeys ))
(apply table:delete pkeys)
((rdb 'sync-database)) #t)
(else '("Row changed by other user"))))
(else ;changed keys
(set! row (apply table:retrieve new-pkeys))
(cond (row (list "Row already exists"
(sprintf #f "%#a" row)))
(else (table:update new-row)
(if (and same-nonkeys?
(not (null? (nthcdr pkl new-row))))
(apply table:delete pkeys))
((rdb 'sync-database)) #t)))))))))
;;@body Given @2 in @1, creates parameter and @code{*command*} tables
;;for editing one row of @2 at a time. @0 returns a procedure taking a
;;row argument which returns the HTML string for editing that row.
;;
;;Optional @3 are expressions (lists) added to the call to
;;@code{command:modify-table}.
;;
;;The domain name of a column determines the expected arity of the data
;;stored in that column. Domain names ending in:
;;
;;@table @samp
;;@item *
;;have arity @samp{nary};
;;@item +
;;have arity @samp{nary1}.
;;@end table
(define (command:make-editable-table rdb table-name . args)
(define table ((rdb 'open-table) table-name #t))
(let ((pkl (table 'primary-limit))
(columns (table 'column-names))
(domains (table 'column-domains))
(types (table 'column-types))
(idxs (do ((idx (length (table 'column-names)) (+ -1 idx))
(nats '() (cons (+ 2 idx) nats)))
((not (positive? idx)) nats)))
(ftn (((rdb 'open-table) '*domains-data* #f) 'get 'foreign-table)))
(define field-specs
(map (lambda (idx column domain type)
(let* ((dstr (symbol->string domain))
(len (+ -1 (string-length dstr))))
(define arity
(case (string-ref dstr len)
((#\*) 'nary)
((#\+) 'nary1)
(else 'single)))
(case (string-ref dstr len)
((#\* #\+)
(set! type (string->symbol (substring dstr 0 len)))
(set! domain type)))
`(,idx ,column ,arity ,domain
,(make-defaulter arity type) #f "")))
idxs columns domains types))
(define foreign-choice-lists
(map (lambda (domain-name)
(define tab-name (ftn domain-name))
(if tab-name (get-foreign-choices (rdb-open tab-name #f)) '()))
domains))
(define-tables rdb
`(,(symbol-append table-name '- 'params)
*parameter-columns* *parameter-columns*
((1 *keys* single string #f #f "")
(2 *row-hash* single string #f #f "")
,@field-specs))
`(,(symbol-append table-name '- 'pname)
((name string))
((parameter-index uint)) ;should be address-params
(("*keys*" 1)
("*row-hash*" 2)
,@(map (lambda (idx column) (list (symbol->string column) idx))
idxs columns)))
`(*commands*
desc:*commands* desc:*commands*
((,(symbol-append 'edit '- table-name)
,(symbol-append table-name '- 'params)
,(symbol-append table-name '- 'pname)
(command:modify-table ',table-name
',(map (lambda (fs)
(caadr (caddar (cddddr fs))))
(butnthcdr pkl field-specs))
,@args)
,(string-append "Modify " (symbol->string table-name))))))
(let ((arities (map caddr field-specs)))
(lambda (row)
(define elements
(map form:element
columns
arities
(map (lambda (fld arity) (case arity
((nary nary1) fld)
(else (list fld))))
row arities)
foreign-choice-lists))
(sprintf #f " <TR>\\n <TD>%s</TD>%s\\n </TR>\\n"
(string-append
(html:hidden '*row-hash* (crc:hash-obj row))
(html:hidden '*keys* (uri:make-path (butnthcdr pkl row)))
;; (html:hidden '*suggest* '<>)
(car elements)
(form:submit '<> (symbol-append 'edit '- table-name))
;; (form:image "Modify Row" "/icons/bang.png")
)
(apply string-append
(map (lambda (elt) (sprintf #f " <TD>%s</TD>\\n" elt))
(cdr elements))))))))
;;@args k names edit-point edit-converter
;;
;;The positive integer @1 is the primary-key-limit (number of
;;primary-keys) of the table. @2 is a list of the field-names. @3 is
;;the list of primary-keys denoting the row to edit (or #f). @4 is the
;;procedure called with @1, @2, and the row to edit.
;;
;;@0 returns a procedure taking a row for its single argument. This
;;returned procedure returns the html string for that table row.
;;
;;Each HTML table constructed using @0 has first @1 fields (typically
;;the primary key fields) of each row linked to a text encoding of these
;;fields (the result of calling @code{row->anchor}). The page so
;;referenced typically allows the user to edit fields of that row.
(define (html:editable-row-converter pkl names edit-point edit-converter)
(require 'pretty-print)
(let ((idxs (do ((idx (length names) (+ -1 idx))
(nats '() (cons idx nats)))
((not (positive? idx)) nats)))
(datum->html
(lambda (datum)
(if (or (string? datum) (symbol? datum))
(html:plain datum)
(let* ((str (pretty-print->string datum))
(len (+ -1 (string-length str))))
(cond ((eqv? (string-index str #\newline) len)
(string-append "<B>" (substring str 0 len) "</B>"))
(else (html:pre str))))))))
(lambda (row)
(string-append
(sprintf #f " <TR VALIGN=TOP>\\n%s </TR>\\n"
(apply string-append
(map (lambda (idx datum foreign)
(sprintf
#f " <TD>%s%s</TD>\\n"
(if (eqv? 1 idx) (row->anchor pkl row) "")
(cond ((or (not datum) (null? datum)) "")
((<= idx pkl)
(let ((keystr (uri:make-path
(butnthcdr pkl row))))
(sprintf #f "<A HREF=\"%s#%s\">%s</A>"
keystr keystr
(datum->html datum))))
(else (datum->html datum)))))
idxs row names)))
(if (and edit-point edit-converter
(equal? (butnthcdr pkl edit-point) (butnthcdr pkl row)))
(edit-converter row)
"")))))
;;@subsection HTML databases
;;@body @1 must be a relational database. @2 must be #f or a
;;non-empty string naming an existing sub-directory of the current
;;directory.
;;
;;@0 creates an html page for each table in the database @1 in the
;;sub-directory named @2, or the current directory if @2 is #f. The
;;top level page with the catalog of tables (captioned @4) is written
;;to a file named @3.
(define (db->html-files db dir index-filename caption)
(call-with-output-file (in-vicinity (if dir (sub-vicinity "" dir) "")
index-filename)
(lambda (port)
(display (catalog->page db caption) port)))
((((db 'open-table) '*catalog-data* #f) 'for-each-row)
(lambda (row)
(call-with-output-file
(in-vicinity (sub-vicinity "" dir) (table-name->filename (car row)))
(lambda (port)
(display (table->linked-page db (car row) index-filename) port))))))
;;@args db dir index-filename
;;@args db dir
;;@1 must be a relational database. @2 must be a non-empty
;;string naming an existing sub-directory of the current directory or
;;one to be created. The optional string @3 names the filename of the
;;top page, which defaults to @file{index.html}.
;;
;;@0 creates sub-directory @2 if neccessary, and calls
;;@code{(db->html-files @1 @2 @3 @2)}. The @samp{file:} URI of @3 is
;;returned.
(define (db->html-directory db dir . index-filename)
(set! index-filename (if (null? index-filename)
"index.html"
(car index-filename)))
(if (symbol? dir) (set! dir (symbol->string dir)))
(if (not (file-exists? dir)) (make-directory dir))
(db->html-files db dir index-filename dir)
(path->uri (in-vicinity (sub-vicinity "" dir) index-filename)))
;;@args db dir index-filename
;;@args db dir
;;@0 is just like @code{db->html-directory}, but calls
;;@code{browse-url-netscape} with the uri for the top page after the
;;pages are created.
(define (db->netscape . args)
(browse-url-netscape (apply db->html-directory args)))

185
module/slib/db2html.txi
View file

@ -1,185 +0,0 @@
@code{(require 'db->html)}
@defun html:table options row @dots{}
@end defun
@defun html:caption caption align
@defunx html:caption caption
@var{align} can be @samp{top} or @samp{bottom}.
@end defun
@defun html:heading columns
Outputs a heading row for the currently-started table.
@end defun
@defun html:href-heading columns uris
Outputs a heading row with column-names @var{columns} linked to URIs @var{uris}.
@end defun
@defun html:linked-row-converter k foreigns
The positive integer @var{k} is the primary-key-limit (number of
primary-keys) of the table. @var{foreigns} is a list of the filenames of
foreign-key field pages and #f for non foreign-key fields.
@code{html:linked-row-converter} returns a procedure taking a row for its single argument. This
returned procedure returns the html string for that table row.
@end defun
@defun table-name->filename table-name
Returns the symbol @var{table-name} converted to a filename.
@end defun
@defun table->linked-html caption db table-name match-key1 @dots{}
Returns HTML string for @var{db} table @var{table-name}. Every foreign-key value is
linked to the page (of the table) defining that key.
The optional @var{match-key1} @dots{} arguments restrict actions to a subset of
the table. @xref{Table Operations, match-key}.
@end defun
@defun table->linked-page db table-name index-filename arg @dots{}
Returns a complete HTML page. The string @var{index-filename} names the page which
refers to this one.
The optional @var{args} @dots{} arguments restrict actions to a subset of
the table. @xref{Table Operations, match-key}.
@end defun
@defun catalog->html db caption arg @dots{}
Returns HTML string for the catalog table of @var{db}.
@end defun
@subsection HTML editing tables
@noindent A client can modify one row of an editable table at a time.
For any change submitted, these routines check if that row has been
modified during the time the user has been editing the form. If so,
an error page results.
@noindent The behavior of edited rows is:
@itemize @bullet
@item
If no fields are changed, then no change is made to the table.
@item
If the primary keys equal null-keys (parameter defaults), and no other
user has modified that row, then that row is deleted.
@item
If only primary keys are changed, there are non-key fields, and no
row with the new keys is in the table, then the old row is
deleted and one with the new keys is inserted.
@item
If only non-key fields are changed, and that row has not been
modified by another user, then the row is changed to reflect the
fields.
@item
If both keys and non-key fields are changed, and no row with the
new keys is in the table, then a row is created with the new
keys and fields.
@item
If fields are changed, all fields are primary keys, and no row with
the new keys is in the table, then a row is created with the new
keys.
@end itemize
@noindent After any change to the table, a @code{sync-database} of the
database is performed.
@defun command:modify-table table-name null-keys update delete retrieve
@defunx command:modify-table table-name null-keys update delete
@defunx command:modify-table table-name null-keys update
@defunx command:modify-table table-name null-keys
Returns procedure (of @var{db}) which returns procedure to modify row
of @var{table-name}. @var{null-keys} is the list of @dfn{null} keys which indicate that the row
@cindex null
is to be deleted. Optional arguments @var{update}, @var{delete}, and @var{retrieve} default to the
@code{row:update}, @code{row:delete}, and @code{row:retrieve} of @var{table-name} in
@var{db}.
@end defun
@defun command:make-editable-table rdb table-name arg @dots{}
Given @var{table-name} in @var{rdb}, creates parameter and @code{*command*} tables
for editing one row of @var{table-name} at a time. @code{command:make-editable-table} returns a procedure taking a
row argument which returns the HTML string for editing that row.
Optional @var{args} are expressions (lists) added to the call to
@code{command:modify-table}.
The domain name of a column determines the expected arity of the data
stored in that column. Domain names ending in:
@table @samp
@item *
have arity @samp{nary};
@item +
have arity @samp{nary1}.
@end table
@end defun
@defun html:editable-row-converter k names edit-point edit-converter
The positive integer @var{k} is the primary-key-limit (number of
primary-keys) of the table. @var{names} is a list of the field-names. @var{edit-point} is
the list of primary-keys denoting the row to edit (or #f). @var{edit-converter} is the
procedure called with @var{k}, @var{names}, and the row to edit.
@code{html:editable-row-converter} returns a procedure taking a row for its single argument. This
returned procedure returns the html string for that table row.
Each HTML table constructed using @code{html:editable-row-converter} has first @var{k} fields (typically
the primary key fields) of each row linked to a text encoding of these
fields (the result of calling @code{row->anchor}). The page so
referenced typically allows the user to edit fields of that row.
@end defun
@subsection HTML databases
@defun db->html-files db dir index-filename caption
@var{db} must be a relational database. @var{dir} must be #f or a
non-empty string naming an existing sub-directory of the current
directory.
@code{db->html-files} creates an html page for each table in the database @var{db} in the
sub-directory named @var{dir}, or the current directory if @var{dir} is #f. The
top level page with the catalog of tables (captioned @var{caption}) is written
to a file named @var{index-filename}.
@end defun
@defun db->html-directory db dir index-filename
@defunx db->html-directory db dir
@var{db} must be a relational database. @var{dir} must be a non-empty
string naming an existing sub-directory of the current directory or
one to be created. The optional string @var{index-filename} names the filename of the
top page, which defaults to @file{index.html}.
@code{db->html-directory} creates sub-directory @var{dir} if neccessary, and calls
@code{(db->html-files @var{db} @var{dir} @var{index-filename} @var{dir})}. The @samp{file:} URI of @var{index-filename} is
returned.
@end defun
@defun db->netscape db dir index-filename
@defunx db->netscape db dir
@code{db->netscape} is just like @code{db->html-directory}, but calls
@code{browse-url-netscape} with the uri for the top page after the
pages are created.
@end defun

92
module/slib/dbrowse.scm
View file

@ -1,92 +0,0 @@
;;; "dbrowse.scm" relational-database-browser
; Copyright 1996, 1997, 1998 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'database-utilities)
(require 'printf)
(define browse:db #f)
(define (browse . args)
(define table-name #f)
(cond ((null? args))
((procedure? (car args))
(set! browse:db (car args))
(set! args (cdr args)))
((string? (car args))
(set! browse:db (open-database (car args)))
(set! args (cdr args))))
(cond ((null? args))
(else (set! table-name (car args))))
(let* ((open-table (browse:db 'open-table))
(catalog (and open-table (open-table '*catalog-data* #f))))
(cond ((not catalog)
(slib:error 'browse "could not open catalog"))
((not table-name)
(browse:display-dir '*catalog-data* catalog))
(else
(let ((table (open-table table-name #f)))
(cond (table (browse:display-table table-name table)
(table 'close-table))
(else (slib:error 'browse "could not open table"
table-name))))))))
(define (browse:display-dir table-name table)
(printf "%s Tables:\\n" table-name)
((table 'for-each-row)
(lambda (row) (printf "\\t%s\\n" (car row)))))
(define (browse:display-table table-name table)
(let* ((width 18)
(dw (string-append "%-" (number->string width)))
(dwp (string-append "%-" (number->string width) "."
(number->string (+ -1 width))))
(dwp-string (string-append dwp "s"))
(dwp-any (string-append dwp "a"))
(dw-integer (string-append dw "d"))
(underline (string-append (make-string (+ -1 width) #\=) " "))
(form ""))
(printf "Table: %s\\n" table-name)
(for-each (lambda (name) (printf dwp-string name))
(table 'column-names))
(newline)
(for-each (lambda (foreign) (printf dwp-any foreign))
(table 'column-foreigns))
(newline)
(for-each (lambda (domain) (printf dwp-string domain))
(table 'column-domains))
(newline)
(for-each (lambda (type)
(case type
((integer number uint base-id)
(set! form (string-append form dw-integer)))
((boolean domain expression atom)
(set! form (string-append form dwp-any)))
((string symbol)
(set! form (string-append form dwp-string)))
(else (slib:error 'browse:display-table "unknown type" type)))
(printf dwp-string type))
(table 'column-types))
(newline)
(set! form (string-append form "\\n"))
(for-each (lambda (domain) (printf underline))
(table 'column-domains))
(newline)
((table 'for-each-row)
(lambda (row)
(apply printf form row)))))

313
module/slib/dbutil.scm
View file

@ -1,313 +0,0 @@
;;; "dbutil.scm" relational-database-utilities
; Copyright 1994, 1995, 1997, 2000, 2001 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'relational-database)
(require 'common-list-functions)
(define (db:base-type path)
'alist-table) ; currently the only one.
(define (dbutil:wrap-command-interface rdb)
(and rdb
(let* ((rdms:commands ((rdb 'open-table) '*commands* #f))
(command:get
(and rdms:commands (rdms:commands 'get 'procedure))))
(and command:get
(letrec ((wdb (lambda (command)
(let ((com (command:get command)))
(cond (com ((slib:eval com) wdb))
(else (rdb command)))))))
(let ((init (wdb '*initialize*)))
(if (procedure? init) init wdb)))))))
(define (dbutil:open-database! path . arg)
(let ((type (if (null? arg) (db:base-type path) (car arg))))
(require type)
(dbutil:wrap-command-interface
(((make-relational-system (slib:eval type)) 'open-database)
path #t))))
(define (dbutil:open-database path . arg)
(let ((type (if (null? arg) (db:base-type path) (car arg))))
(require type)
(dbutil:wrap-command-interface
(((make-relational-system (slib:eval type)) 'open-database)
path #f))))
(define (dbutil:check-domain rdb)
(let* ((ro:domains ((rdb 'open-table) '*domains-data* #f))
(ro:get-dir (ro:domains 'get 'domain-integrity-rule))
(ro:for-tab (ro:domains 'get 'foreign-table)))
(lambda (domain)
(let ((fkname (ro:for-tab domain))
(dir (slib:eval (ro:get-dir domain))))
(if fkname (let* ((fktab ((rdb 'open-table) fkname #f))
(p? (fktab 'get 1)))
(if dir (lambda (e) (and (dir e) (p? e))) p?))
dir)))))
(define (dbutil:create-database path type)
(require type)
(let ((rdb (((make-relational-system (slib:eval type)) 'create-database)
path)))
(dbutil:define-tables
rdb
'(type
((name symbol))
()
((atom)
(symbol)
(string)
(number)
(money)
(date-time)
(boolean)
(foreign-key)
(expression)
(virtual)))
'(parameter-arity
((name symbol))
((predicate? expression)
(procedure expression))
((single (lambda (a) (and (pair? a) (null? (cdr a)))) car)
(optional
(lambda (lambda (a) (or (null? a) (and (pair? a) (null? (cdr a))))))
identity)
(boolean
(lambda (a) (or (null? a)
(and (pair? a) (null? (cdr a)) (boolean? (car a)))))
(lambda (a) (if (null? a) #f (car a))))
(nary (lambda (a) #t) identity)
(nary1 (lambda (a) (not (null? a))) identity))))
(for-each (((rdb 'open-table) '*domains-data* #t) 'row:insert)
'((parameter-list *catalog-data* #f symbol 1)
(parameter-name-translation *catalog-data* #f symbol 1)
(parameter-arity parameter-arity #f symbol 1)
(table *catalog-data* #f atom 1)))
(dbutil:define-tables
rdb
'(*parameter-columns*
*columns*
*columns*
((1 #t index #f uint)
(2 #f name #f symbol)
(3 #f arity #f parameter-arity)
(4 #f domain #f domain)
(5 #f defaulter #f expression)
(6 #f expander #f expression)
(7 #f documentation #f string)))
'(no-parameters
*parameter-columns*
*parameter-columns*
())
'(no-parameter-names
((name string))
((parameter-index uint))
())
'(add-domain-params
*parameter-columns*
*parameter-columns*
((1 domain-name single atom #f #f "new domain name")
(2 foreign-table optional table #f #f
"if present, domain-name must be existing key into this table")
(3 domain-integrity-rule optional expression #f #f
"returns #t if single argument is good")
(4 type-id single type #f #f "base type of new domain")
(5 type-param optional expression #f #f
"which (key) field of the foreign-table")
))
'(add-domain-pnames
((name string))
((parameter-index uint)) ;should be add-domain-params
(
("n" 1) ("name" 1)
("f" 2) ("foreign (key) table" 2)
("r" 3) ("domain integrity rule" 3)
("t" 4) ("type" 4)
("p" 5) ("type param" 5)
))
'(del-domain-params
*parameter-columns*
*parameter-columns*
((1 domain-name single domain #f #f "domain name")))
'(del-domain-pnames
((name string))
((parameter-index uint)) ;should be del-domain-params
(("n" 1) ("name" 1)))
'(*commands*
((name symbol))
((parameters parameter-list)
(parameter-names parameter-name-translation)
(procedure expression)
(documentation string))
((domain-checker
no-parameters
no-parameter-names
dbutil:check-domain
"return procedure to check given domain name")
(add-domain
add-domain-params
add-domain-pnames
(lambda (rdb)
(((rdb 'open-table) '*domains-data* #t) 'row:update))
"add a new domain")
(delete-domain
del-domain-params
del-domain-pnames
(lambda (rdb)
(((rdb 'open-table) '*domains-data* #t) 'row:remove))
"delete a domain"))))
(let* ((tab ((rdb 'open-table) '*domains-data* #t))
(row ((tab 'row:retrieve) 'type)))
(set-car! (cdr row) 'type)
((tab 'row:update) row))
(dbutil:wrap-command-interface rdb)))
(define (make-defaulter arity type)
`(lambda (pl)
',(case arity
((optional nary) '())
((boolean) #f)
((single nary1)
(case type
((string) '(""))
((symbol) '(nil))
(else '(#f))))
(else (slib:error 'make-defaulter 'unknown 'arity arity)))))
(define (get-foreign-choices tab)
(define dlst ((tab 'get* 1)))
(do ((dlst dlst (cdr dlst))
(vlst (if (memq 'visible-name (tab 'column-names))
((tab 'get* 'visible-name))
dlst)
(cdr vlst))
(out '() (if (member (car dlst) (cdr dlst))
out
(cons (list (car dlst) (car vlst)) out))))
((null? dlst) out)))
(define (make-command-server rdb command-table)
(let* ((comtab ((rdb 'open-table) command-table #f))
(names (comtab 'column-names))
(row-ref (lambda (row name) (list-ref row (position name names))))
(comgetrow (comtab 'row:retrieve)))
(lambda (comname command-callback)
(cond ((not comname) (set! comname '*default*)))
(cond ((not (comgetrow comname))
(slib:error 'command 'not 'known: comname)))
(let* ((command:row (comgetrow comname))
(parameter-table
((rdb 'open-table) (row-ref command:row 'parameters) #f))
(parameter-names
((rdb 'open-table) (row-ref command:row 'parameter-names) #f))
(comval ((slib:eval (row-ref command:row 'procedure)) rdb))
(options ((parameter-table 'get* 'name)))
(positions ((parameter-table 'get* 'index)))
(arities ((parameter-table 'get* 'arity)))
(defaulters (map slib:eval ((parameter-table 'get* 'defaulter))))
(domains ((parameter-table 'get* 'domain)))
(types (map (((rdb 'open-table) '*domains-data* #f) 'get 'type-id)
domains))
(dirs (map (rdb 'domain-checker) domains))
(aliases
(map list ((parameter-names 'get* 'name))
(map (parameter-table 'get 'name)
((parameter-names 'get* 'parameter-index))))))
(command-callback comname comval options positions
arities types defaulters dirs aliases)))))
(define (dbutil:define-tables rdb . spec-list)
(define new-tables '())
(define dom:typ (((rdb 'open-table) '*domains-data* #f) 'get 4))
(define create-table (rdb 'create-table))
(define open-table (rdb 'open-table))
(define table-exists? (rdb 'table-exists?))
(define (check-domain dname)
(cond ((dom:typ dname))
((member dname new-tables)
(let* ((ftab (open-table
(string->symbol
(string-append "desc:" (symbol->string dname)))
#f)))
((((rdb 'open-table) '*domains-data* #t) 'row:insert)
(list dname dname #f
(dom:typ ((ftab 'get 'domain-name) 1)) 1))))))
(define (define-table name prikeys slots data)
(cond
((table-exists? name)
(let* ((tab (open-table name #t))
(row:update (tab 'row:update)))
(for-each row:update data)))
((and (symbol? prikeys) (eq? prikeys slots))
(cond ((not (table-exists? slots))
(slib:error "Table doesn't exist:" slots)))
(set! new-tables (cons name new-tables))
(let* ((tab (create-table name slots))
(row:insert (tab 'row:insert)))
(for-each row:insert data)
((tab 'close-table))))
(else
(let* ((descname
(string->symbol (string-append "desc:" (symbol->string name))))
(tab (create-table descname))
(row:insert (tab 'row:insert))
(j 0))
(set! new-tables (cons name new-tables))
(for-each (lambda (des)
(set! j (+ 1 j))
(check-domain (cadr des))
(row:insert (list j #t (car des)
(if (null? (cddr des)) #f (caddr des))
(cadr des))))
prikeys)
(for-each (lambda (des)
(set! j (+ 1 j))
(check-domain (cadr des))
(row:insert (list j #f (car des)
(if (null? (cddr des)) #f (caddr des))
(cadr des))))
slots)
((tab 'close-table))
(set! tab (create-table name descname))
(set! row:insert (tab 'row:insert))
(for-each row:insert data)
((tab 'close-table))))))
(for-each (lambda (spec) (apply define-table spec)) spec-list))
(define (dbutil:list-table-definition rdb table-name)
(cond (((rdb 'table-exists?) table-name)
(let* ((table ((rdb 'open-table) table-name #f))
(prilimit (table 'primary-limit))
(coldefs (map list
(table 'column-names)
(table 'column-domains))))
(list table-name
(butnthcdr prilimit coldefs)
(nthcdr prilimit coldefs)
((table 'row:retrieve*)))))
(else #f)))
(define create-database dbutil:create-database)
(define open-database! dbutil:open-database!)
(define open-database dbutil:open-database)
(define define-tables dbutil:define-tables)
(define list-table-definition dbutil:list-table-definition)

98
module/slib/debug.scm
View file

@ -1,98 +0,0 @@
;;;; "debug.scm" Utility functions for debugging in Scheme.
;;; Copyright (C) 1991, 1992, 1993, 1995, 1999 Aubrey Jaffer.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'trace)
(require 'break)
(require 'line-i/o)
(define (for-each-top-level-definition-in-file file proc)
(call-with-input-file
file
(lambda (port)
(letrec
((walk
(lambda (exp)
(cond
((not (and (pair? exp) (list? exp))))
((not (symbol? (car exp))))
(else
(case (car exp)
((begin) (for-each walk (cdr exp)))
((cond) (for-each
(lambda (exp)
(for-each walk
(if (list? (car exp)) exp (cdr exp))))
(cdr exp)))
((if) (for-each
walk (if (list? (cadr exp)) (cdr exp) (cddr exp))))
((defmacro define-syntax) (proc exp))
((define) (proc exp))))))))
(if (eqv? #\# (peek-char port))
(read-line port)) ;remove `magic-number'
(do ((form (read port) (read port)))
((eof-object? form))
(walk form))))))
(define (for-each-top-level-defined-procedure-symbol-in-file file proc)
(letrec ((get-defined-symbol
(lambda (form)
(if (pair? form)
(get-defined-symbol (car form))
form))))
(for-each-top-level-definition-in-file
file
(lambda (form)
(and (eqv? 'define (car form))
(let ((sym (get-defined-symbol (cadr form))))
(cond ((procedure? (slib:eval sym))
(proc sym)))))))))
(define (trace-all file . ...)
(for-each
(lambda (file)
(for-each-top-level-defined-procedure-symbol-in-file
file
(lambda (sym)
(slib:eval `(set! ,sym (trace:trace-procedure 'trace ,sym ',sym))))))
(cons file ...)))
(define (track-all file . ...)
(for-each
(lambda (file)
(for-each-top-level-defined-procedure-symbol-in-file
file
(lambda (sym)
(slib:eval `(set! ,sym (trace:trace-procedure 'track ,sym ',sym))))))
(cons file ...)))
(define (stack-all file . ...)
(for-each
(lambda (file)
(for-each-top-level-defined-procedure-symbol-in-file
file
(lambda (sym)
(slib:eval `(set! ,sym (trace:trace-procedure 'stack ,sym ',sym))))))
(cons file ...)))
(define (break-all file . ...)
(for-each
(lambda (file)
(for-each-top-level-defined-procedure-symbol-in-file
file
(lambda (sym)
(slib:eval `(set! ,sym (break:breakf ,sym ',sym))))))
(cons file ...)))

100
module/slib/defmacex.scm
View file

@ -1,100 +0,0 @@
;;;"defmacex.scm" defmacro:expand* for any Scheme dialect.
;;;Copyright 1993-1994 Dorai Sitaram and Aubrey Jaffer.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;;;expand thoroughly, not just topmost expression. While expanding
;;;subexpressions, the primitive forms quote, lambda, set!, let/*/rec,
;;;cond, case, do, quasiquote: need to be destructured properly. (if,
;;;and, or, begin: don't need special treatment.)
(define (defmacro:iqq e depth)
(letrec
((map1 (lambda (f x)
(if (pair? x) (cons (f (car x)) (map1 f (cdr x)))
x)))
(iqq (lambda (e depth)
(if (pair? e)
(case (car e)
((quasiquote) (list (car e) (iqq (cadr e) (+ 1 depth))))
((unquote unquote-splicing)
(list (car e) (if (= 1 depth)
(defmacro:expand* (cadr e))
(iqq (cadr e) (+ -1 depth)))))
(else (map1 (lambda (e) (iqq e depth)) e)))
e))))
(iqq e depth)))
(define (defmacro:expand* e)
(if (pair? e)
(let* ((c (macroexpand-1 e)))
(if (not (eq? e c))
(defmacro:expand* c)
(case (car e)
((quote) e)
((quasiquote) (defmacro:iqq e 0))
((lambda define set!)
(cons (car e) (cons (cadr e) (map defmacro:expand* (cddr e)))))
((let)
(let ((b (cadr e)))
(if (symbol? b) ;named let
`(let ,b
,(map (lambda (vv)
`(,(car vv)
,(defmacro:expand* (cadr vv))))
(caddr e))
,@(map defmacro:expand*
(cdddr e)))
`(let
,(map (lambda (vv)
`(,(car vv)
,(defmacro:expand* (cadr vv))))
b)
,@(map defmacro:expand*
(cddr e))))))
((let* letrec)
`(,(car e) ,(map (lambda (vv)
`(,(car vv)
,(defmacro:expand* (cadr vv))))
(cadr e))
,@(map defmacro:expand* (cddr e))))
((cond)
`(cond
,@(map (lambda (c)
(map defmacro:expand* c))
(cdr e))))
((case)
`(case ,(defmacro:expand* (cadr e))
,@(map (lambda (c)
`(,(car c)
,@(map defmacro:expand* (cdr c))))
(cddr e))))
((do)
`(do ,(map
(lambda (initsteps)
`(,(car initsteps)
,@(map defmacro:expand*
(cdr initsteps))))
(cadr e))
,(map defmacro:expand* (caddr e))
,@(map defmacro:expand* (cdddr e))))
((defmacro)
(cons (car e)
(cons (cadr e)
(cons (caddr e) (map defmacro:expand* (cdddr e))))))
(else (map defmacro:expand* e)))))
e))

14
module/slib/determ.scm
View file

@ -1,14 +0,0 @@
;"determ.scm" Determinant
(define (determinant m)
(define (butnth n lst)
(if (zero? n) (cdr lst) (cons (car lst) (butnth (+ -1 n) (cdr lst)))))
(define (minor m i j)
(map (lambda (x) (butnth j x)) (butnth i m)))
(define (cofactor m i j)
(* (if (odd? (+ i j)) -1 1) (determinant (minor m i j))))
(define n (length m))
(if (eqv? 1 n) (caar m)
(do ((j (+ -1 n) (+ -1 j))
(ans 0 (+ ans (* (list-ref (car m) j) (cofactor m 0 j)))))
((negative? j) ans))))

80
module/slib/dwindtst.scm
View file

@ -1,80 +0,0 @@
;;;; "dwindtst.scm", routines for characterizing dynamic-wind.
;Copyright (C) 1992 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'dynamic-wind)
(define (dwtest n)
(define cont #f)
(display "testing escape from thunk") (display n) (newline)
(display "visiting:") (newline)
(call-with-current-continuation
(lambda (x) (set! cont x)))
(if n
(dynamic-wind
(lambda ()
(display "thunk1") (newline)
(if (eqv? n 1) (let ((ntmp n))
(set! n #f)
(cont ntmp))))
(lambda ()
(display "thunk2") (newline)
(if (eqv? n 2) (let ((ntmp n))
(set! n #f)
(cont ntmp))))
(lambda ()
(display "thunk3") (newline)
(if (eqv? n 3) (let ((ntmp n))
(set! n #f)
(cont ntmp)))))))
(define (dwctest n)
(define cont #f)
(define ccont #f)
(display "creating continuation thunk") (newline)
(display "visiting:") (newline)
(call-with-current-continuation
(lambda (x) (set! cont x)))
(if n (set! n (- n)))
(if n
(dynamic-wind
(lambda ()
(display "thunk1") (newline)
(if (eqv? n 1) (let ((ntmp n))
(set! n #f)
(cont ntmp))))
(lambda ()
(call-with-current-continuation
(lambda (x) (set! ccont x)))
(display "thunk2") (newline)
(if (eqv? n 2) (let ((ntmp n))
(set! n #f)
(cont ntmp))))
(lambda ()
(display "thunk3") (newline)
(if (eqv? n 3) (let ((ntmp n))
(set! n #f)
(cont ntmp))))))
(cond
(n
(set! n (- n))
(display "testing escape from continuation thunk") (display n) (newline)
(display "visiting:") (newline)
(ccont #f))))
(dwtest 1) (dwtest 2) (dwtest 3)
(dwctest 1) (dwctest 2) (dwctest 3)

75
module/slib/dynamic.scm
View file

@ -1,75 +0,0 @@
; "dynamic.scm", DYNAMIC data type for Scheme
; Copyright 1992 Andrew Wilcox.
;
; You may freely copy, redistribute and modify this package.
(require 'record)
(require 'dynamic-wind)
(define dynamic-environment-rtd
(make-record-type "dynamic environment" '(dynamic value parent)))
(define make-dynamic-environment
(record-constructor dynamic-environment-rtd))
(define dynamic-environment:dynamic
(record-accessor dynamic-environment-rtd 'dynamic))
(define dynamic-environment:value
(record-accessor dynamic-environment-rtd 'value))
(define dynamic-environment:set-value!
(record-modifier dynamic-environment-rtd 'value))
(define dynamic-environment:parent
(record-accessor dynamic-environment-rtd 'parent))
(define *current-dynamic-environment* #f)
(define (extend-current-dynamic-environment dynamic obj)
(set! *current-dynamic-environment*
(make-dynamic-environment dynamic obj
*current-dynamic-environment*)))
(define dynamic-rtd (make-record-type "dynamic" '()))
(define make-dynamic
(let ((dynamic-constructor (record-constructor dynamic-rtd)))
(lambda (obj)
(let ((dynamic (dynamic-constructor)))
(extend-current-dynamic-environment dynamic obj)
dynamic))))
(define dynamic? (record-predicate dynamic-rtd))
(define (guarantee-dynamic dynamic)
(or (dynamic? dynamic)
(slib:error "Not a dynamic" dynamic)))
(define dynamic:errmsg
"No value defined for this dynamic in the current dynamic environment")
(define (dynamic-ref dynamic)
(guarantee-dynamic dynamic)
(let loop ((env *current-dynamic-environment*))
(cond ((not env)
(slib:error dynamic:errmsg dynamic))
((eq? (dynamic-environment:dynamic env) dynamic)
(dynamic-environment:value env))
(else
(loop (dynamic-environment:parent env))))))
(define (dynamic-set! dynamic obj)
(guarantee-dynamic dynamic)
(let loop ((env *current-dynamic-environment*))
(cond ((not env)
(slib:error dynamic:errmsg dynamic))
((eq? (dynamic-environment:dynamic env) dynamic)
(dynamic-environment:set-value! env obj))
(else
(loop (dynamic-environment:parent env))))))
(define (call-with-dynamic-binding dynamic obj thunk)
(let ((out-thunk-env #f)
(in-thunk-env (make-dynamic-environment
dynamic obj
*current-dynamic-environment*)))
(dynamic-wind (lambda ()
(set! out-thunk-env *current-dynamic-environment*)
(set! *current-dynamic-environment* in-thunk-env))
thunk
(lambda ()
(set! in-thunk-env *current-dynamic-environment*)
(set! *current-dynamic-environment* out-thunk-env)))))

74
module/slib/dynwind.scm
View file

@ -1,74 +0,0 @@
; "dynwind.scm", wind-unwind-protect for Scheme
; Copyright (c) 1992, 1993 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;This facility is a generalization of Common Lisp `unwind-protect',
;designed to take into account the fact that continuations produced by
;CALL-WITH-CURRENT-CONTINUATION may be reentered.
; (dynamic-wind <thunk1> <thunk2> <thunk3>) procedure
;The arguments <thunk1>, <thunk2>, and <thunk3> must all be procedures
;of no arguments (thunks).
;DYNAMIC-WIND calls <thunk1>, <thunk2>, and then <thunk3>. The value
;returned by <thunk2> is returned as the result of DYNAMIC-WIND.
;<thunk3> is also called just before control leaves the dynamic
;context of <thunk2> by calling a continuation created outside that
;context. Furthermore, <thunk1> is called before reentering the
;dynamic context of <thunk2> by calling a continuation created inside
;that context. (Control is inside the context of <thunk2> if <thunk2>
;is on the current return stack).
;;;WARNING: This code has no provision for dealing with errors or
;;;interrupts. If an error or interrupt occurs while using
;;;dynamic-wind, the dynamic environment will be that in effect at the
;;;time of the error or interrupt.
(define dynamic:winds '())
(define (dynamic-wind <thunk1> <thunk2> <thunk3>)
(<thunk1>)
(set! dynamic:winds (cons (cons <thunk1> <thunk3>) dynamic:winds))
(let ((ans (<thunk2>)))
(set! dynamic:winds (cdr dynamic:winds))
(<thunk3>)
ans))
(define call-with-current-continuation
(let ((oldcc call-with-current-continuation))
(lambda (proc)
(let ((winds dynamic:winds))
(oldcc
(lambda (cont)
(proc (lambda (c2)
(dynamic:do-winds winds (- (length dynamic:winds)
(length winds)))
(cont c2)))))))))
(define (dynamic:do-winds to delta)
(cond ((eq? dynamic:winds to))
((negative? delta)
(dynamic:do-winds (cdr to) (+ 1 delta))
((caar to))
(set! dynamic:winds to))
(else
(let ((from (cdar dynamic:winds)))
(set! dynamic:winds (cdr dynamic:winds))
(from)
(dynamic:do-winds to (+ -1 delta))))))

303
module/slib/elk.init
View file

@ -1,303 +0,0 @@
;;;"elk.init" Initialisation file for SLIB for ELK 2.1 -*- Scheme -*-
;;; Author: Aubrey Jaffer
;;;
;;; This code is in the public domain.
; No guarantees are given about the correctness of any of the
; choices made below. Only enough work was done to get the require
; mechanism to work correctly.
;
; Stephen J. Bevan <bevan@cs.man.ac.uk> 19920912 modified by Mike
; Sperber to work correctly with statically-linked Elk and slib1d. Be
; sure to change the library vicinities according to your local
; configuration. If you're running MS-DOS (which is possible since
; 2.1), you probably have to change this file to make everything work
; correctly.
;;; (software-type) should be set to the generic operating system type.
;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
(define (software-type) 'UNIX)
;;; (scheme-implementation-type) should return the name of the scheme
;;; implementation loading this file.
(define (scheme-implementation-type) 'Elk)
;;; (scheme-implementation-home-page) should return a (string) URI
;;; (Uniform Resource Identifier) for this scheme implementation's home
;;; page; or false if there isn't one.
(define (scheme-implementation-home-page)
"http://www.informatik.uni-bremen.de/~net/elk/")
;;; (scheme-implementation-version) should return a string describing
;;; the version the scheme implementation loading this file.
(define (scheme-implementation-version) "3.0")
;;; (implementation-vicinity) should be defined to be the pathname of
;;; the directory where any auxillary files to your Scheme
;;; implementation reside.
(define (implementation-vicinity)
(case (software-type)
((UNIX) "/usr/local/lib/elk-2.1/scm/")
((VMS) "scheme$src:")
((MS-DOS) "C:\\scheme\\")))
;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
(require 'unix)
(define getenv unix-getenv)
(define system unix-system)
(define library-vicinity
(let ((library-path
(or (getenv "SCHEME_LIBRARY_PATH")
;; Uses this path if SCHEME_LIBRARY_PATH is not defined.
(case (software-type)
((UNIX) "/usr/local/lib/slib/")
((VMS) "lib$scheme:")
((MS-DOS) "C:\\SLIB\\")
(else "")))))
(lambda () library-path)))
;;; (home-vicinity) should return the vicinity of the user's HOME
;;; directory, the directory which typically contains files which
;;; customize a computer environment for a user.
(define home-vicinity
(let ((home-path (getenv "HOME")))
(lambda () home-path)))
;;; *features* should be set to a list of symbols describing features
;;; of this implementation. Suggestions for features are:
(define *features*
'(
source ;can load scheme source files
;(slib:load-source "filename")
compiled ;can load compiled files
;(slib:load-compiled "filename")
rev4-report
ieee-p1178
sicp
rev4-optional-procedures
rev3-procedures
rev2-procedures
multiarg/and-
multiarg-apply
delay
transcript
full-continuation
sort
format
system
getenv
program-arguments
string-port
))
;------------
(define program-arguments
(lambda ()
(cons "undefined-program-name" (command-line-args))))
; EXACT? appears to always return #f which isn't very useful.
; Approximating it with INTEGER? at least means that some
; of the code in the library will work correctly
(define exact? integer?) ; WARNING: redefining EXACT?
(define (inexact? arg)
(not (exact? arg)))
;;; (TMPNAM) makes a temporary file name.
(define tmpnam
(let ((cntr 100))
(lambda () (set! cntr (+ 1 cntr))
(let ((tmp (string-append "slib_" (number->string cntr))))
(if (file-exists? tmp) (tmpnam) tmp)))))
; Pull in GENTENV and SYSTEM
;;; (FILE-EXISTS? <string>) already here.
;;; (DELETE-FILE <string>)
(define (delete-file f) (system (string-append "rm " f)))
;------------
;;; (OUTPUT-PORT-WIDTH <port>)
(define (output-port-width . arg) 79)
;;; (OUTPUT-PORT-HEIGHT <port>)
(define (output-port-height . arg) 24)
;;; (CURRENT-ERROR-PORT)
;;; is already defined in Elk 2.1
;;; FORCE-OUTPUT flushes any pending output on optional arg output port
;;; use this definition if your system doesn't have such a procedure.
(define force-output flush-output-port)
;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
;;; port versions of CALL-WITH-*PUT-FILE.
(define (call-with-output-string f)
(let ((outsp (open-output-string)))
(f outsp)
(let ((s (get-output-string outsp)))
(close-output-port outsp)
s)))
(define (call-with-input-string s f)
(let* ((insp (open-input-string s))
(res (f insp)))
(close-input-port insp)
res))
;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
;;; be returned by CHAR->INTEGER.
(define char-code-limit 256)
;;; MOST-POSITIVE-FIXNUM is used in modular.scm
(define most-positive-fixnum 8388608) ; 23 bit integers ?
;;; Return argument
(define (identity x) x)
;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
(define slib:eval eval)
(define *macros* '())
(define (defmacro? m) (and (assq m *macros*) #t))
(define-macro (defmacro key pattern . body)
`(begin
(define-macro ,(cons key pattern) ,@body)
(set! *macros* (cons (cons ',key (lambda ,pattern ,@body)) *macros*))))
(define (macroexpand-1 e)
(if (pair? e) (let ((a (car e)))
(cond ((symbol? a) (set! a (assq a *macros*))
(if a (apply (cdr a) (cdr e)) e))
(else e)))
e))
(define (macroexpand e)
(if (pair? e) (let ((a (car e)))
(cond ((symbol? a)
(set! a (assq a *macros*))
(if a (macroexpand (apply (cdr a) (cdr e))) e))
(else e)))
e))
(define gentemp
(let ((*gensym-counter* -1))
(lambda ()
(set! *gensym-counter* (+ *gensym-counter* 1))
(string->symbol
(string-append "slib:G" (number->string *gensym-counter*))))))
(define defmacro:eval slib:eval)
(define defmacro:load load)
;;; If your implementation provides R4RS macros:
;(define macro:eval slib:eval)
;(define macro:load load)
(define (slib:eval-load <pathname> evl)
(if (not (file-exists? <pathname>))
(set! <pathname> (string-append <pathname> (scheme-file-suffix))))
(call-with-input-file <pathname>
(lambda (port)
(let ((old-load-pathname *load-pathname*))
(set! *load-pathname* <pathname>)
(do ((o (read port) (read port)))
((eof-object? o))
(evl o))
(set! *load-pathname* old-load-pathname)))))
(define slib:warn
(lambda args
(let ((cep (current-error-port)))
(if (provided? 'trace) (print-call-stack cep))
(display "Warn: " cep)
(for-each (lambda (x) (display x cep)) args))))
;;; define an error procedure for the library
(define slib:error
(lambda args
(define (slib:error . args)
(if (provided? 'trace) (print-call-stack (current-error-port)))
(apply s48-error args))
(let ((port (open-output-string))
(err (if (and (pair? args) (symbol? (car args)))
(car args) 'slib))
(args (if (and (pair? args) (symbol? (car args)))
(cdr args) args)))
(for-each (lambda (x) (display x port) (display " " port)) args)
(let ((str (get-output-string port)))
(close-output-port port)
(error err str)))))
;;; define these as appropriate for your system.
(define slib:tab #\tab)
(define slib:form-feed #\formfeed)
;;; Define these if your implementation's syntax can support it and if
;;; they are not already defined.
;(define (1+ n) (+ n 1))
;(define (-1+ n) (+ n -1))
;(define 1- -1+)
(define in-vicinity string-append)
;;; Define SLIB:EXIT to be the implementation procedure to exit or
;;; return if exitting not supported.
(define slib:exit
(lambda args
(exit (cond ((null? args) 0)
((eqv? #t (car args)) 0)
((and (number? (car args)) (integer? (car args))) (car args))
(else 1)))))
;;; Here for backward compatability
(define scheme-file-suffix
(let ((suffix (case (software-type)
((NOSVE) "_scm")
(else ".scm"))))
(lambda () suffix)))
;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
;;; suffix all the module files in SLIB have. See feature 'SOURCE.
; Modify the already modified _load_ so that it copes with
; environments correctly. The change involves using
; _(global-environment)_ if none is explicitly specified.
; If this is not done, definitions in files loaded by other files will
; not be loaded in the correct environment.
(define slib:load-source
(let ((primitive-load load))
(lambda (<pathname> . rest)
(let ((env (if (null? rest) (list (global-environment)) rest)))
(apply primitive-load <pathname> env)))))
;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
;;; by compiling "foo.scm" if this implementation can compile files.
;;; See feature 'COMPILED.
(define slib:load-compiled
(let ((primitive-load load))
(lambda (<pathname> . rest)
(apply primitive-load (string->symbol (string-append name ".o")) rest))))
;;; At this point SLIB:LOAD must be able to load SLIB files.
(define slib:load slib:load-source) ;WARNING: redefining LOAD
(slib:load (in-vicinity (library-vicinity) "require"))

146
module/slib/eval.scm
View file

@ -1,146 +0,0 @@
; "eval.scm", Eval proposed by Guillermo (Bill) J. Rozas for R5RS.
; Copyright (c) 1997, 1998 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;;; Rather than worry over the status of all the optional procedures,
;;; just require as many as possible.
(require 'rev4-optional-procedures)
(require 'dynamic-wind)
(require 'transcript)
(require 'with-file)
(require 'values)
(define eval:make-environment
(let ((eval-1 slib:eval))
(lambda (identifiers)
((lambda args args)
#f
identifiers
(lambda (expression)
(eval-1 `(lambda ,identifiers ,expression)))))))
(define eval:capture-environment!
(let ((set-car! set-car!)
(eval-1 slib:eval)
(apply apply))
(lambda (environment)
(set-car!
environment
(apply (lambda (environment-values identifiers procedure)
(eval-1 `((lambda args args) ,@identifiers)))
environment)))))
(define interaction-environment
(let ((env (eval:make-environment '())))
(lambda () env)))
;;; null-environment is set by first call to scheme-report-environment at
;;; the end of this file.
(define null-environment #f)
(define scheme-report-environment
(let* ((r4rs-procedures
(append
(cond ((provided? 'inexact)
(append
'(acos angle asin atan cos exact->inexact exp
expt imag-part inexact->exact log magnitude
make-polar make-rectangular real-part sin
sqrt tan)
(if (let ((n (string->number "1/3")))
(and (number? n) (exact? n)))
'(denominator numerator)
'())))
(else '()))
(cond ((provided? 'rationalize)
'(rationalize))
(else '()))
(cond ((provided? 'delay)
'(force))
(else '()))
(cond ((provided? 'char-ready?)
'(char-ready?))
(else '()))
'(* + - / < <= = > >= abs append apply assoc assq assv boolean?
caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar
caddar cadddr caddr cadr call-with-current-continuation
call-with-input-file call-with-output-file car cdaaar cdaadr
cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr
cdddr cddr cdr ceiling char->integer char-alphabetic? char-ci<=?
char-ci<? char-ci=? char-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)

245
module/slib/factor.scm
View file

@ -1,245 +0,0 @@
;;;; "factor.scm" factorization, prime test and generation
;;; Copyright (C) 1991, 1992, 1993, 1998 Aubrey Jaffer.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'common-list-functions)
(require 'modular)
(require 'random)
(require 'byte)
;;@body
;;@0 is the random-state (@pxref{Random Numbers}) used by these
;;procedures. If you call these procedures from more than one thread
;;(or from interrupt), @code{random} may complain about reentrant
;;calls.
(define prime:prngs
(make-random-state "repeatable seed for primes"))
;;@emph{Note:} The prime test and generation procedures implement (or
;;use) the Solovay-Strassen primality test. See
;;
;;@itemize @bullet
;;@item Robert Solovay and Volker Strassen,
;;@cite{A Fast Monte-Carlo Test for Primality},
;;SIAM Journal on Computing, 1977, pp 84-85.
;;@end itemize
;;; Solovay-Strassen Prime Test
;;; if n is prime, then J(a,n) is congruent mod n to a**((n-1)/2)
;;; (modulo p 16) is because we care only about the low order bits.
;;; The odd? tests are inline of (expt -1 ...)
(define (prime:jacobi-symbol p q)
(cond ((zero? p) 0)
((= 1 p) 1)
((odd? p)
(if (odd? (quotient (* (- (modulo p 16) 1) (- q 1)) 4))
(- (prime:jacobi-symbol (modulo q p) p))
(prime:jacobi-symbol (modulo q p) p)))
(else
(let ((qq (modulo q 16)))
(if (odd? (quotient (- (* qq qq) 1) 8))
(- (prime:jacobi-symbol (quotient p 2) q))
(prime:jacobi-symbol (quotient p 2) q))))))
;;@args p q
;;Returns the value (+1, @minus{}1, or 0) of the Jacobi-Symbol of
;;exact non-negative integer @1 and exact positive odd integer @2.
(define jacobi-symbol prime:jacobi-symbol)
;;@body
;;@0 the maxinum number of iterations of Solovay-Strassen that will
;;be done to test a number for primality.
(define prime:trials 30)
;;; checks if n is prime. Returns #f if not prime. #t if (probably) prime.
;;; probability of a mistake = (expt 2 (- prime:trials))
;;; choosing prime:trials=30 should be enough
(define (Solovay-Strassen-prime? n)
(do ((i prime:trials (- i 1))
(a (+ 2 (random (- n 2) prime:prngs))
(+ 2 (random (- n 2) prime:prngs))))
((not (and (positive? i)
(= (gcd a n) 1)
(= (modulo (prime:jacobi-symbol a n) n)
(modular:expt n a (quotient (- n 1) 2)))))
(if (positive? i) #f #t))))
;;; prime:products are products of small primes.
(define (primes-gcd? n comps)
(comlist:notevery (lambda (prd) (= 1 (gcd n prd))) comps))
(define prime:prime-sqr 121)
(define prime:products '(105))
(define prime:sieve (bytes 0 0 1 1 0 1 0 1 0 0 0))
(letrec ((lp (lambda (comp comps primes nexp)
(cond ((< comp (quotient most-positive-fixnum nexp))
(let ((ncomp (* nexp comp)))
(lp ncomp comps
(cons nexp primes)
(next-prime nexp (cons ncomp comps)))))
((< (quotient comp nexp) (* nexp nexp))
(set! prime:prime-sqr (* nexp nexp))
(set! prime:sieve (make-bytes nexp 0))
(for-each (lambda (prime)
(byte-set! prime:sieve prime 1))
primes)
(set! prime:products (reverse (cons comp comps))))
(else
(lp nexp (cons comp comps)
(cons nexp primes)
(next-prime nexp (cons comp comps)))))))
(next-prime (lambda (nexp comps)
(set! comps (reverse comps))
(do ((nexp (+ 2 nexp) (+ 2 nexp)))
((not (primes-gcd? nexp comps)) nexp)))))
(lp 3 '() '(2 3) 5))
(define (prime:prime? n)
(set! n (abs n))
(cond ((< n (bytes-length prime:sieve)) (positive? (byte-ref prime:sieve n)))
((even? n) #f)
((primes-gcd? n prime:products) #f)
((< n prime:prime-sqr) #t)
(else (Solovay-Strassen-prime? n))))
;;@args n
;;Returns @code{#f} if @1 is composite; @code{#t} if @1 is prime.
;;There is a slight chance @code{(expt 2 (- prime:trials))} that a
;;composite will return @code{#t}.
(define prime? prime:prime?)
(define probably-prime? prime:prime?) ;legacy
(define (prime:prime< start)
(do ((nbr (+ -1 start) (+ -1 nbr)))
((or (negative? nbr) (prime:prime? nbr))
(if (negative? nbr) #f nbr))))
(define (prime:primes< start count)
(do ((cnt (+ -2 count) (+ -1 cnt))
(lst '() (cons prime lst))
(prime (prime:prime< start) (prime:prime< prime)))
((or (not prime) (negative? cnt))
(if prime (cons prime lst) lst))))
;;@args start count
;;Returns a list of the first @2 prime numbers less than
;;@1. If there are fewer than @var{count} prime numbers
;;less than @var{start}, then the returned list will have fewer than
;;@var{start} elements.
(define primes< prime:primes<)
(define (prime:prime> start)
(do ((nbr (+ 1 start) (+ 1 nbr)))
((prime:prime? nbr) nbr)))
(define (prime:primes> start count)
(set! start (max 0 start))
(do ((cnt (+ -2 count) (+ -1 cnt))
(lst '() (cons prime lst))
(prime (prime:prime> start) (prime:prime> prime)))
((negative? cnt)
(reverse (cons prime lst)))))
;;@args start count
;;Returns a list of the first @2 prime numbers greater than @1.
(define primes> prime:primes>)
;;;;Lankinen's recursive factoring algorithm:
;From: ld231782@longs.LANCE.ColoState.EDU (L. Detweiler)
; | undefined if n<0,
; | (u,v) if n=0,
;Let f(u,v,b,n) := | [otherwise]
; | f(u+b,v,2b,(n-v)/2) or f(u,v+b,2b,(n-u)/2) if n odd
; | f(u,v,2b,n/2) or f(u+b,v+b,2b,(n-u-v-b)/2) if n even
;Thm: f(1,1,2,(m-1)/2) = (p,q) iff pq=m for odd m.
;It may be illuminating to consider the relation of the Lankinen function in
;a `computational hierarchy' of other factoring functions.* Assumptions are
;made herein on the basis of conventional digital (binary) computers. Also,
;complexity orders are given for the worst case scenarios (when the number to
;be factored is prime). However, all algorithms would probably perform to
;the same constant multiple of the given orders for complete composite
;factorizations.
;Thm: Eratosthenes' Sieve is very roughtly O(ln(n)/n) in time and
; O(n*log2(n)) in space.
;Pf: It works with all prime factors less than n (about ln(n)/n by the prime
; number thm), requiring an array of size proportional to n with log2(n)
; space for each entry.
;Thm: `Odd factors' is O((sqrt(n)/2)*log2(n)) in time and O(log2(n)) in
; space.
;Pf: It tests all odd factors less than the square root of n (about
; sqrt(n)/2), with log2(n) time for each division. It requires only
; log2(n) space for the number and divisors.
;Thm: Lankinen's algorithm is O(sqrt(n)/2) in time and O((sqrt(n)/2)*log2(n))
; in space.
;Pf: The algorithm is easily modified to seach only for factors p<q for all
; pq=m. Then the recursive call tree forms a geometric progression
; starting at one, and doubling until reaching sqrt(n)/2, or a length of
; log2(sqrt(n)/2). From the formula for a geometric progression, there is
; a total of about 2^log2(sqrt(n)/2) = sqrt(n)/2 calls. Assuming that
; addition, subtraction, comparison, and multiplication/division by two
; occur in constant time, this implies O(sqrt(n)/2) time and a
; O((sqrt(n)/2)*log2(n)) requirement of stack space.
(define (prime:f u v b n)
(if (<= n 0)
(cond ((negative? n) #f)
((= u 1) #f)
((= v 1) #f)
; Do both of these factors need to be factored?
(else (append (or (prime:f 1 1 2 (quotient (- u 1) 2))
(list u))
(or (prime:f 1 1 2 (quotient (- v 1) 2))
(list v)))))
(if (even? n)
(or (prime:f u v (+ b b) (quotient n 2))
(prime:f (+ u b) (+ v b) (+ b b) (quotient (- n (+ u v b)) 2)))
(or (prime:f (+ u b) v (+ b b) (quotient (- n v) 2))
(prime:f u (+ v b) (+ b b) (quotient (- n u) 2))))))
(define (prime:fo m)
(let* ((s (gcd m (car prime:products)))
(r (quotient m s)))
(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 (prime:fe m)
(if (even? m)
(cons 2 (prime:fe (quotient m 2)))
(if (eqv? 1 m)
'()
(prime:fo m))))
(define (prime:factor k)
(case k
((-1 0 1) (list k))
(else (if (negative? k)
(cons -1 (prime:fe (- k)))
(prime:fe k)))))
;;@args k
;;Returns a list of the prime factors of @1. The order of the
;;factors is unspecified. In order to obtain a sorted list do
;;@code{(sort! (factor @var{k}) <)}.
(define factor prime:factor)

56
module/slib/factor.txi
View file

@ -1,56 +0,0 @@
@defvar prime:prngs
@var{prime:prngs} is the random-state (@pxref{Random Numbers}) used by these
procedures. If you call these procedures from more than one thread
(or from interrupt), @code{random} may complain about reentrant
calls.
@end defvar
@emph{Note:} The prime test and generation procedures implement (or
use) the Solovay-Strassen primality test. See
@itemize @bullet
@item Robert Solovay and Volker Strassen,
@cite{A Fast Monte-Carlo Test for Primality},
SIAM Journal on Computing, 1977, pp 84-85.
@end itemize
@defun jacobi-symbol p q
Returns the value (+1, @minus{}1, or 0) of the Jacobi-Symbol of
exact non-negative integer @var{p} and exact positive odd integer @var{q}.
@end defun
@defvar prime:trials
@var{prime:trials} the maxinum number of iterations of Solovay-Strassen that will
be done to test a number for primality.
@end defvar
@defun prime? n
Returns @code{#f} if @var{n} is composite; @code{#t} if @var{n} is prime.
There is a slight chance @code{(expt 2 (- prime:trials))} that a
composite will return @code{#t}.
@end defun
@defun primes< start count
Returns a list of the first @var{count} prime numbers less than
@var{start}. If there are fewer than @var{count} prime numbers
less than @var{start}, then the returned list will have fewer than
@var{start} elements.
@end defun
@defun primes> start count
Returns a list of the first @var{count} prime numbers greater than @var{start}.
@end defun
@defun factor k
Returns a list of the prime factors of @var{k}. The order of the
factors is unspecified. In order to obtain a sorted list do
@code{(sort! (factor @var{k}) <)}.
@end defun

70
module/slib/fft.scm
View file

@ -1,70 +0,0 @@
;;;"fft.scm" Fast Fourier Transform
;Copyright (C) 1999 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;;;; See:
;;; Introduction to Algorithms (MIT Electrical
;;; Engineering and Computer Science Series)
;;; by Thomas H. Cormen, Charles E. Leiserson (Contributor),
;;; Ronald L. Rivest (Contributor)
;;; MIT Press; ISBN: 0-262-03141-8 (July 1990)
;;; http://www.astro.virginia.edu/~eww6n/math/DiscreteFourierTransform.html
;;; differs in the direction of rotation of the complex unit vectors.
(require 'array)
(define (fft:shuffled&scaled ara n scale)
(define lgn (integer-length (+ -1 n)))
(define new (apply make-array 0 (array-dimensions ara)))
(define bit-reverse (lambda (width in)
(if (zero? width) 0
(+ (bit-reverse (+ -1 width) (quotient in 2))
(ash (modulo in 2) (+ -1 width))))))
(if (not (eqv? n (expt 2 lgn)))
(slib:error 'fft "array length not power of 2" n))
(do ((k 0 (+ 1 k)))
((>= k n) new)
(array-set! new (* (array-ref ara k) scale) (bit-reverse lgn k))))
(define (dft! ara n dir)
(define lgn (integer-length (+ -1 n)))
(define pi2i (* 0+8i (atan 1)))
(do ((s 1 (+ 1 s)))
((> s lgn) ara)
(let* ((m (expt 2 s))
(w_m (exp (* dir (/ pi2i m))))
(m/2-1 (+ (quotient m 2) -1)))
(do ((j 0 (+ 1 j))
(w 1 (* w w_m)))
((> j m/2-1))
(do ((k j (+ m k)))
((>= k n))
(let* ((k+m/2 (+ k m/2-1 1))
(t (* w (array-ref ara k+m/2)))
(u (array-ref ara k)))
(array-set! ara (+ u t) k)
(array-set! ara (- u t) k+m/2)))))))
(define (fft ara)
(define n (car (array-dimensions ara)))
(dft! (fft:shuffled&scaled ara n 1) n 1))
(define (fft-1 ara)
(define n (car (array-dimensions ara)))
(dft! (fft:shuffled&scaled ara n (/ n)) n -1))

40
module/slib/fluidlet.scm
View file

@ -1,40 +0,0 @@
; "fluidlet.scm", FLUID-LET for Scheme
; Copyright (c) 1998, Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'dynamic-wind)
(require 'common-list-functions) ;MAKE-LIST
(defmacro fluid-let (clauses . body)
(let ((ids (map car clauses))
(new-tmps (map (lambda (x) (gentemp)) clauses))
(old-tmps (map (lambda (x) (gentemp)) clauses)))
`(let (,@(map list new-tmps (map cadr clauses))
,@(map list old-tmps (make-list (length clauses) #f)))
(dynamic-wind
(lambda ()
,@(map (lambda (ot id) `(set! ,ot ,id))
old-tmps ids)
,@(map (lambda (id nt) `(set! ,id ,nt))
ids new-tmps))
(lambda () ,@body)
(lambda ()
,@(map (lambda (nt id) `(set! ,nt ,id))
new-tmps ids)
,@(map (lambda (id ot) `(set! ,id ,ot))
ids old-tmps))))))

434
module/slib/fmtdoc.txi
View file

@ -1,434 +0,0 @@
@menu
* Format Interface::
* Format Specification::
@end menu
@node Format Interface, Format Specification, Format, Format
@subsection Format Interface
@defun format destination format-string . arguments
An almost complete implementation of Common LISP format description
according to the CL reference book @cite{Common LISP} from Guy L.
Steele, Digital Press. Backward compatible to most of the available
Scheme format implementations.
Returns @code{#t}, @code{#f} or a string; has side effect of printing
according to @var{format-string}. If @var{destination} is @code{#t},
the output is to the current output port and @code{#t} is returned. If
@var{destination} is @code{#f}, a formatted string is returned as the
result of the call. NEW: If @var{destination} is a string,
@var{destination} is regarded as the format string; @var{format-string} is
then the first argument and the output is returned as a string. If
@var{destination} is a number, the output is to the current error port
if available by the implementation. Otherwise @var{destination} must be
an output port and @code{#t} is returned.@refill
@var{format-string} must be a string. In case of a formatting error
format returns @code{#f} and prints a message on the current output or
error port. Characters are output as if the string were output by the
@code{display} function with the exception of those prefixed by a tilde
(~). For a detailed description of the @var{format-string} syntax
please consult a Common LISP format reference manual. For a test suite
to verify this format implementation load @file{formatst.scm}. Please
send bug reports to @code{lutzeb@@cs.tu-berlin.de}.
Note: @code{format} is not reentrant, i.e. only one @code{format}-call
may be executed at a time.
@end defun
@node Format Specification, , Format Interface, Format
@subsection Format Specification (Format version 3.0)
Please consult a Common LISP format reference manual for a detailed
description of the format string syntax. For a demonstration of the
implemented directives see @file{formatst.scm}.@refill
This implementation supports directive parameters and modifiers
(@code{:} and @code{@@} characters). Multiple parameters must be
separated by a comma (@code{,}). Parameters can be numerical parameters
(positive or negative), character parameters (prefixed by a quote
character (@code{'}), variable parameters (@code{v}), number of rest
arguments parameter (@code{#}), empty and default parameters. Directive
characters are case independent. The general form of a directive
is:@refill
@noindent
@var{directive} ::= ~@{@var{directive-parameter},@}[:][@@]@var{directive-character}
@noindent
@var{directive-parameter} ::= [ [-|+]@{0-9@}+ | '@var{character} | v | # ]
@subsubsection Implemented CL Format Control Directives
Documentation syntax: Uppercase characters represent the corresponding
control directive characters. Lowercase characters represent control
directive parameter descriptions.
@table @asis
@item @code{~A}
Any (print as @code{display} does).
@table @asis
@item @code{~@@A}
left pad.
@item @code{~@var{mincol},@var{colinc},@var{minpad},@var{padchar}A}
full padding.
@end table
@item @code{~S}
S-expression (print as @code{write} does).
@table @asis
@item @code{~@@S}
left pad.
@item @code{~@var{mincol},@var{colinc},@var{minpad},@var{padchar}S}
full padding.
@end table
@item @code{~D}
Decimal.
@table @asis
@item @code{~@@D}
print number sign always.
@item @code{~:D}
print comma separated.
@item @code{~@var{mincol},@var{padchar},@var{commachar}D}
padding.
@end table
@item @code{~X}
Hexadecimal.
@table @asis
@item @code{~@@X}
print number sign always.
@item @code{~:X}
print comma separated.
@item @code{~@var{mincol},@var{padchar},@var{commachar}X}
padding.
@end table
@item @code{~O}
Octal.
@table @asis
@item @code{~@@O}
print number sign always.
@item @code{~:O}
print comma separated.
@item @code{~@var{mincol},@var{padchar},@var{commachar}O}
padding.
@end table
@item @code{~B}
Binary.
@table @asis
@item @code{~@@B}
print number sign always.
@item @code{~:B}
print comma separated.
@item @code{~@var{mincol},@var{padchar},@var{commachar}B}
padding.
@end table
@item @code{~@var{n}R}
Radix @var{n}.
@table @asis
@item @code{~@var{n},@var{mincol},@var{padchar},@var{commachar}R}
padding.
@end table
@item @code{~@@R}
print a number as a Roman numeral.
@item @code{~:@@R}
print a number as an ``old fashioned'' Roman numeral.
@item @code{~:R}
print a number as an ordinal English number.
@item @code{~R}
print a number as a cardinal English number.
@item @code{~P}
Plural.
@table @asis
@item @code{~@@P}
prints @code{y} and @code{ies}.
@item @code{~:P}
as @code{~P but jumps 1 argument backward.}
@item @code{~:@@P}
as @code{~@@P but jumps 1 argument backward.}
@end table
@item @code{~C}
Character.
@table @asis
@item @code{~@@C}
prints a character as the reader can understand it (i.e. @code{#\} prefixing).
@item @code{~:C}
prints a character as emacs does (eg. @code{^C} for ASCII 03).
@end table
@item @code{~F}
Fixed-format floating-point (prints a flonum like @var{mmm.nnn}).
@table @asis
@item @code{~@var{width},@var{digits},@var{scale},@var{overflowchar},@var{padchar}F}
@item @code{~@@F}
If the number is positive a plus sign is printed.
@end table
@item @code{~E}
Exponential floating-point (prints a flonum like @var{mmm.nnn}@code{E}@var{ee}).
@table @asis
@item @code{~@var{width},@var{digits},@var{exponentdigits},@var{scale},@var{overflowchar},@var{padchar},@var{exponentchar}E}
@item @code{~@@E}
If the number is positive a plus sign is printed.
@end table
@item @code{~G}
General floating-point (prints a flonum either fixed or exponential).
@table @asis
@item @code{~@var{width},@var{digits},@var{exponentdigits},@var{scale},@var{overflowchar},@var{padchar},@var{exponentchar}G}
@item @code{~@@G}
If the number is positive a plus sign is printed.
@end table
@item @code{~$}
Dollars floating-point (prints a flonum in fixed with signs separated).
@table @asis
@item @code{~@var{digits},@var{scale},@var{width},@var{padchar}$}
@item @code{~@@$}
If the number is positive a plus sign is printed.
@item @code{~:@@$}
A sign is always printed and appears before the padding.
@item @code{~:$}
The sign appears before the padding.
@end table
@item @code{~%}
Newline.
@table @asis
@item @code{~@var{n}%}
print @var{n} newlines.
@end table
@item @code{~&}
print newline if not at the beginning of the output line.
@table @asis
@item @code{~@var{n}&}
prints @code{~&} and then @var{n-1} newlines.
@end table
@item @code{~|}
Page Separator.
@table @asis
@item @code{~@var{n}|}
print @var{n} page separators.
@end table
@item @code{~~}
Tilde.
@table @asis
@item @code{~@var{n}~}
print @var{n} tildes.
@end table
@item @code{~}<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

1675
module/slib/format.scm
View file

File diff suppressed because it is too large Load diff

647
module/slib/formatst.scm
View file

@ -1,647 +0,0 @@
;; "formatst.scm" SLIB FORMAT Version 3.0 conformance test
; Written by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de)
;
; This code is in the public domain.
;; Test run: (slib:load "formatst")
; Failure reports for various scheme interpreters:
;
; SCM4d
; None.
; Elk 2.2:
; None.
; MIT C-Scheme 7.1:
; The empty list is always evaluated as a boolean and consequently
; represented as `#f'.
; Scheme->C 01nov91:
; None, if format:symbol-case-conv and format:iobj-case-conv are set
; to string-downcase.
(require 'format)
(if (not (string=? format:version "3.0"))
(begin
(display "You have format version ")
(display format:version)
(display ". This test is for format version 3.0!")
(newline)
(format:abort)))
(define fails 0)
(define total 0)
(define test-verbose #f) ; shows each test performed
(define (test format-args out-str)
(set! total (+ total 1))
(if (not test-verbose)
(if (zero? (modulo total 10))
(begin
(display total)
(display ",")
(force-output (current-output-port)))))
(let ((format-out (apply format `(#f ,@format-args))))
(if (string=? out-str format-out)
(if test-verbose
(begin
(display "Verified ")
(write format-args)
(display " returns ")
(write out-str)
(newline)))
(begin
(set! fails (+ fails 1))
(if (not test-verbose) (newline))
(display "*Failed* ")
(write format-args)
(newline)
(display " returns ")
(write format-out)
(newline)
(display " expected ")
(write out-str)
(newline)))))
; ensure format default configuration
(set! format:symbol-case-conv #f)
(set! format:iobj-case-conv #f)
(set! format:read-proof #f)
(format #t "~q")
(format #t "This implementation has~@[ no~] flonums ~
~:[but no~;and~] complex numbers~%"
(not format:floats) format:complex-numbers)
; any object test
(test '("abc") "abc")
(test '("~a" 10) "10")
(test '("~a" -1.2) "-1.2")
(test '("~a" a) "a")
(test '("~a" #t) "#t")
(test '("~a" #f) "#f")
(test '("~a" "abc") "abc")
(test '("~a" #(1 2 3)) "#(1 2 3)")
(test '("~a" ()) "()")
(test '("~a" (a)) "(a)")
(test '("~a" (a b)) "(a b)")
(test '("~a" (a (b c) d)) "(a (b c) d)")
(test '("~a" (a . b)) "(a . b)")
(test '("~a" (a (b c . d))) "(a (b . (c . d)))") ; this is ugly
(test `("~a" ,display) (format:iobj->str display))
(test `("~a" ,(current-input-port)) (format:iobj->str (current-input-port)))
(test `("~a" ,(current-output-port)) (format:iobj->str (current-output-port)))
; # argument test
(test '("~a ~a" 10 20) "10 20")
(test '("~a abc ~a def" 10 20) "10 abc 20 def")
; numerical test
(test '("~d" 100) "100")
(test '("~x" 100) "64")
(test '("~o" 100) "144")
(test '("~b" 100) "1100100")
(test '("~@d" 100) "+100")
(test '("~@d" -100) "-100")
(test '("~@x" 100) "+64")
(test '("~@o" 100) "+144")
(test '("~@b" 100) "+1100100")
(test '("~10d" 100) " 100")
(test '("~:d" 123) "123")
(test '("~:d" 1234) "1,234")
(test '("~:d" 12345) "12,345")
(test '("~:d" 123456) "123,456")
(test '("~:d" 12345678) "12,345,678")
(test '("~:d" -123) "-123")
(test '("~:d" -1234) "-1,234")
(test '("~:d" -12345) "-12,345")
(test '("~:d" -123456) "-123,456")
(test '("~:d" -12345678) "-12,345,678")
(test '("~10:d" 1234) " 1,234")
(test '("~10:d" -1234) " -1,234")
(test '("~10,'*d" 100) "*******100")
(test '("~10,,'|:d" 12345678) "12|345|678")
(test '("~10,,,2:d" 12345678) "12,34,56,78")
(test '("~14,'*,'|,4:@d" 12345678) "****+1234|5678")
(test '("~10r" 100) "100")
(test '("~2r" 100) "1100100")
(test '("~8r" 100) "144")
(test '("~16r" 100) "64")
(test '("~16,10,'*r" 100) "********64")
; roman numeral test
(test '("~@r" 4) "IV")
(test '("~@r" 19) "XIX")
(test '("~@r" 50) "L")
(test '("~@r" 100) "C")
(test '("~@r" 1000) "M")
(test '("~@r" 99) "XCIX")
(test '("~@r" 1994) "MCMXCIV")
; old roman numeral test
(test '("~:@r" 4) "IIII")
(test '("~:@r" 5) "V")
(test '("~:@r" 10) "X")
(test '("~:@r" 9) "VIIII")
; cardinal/ordinal English number test
(test '("~r" 4) "four")
(test '("~r" 10) "ten")
(test '("~r" 19) "nineteen")
(test '("~r" 1984) "one thousand, nine hundred eighty-four")
(test '("~:r" -1984) "minus one thousand, nine hundred eighty-fourth")
; character test
(test '("~c" #\a) "a")
(test '("~@c" #\a) "#\\a")
(test `("~@c" ,(integer->char 32)) "#\\space")
(test `("~@c" ,(integer->char 0)) "#\\nul")
(test `("~@c" ,(integer->char 27)) "#\\esc")
(test `("~@c" ,(integer->char 127)) "#\\del")
(test `("~@c" ,(integer->char 128)) "#\\200")
(test `("~@c" ,(integer->char 255)) "#\\377")
(test '("~65c") "A")
(test '("~7@c") "#\\bel")
(test '("~:c" #\a) "a")
(test `("~:c" ,(integer->char 1)) "^A")
(test `("~:c" ,(integer->char 27)) "^[")
(test '("~7:c") "^G")
(test `("~:c" ,(integer->char 128)) "#\\200")
(test `("~:c" ,(integer->char 127)) "#\\177")
(test `("~:c" ,(integer->char 255)) "#\\377")
; plural test
(test '("test~p" 1) "test")
(test '("test~p" 2) "tests")
(test '("test~p" 0) "tests")
(test '("tr~@p" 1) "try")
(test '("tr~@p" 2) "tries")
(test '("tr~@p" 0) "tries")
(test '("~a test~:p" 10) "10 tests")
(test '("~a test~:p" 1) "1 test")
; tilde test
(test '("~~~~") "~~")
(test '("~3~") "~~~")
; whitespace character test
(test '("~%") "
")
(test '("~3%") "
")
(test '("~&") "")
(test '("abc~&") "abc
")
(test '("abc~&def") "abc
def")
(test '("~&") "
")
(test '("~3&") "
")
(test '("abc~3&") "abc
")
(test '("~|") (string slib:form-feed))
(test '("~_~_~_") " ")
(test '("~3_") " ")
(test '("~/") (string slib:tab))
(test '("~3/") (make-string 3 slib:tab))
; tabulate test
(test '("~0&~3t") " ")
(test '("~0&~10t") " ")
(test '("~10t") "")
(test '("~0&1234567890~,8tABC") "1234567890 ABC")
(test '("~0&1234567890~0,8tABC") "1234567890 ABC")
(test '("~0&1234567890~1,8tABC") "1234567890 ABC")
(test '("~0&1234567890~2,8tABC") "1234567890ABC")
(test '("~0&1234567890~3,8tABC") "1234567890 ABC")
(test '("~0&1234567890~4,8tABC") "1234567890 ABC")
(test '("~0&1234567890~5,8tABC") "1234567890 ABC")
(test '("~0&1234567890~6,8tABC") "1234567890 ABC")
(test '("~0&1234567890~7,8tABC") "1234567890 ABC")
(test '("~0&1234567890~8,8tABC") "1234567890 ABC")
(test '("~0&1234567890~9,8tABC") "1234567890 ABC")
(test '("~0&1234567890~10,8tABC") "1234567890ABC")
(test '("~0&1234567890~11,8tABC") "1234567890 ABC")
(test '("~0&12345~,8tABCDE~,8tXYZ") "12345 ABCDE XYZ")
(test '("~,8t+++~,8t===") " +++ ===")
(test '("~0&ABC~,8,'.tDEF") "ABC......DEF")
(test '("~0&~3,8@tABC") " ABC")
(test '("~0&1234~3,8@tABC") "1234 ABC")
(test '("~0&12~3,8@tABC~3,8@tDEF") "12 ABC DEF")
; indirection test
(test '("~a ~? ~a" 10 "~a ~a" (20 30) 40) "10 20 30 40")
(test '("~a ~@? ~a" 10 "~a ~a" 20 30 40) "10 20 30 40")
; field test
(test '("~10a" "abc") "abc ")
(test '("~10@a" "abc") " abc")
(test '("~10a" "0123456789abc") "0123456789abc")
(test '("~10@a" "0123456789abc") "0123456789abc")
; pad character test
(test '("~10,,,'*a" "abc") "abc*******")
(test '("~10,,,'Xa" "abc") "abcXXXXXXX")
(test '("~10,,,42a" "abc") "abc*******")
(test '("~10,,,'*@a" "abc") "*******abc")
(test '("~10,,3,'*a" "abc") "abc*******")
(test '("~10,,3,'*a" "0123456789abc") "0123456789abc***") ; min. padchar length
(test '("~10,,3,'*@a" "0123456789abc") "***0123456789abc")
; colinc, minpad padding test
(test '("~10,8,0,'*a" 123) "123********")
(test '("~10,9,0,'*a" 123) "123*********")
(test '("~10,10,0,'*a" 123) "123**********")
(test '("~10,11,0,'*a" 123) "123***********")
(test '("~8,1,0,'*a" 123) "123*****")
(test '("~8,2,0,'*a" 123) "123******")
(test '("~8,3,0,'*a" 123) "123******")
(test '("~8,4,0,'*a" 123) "123********")
(test '("~8,5,0,'*a" 123) "123*****")
(test '("~8,1,3,'*a" 123) "123*****")
(test '("~8,1,5,'*a" 123) "123*****")
(test '("~8,1,6,'*a" 123) "123******")
(test '("~8,1,9,'*a" 123) "123*********")
; slashify test
(test '("~s" "abc") "\"abc\"")
(test '("~s" "abc \\ abc") "\"abc \\\\ abc\"")
(test '("~a" "abc \\ abc") "abc \\ abc")
(test '("~s" "abc \" abc") "\"abc \\\" abc\"")
(test '("~a" "abc \" abc") "abc \" abc")
(test '("~s" #\space) "#\\space")
(test '("~s" #\newline) "#\\newline")
(test `("~s" ,slib:tab) "#\\ht")
(test '("~s" #\a) "#\\a")
(test '("~a" (a "b" c)) "(a \"b\" c)")
; symbol case force test
(define format:old-scc format:symbol-case-conv)
(set! format:symbol-case-conv string-upcase)
(test '("~a" abc) "ABC")
(set! format:symbol-case-conv string-downcase)
(test '("~s" abc) "abc")
(set! format:symbol-case-conv string-capitalize)
(test '("~s" abc) "Abc")
(set! format:symbol-case-conv format:old-scc)
; read proof test
(test `("~:s" ,display)
(begin
(set! format:read-proof #t)
(format:iobj->str display)))
(test `("~:a" ,display)
(begin
(set! format:read-proof #t)
(format:iobj->str display)))
(test `("~:a" (1 2 ,display))
(begin
(set! format:read-proof #t)
(string-append "(1 2 " (format:iobj->str display) ")")))
(test '("~:a" "abc") "abc")
(set! format:read-proof #f)
; internal object case type force test
(set! format:iobj-case-conv string-upcase)
(test `("~a" ,display) (string-upcase (format:iobj->str display)))
(set! format:iobj-case-conv string-downcase)
(test `("~s" ,display) (string-downcase (format:iobj->str display)))
(set! format:iobj-case-conv string-capitalize)
(test `("~s" ,display) (string-capitalize (format:iobj->str display)))
(set! format:iobj-case-conv #f)
; continuation line test
(test '("abc~
123") "abc123")
(test '("abc~
123") "abc123")
(test '("abc~
") "abc")
(test '("abc~:
def") "abc def")
(test '("abc~@
def")
"abc
def")
; flush output (can't test it here really)
(test '("abc ~! xyz") "abc xyz")
; string case conversion
(test '("~a ~(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc hello world xyz")
(test '("~a ~:(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc Hello World xyz")
(test '("~a ~@(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc Hello world xyz")
(test '("~a ~:@(~a~) ~a" "abc" "hello world" "xyz") "abc HELLO WORLD xyz")
(test '("~:@(~a~)" (a b c)) "(A B C)")
(test '("~:@(~x~)" 255) "FF")
(test '("~:@(~p~)" 2) "S")
(test `("~:@(~a~)" ,display) (string-upcase (format:iobj->str display)))
(test '("~:(~a ~a ~a~) ~a" "abc" "xyz" "123" "world") "Abc Xyz 123 world")
; variable parameter
(test '("~va" 10 "abc") "abc ")
(test '("~v,,,va" 10 42 "abc") "abc*******")
; number of remaining arguments as parameter
(test '("~#,,,'*@a ~a ~a ~a" 1 1 1 1) "***1 1 1 1")
; argument jumping
(test '("~a ~* ~a" 10 20 30) "10 30")
(test '("~a ~2* ~a" 10 20 30 40) "10 40")
(test '("~a ~:* ~a" 10) "10 10")
(test '("~a ~a ~2:* ~a ~a" 10 20) "10 20 10 20")
(test '("~a ~a ~@* ~a ~a" 10 20) "10 20 10 20")
(test '("~a ~a ~4@* ~a ~a" 10 20 30 40 50 60) "10 20 50 60")
; conditionals
(test '("~[abc~;xyz~]" 0) "abc")
(test '("~[abc~;xyz~]" 1) "xyz")
(test '("~[abc~;xyz~:;456~]" 99) "456")
(test '("~0[abc~;xyz~:;456~]") "abc")
(test '("~1[abc~;xyz~:;456~] ~a" 100) "xyz 100")
(test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]") "no arg")
(test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10) "10")
(test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10 20) "10 and 20")
(test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10 20 30) "10, 20 and 30")
(test '("~:[hello~;world~] ~a" #t 10) "world 10")
(test '("~:[hello~;world~] ~a" #f 10) "hello 10")
(test '("~@[~a tests~]" #f) "")
(test '("~@[~a tests~]" 10) "10 tests")
(test '("~@[~a test~:p~] ~a" 10 done) "10 tests done")
(test '("~@[~a test~:p~] ~a" 1 done) "1 test done")
(test '("~@[~a test~:p~] ~a" 0 done) "0 tests done")
(test '("~@[~a test~:p~] ~a" #f done) " done")
(test '("~@[ level = ~d~]~@[ length = ~d~]" #f 5) " length = 5")
(test '("~[abc~;~[4~;5~;6~]~;xyz~]" 0) "abc") ; nested conditionals (irrghh)
(test '("~[abc~;~[4~;5~;6~]~;xyz~]" 2) "xyz")
(test '("~[abc~;~[4~;5~;6~]~;xyz~]" 1 2) "6")
; iteration
(test '("~{ ~a ~}" (a b c)) " a b c ")
(test '("~{ ~a ~}" ()) "")
(test '("~{ ~a ~5,,,'*a~}" (a b c d)) " a b**** c d****")
(test '("~{ ~a,~a ~}" (a 1 b 2 c 3)) " a,1 b,2 c,3 ")
(test '("~2{ ~a,~a ~}" (a 1 b 2 c 3)) " a,1 b,2 ")
(test '("~3{~a ~} ~a" (a b c d e) 100) "a b c 100")
(test '("~0{~a ~} ~a" (a b c d e) 100) " 100")
(test '("~:{ ~a,~a ~}" ((a b) (c d e f) (g h))) " a,b c,d g,h ")
(test '("~2:{ ~a,~a ~}" ((a b) (c d e f) (g h))) " a,b c,d ")
(test '("~@{ ~a,~a ~}" a 1 b 2 c 3) " a,1 b,2 c,3 ")
(test '("~2@{ ~a,~a ~} <~a|~a>" a 1 b 2 c 3) " a,1 b,2 <c|3>")
(test '("~:@{ ~a,~a ~}" (a 1) (b 2) (c 3)) " a,1 b,2 c,3 ")
(test '("~2:@{ ~a,~a ~} ~a" (a 1) (b 2) (c 3)) " a,1 b,2 (c 3)")
(test '("~{~}" "<~a,~a>" (a 1 b 2 c 3)) "<a,1><b,2><c,3>")
(test '("~{ ~a ~{<~a>~}~} ~a" (a (1 2) b (3 4)) 10) " a <1><2> b <3><4> 10")
; up and out
(test '("abc ~^ xyz") "abc ")
(test '("~@(abc ~^ xyz~) ~a" 10) "ABC xyz 10")
(test '("done. ~^ ~d warning~:p. ~^ ~d error~:p.") "done. ")
(test '("done. ~^ ~d warning~:p. ~^ ~d error~:p." 10) "done. 10 warnings. ")
(test '("done. ~^ ~d warning~:p. ~^ ~d error~:p." 10 1)
"done. 10 warnings. 1 error.")
(test '("~{ ~a ~^<~a>~} ~a" (a b c d e f) 10) " a <b> c <d> e <f> 10")
(test '("~{ ~a ~^<~a>~} ~a" (a b c d e) 10) " a <b> c <d> e 10")
(test '("abc~0^ xyz") "abc")
(test '("abc~9^ xyz") "abc xyz")
(test '("abc~7,4^ xyz") "abc xyz")
(test '("abc~7,7^ xyz") "abc")
(test '("abc~3,7,9^ xyz") "abc")
(test '("abc~8,7,9^ xyz") "abc xyz")
(test '("abc~3,7,5^ xyz") "abc xyz")
; complexity tests (oh my god, I hardly understand them myself (see CL std))
(define fmt "Items:~#[ none~; ~a~; ~a and ~a~:;~@{~#[~; and~] ~a~^,~}~].")
(test `(,fmt ) "Items: none.")
(test `(,fmt foo) "Items: foo.")
(test `(,fmt foo bar) "Items: foo and bar.")
(test `(,fmt foo bar baz) "Items: foo, bar, and baz.")
(test `(,fmt foo bar baz zok) "Items: foo, bar, baz, and zok.")
; fixed floating points
(cond
(format:floats
(test '("~6,2f" 3.14159) " 3.14")
(test '("~6,1f" 3.14159) " 3.1")
(test '("~6,0f" 3.14159) " 3.")
(test '("~5,1f" 0) " 0.0")
(test '("~10,7f" 3.14159) " 3.1415900")
(test '("~10,7f" -3.14159) "-3.1415900")
(test '("~10,7@f" 3.14159) "+3.1415900")
(test '("~6,3f" 0.0) " 0.000")
(test '("~6,4f" 0.007) "0.0070")
(test '("~6,3f" 0.007) " 0.007")
(test '("~6,2f" 0.007) " 0.01")
(test '("~3,2f" 0.007) ".01")
(test '("~3,2f" -0.007) "-.01")
(test '("~6,2,,,'*f" 3.14159) "**3.14")
(test '("~6,3,,'?f" 12345.56789) "??????")
(test '("~6,3f" 12345.6789) "12345.679")
(test '("~,3f" 12345.6789) "12345.679")
(test '("~,3f" 9.9999) "10.000")
(test '("~6f" 23.4) " 23.4")
(test '("~6f" 1234.5) "1234.5")
(test '("~6f" 12345678) "12345678.0")
(test '("~6,,,'?f" 12345678) "??????")
(test '("~6f" 123.56789) "123.57")
(test '("~6f" 123.0) " 123.0")
(test '("~6f" -123.0) "-123.0")
(test '("~6f" 0.0) " 0.0")
(test '("~3f" 3.141) "3.1")
(test '("~2f" 3.141) "3.")
(test '("~1f" 3.141) "3.141")
(test '("~f" 123.56789) "123.56789")
(test '("~f" -314.0) "-314.0")
(test '("~f" 1e4) "10000.0")
(test '("~f" -1.23e10) "-12300000000.0")
(test '("~f" 1e-4) "0.0001")
(test '("~f" -1.23e-10) "-0.000000000123")
(test '("~@f" 314.0) "+314.0")
(test '("~,,3f" 0.123456) "123.456")
(test '("~,,-3f" -123.456) "-0.123456")
(test '("~5,,3f" 0.123456) "123.5")
))
; exponent floating points
(cond
(format:floats
(test '("~e" 3.14159) "3.14159E+0")
(test '("~e" 0.00001234) "1.234E-5")
(test '("~,,,0e" 0.00001234) "0.1234E-4")
(test '("~,3e" 3.14159) "3.142E+0")
(test '("~,3@e" 3.14159) "+3.142E+0")
(test '("~,3@e" 0.0) "+0.000E+0")
(test '("~,0e" 3.141) "3.E+0")
(test '("~,3,,0e" 3.14159) "0.314E+1")
(test '("~,5,3,-2e" 3.14159) "0.00314E+003")
(test '("~,5,3,-5e" -3.14159) "-0.00000E+006")
(test '("~,5,2,2e" 3.14159) "31.4159E-01")
(test '("~,5,2,,,,'ee" 0.0) "0.00000e+00")
(test '("~12,3e" -3.141) " -3.141E+0")
(test '("~12,3,,,,'#e" -3.141) "###-3.141E+0")
(test '("~10,2e" -1.236e-4) " -1.24E-4")
(test '("~5,3e" -3.141) "-3.141E+0")
(test '("~5,3,,,'*e" -3.141) "*****")
(test '("~3e" 3.14159) "3.14159E+0")
(test '("~4e" 3.14159) "3.14159E+0")
(test '("~5e" 3.14159) "3.E+0")
(test '("~5,,,,'*e" 3.14159) "3.E+0")
(test '("~6e" 3.14159) "3.1E+0")
(test '("~7e" 3.14159) "3.14E+0")
(test '("~7e" -3.14159) "-3.1E+0")
(test '("~8e" 3.14159) "3.142E+0")
(test '("~9e" 3.14159) "3.1416E+0")
(test '("~9,,,,,,'ee" 3.14159) "3.1416e+0")
(test '("~10e" 3.14159) "3.14159E+0")
(test '("~11e" 3.14159) " 3.14159E+0")
(test '("~12e" 3.14159) " 3.14159E+0")
(test '("~13,6,2,-5e" 3.14159) " 0.000003E+06")
(test '("~13,6,2,-4e" 3.14159) " 0.000031E+05")
(test '("~13,6,2,-3e" 3.14159) " 0.000314E+04")
(test '("~13,6,2,-2e" 3.14159) " 0.003142E+03")
(test '("~13,6,2,-1e" 3.14159) " 0.031416E+02")
(test '("~13,6,2,0e" 3.14159) " 0.314159E+01")
(test '("~13,6,2,1e" 3.14159) " 3.141590E+00")
(test '("~13,6,2,2e" 3.14159) " 31.41590E-01")
(test '("~13,6,2,3e" 3.14159) " 314.1590E-02")
(test '("~13,6,2,4e" 3.14159) " 3141.590E-03")
(test '("~13,6,2,5e" 3.14159) " 31415.90E-04")
(test '("~13,6,2,6e" 3.14159) " 314159.0E-05")
(test '("~13,6,2,7e" 3.14159) " 3141590.E-06")
(test '("~13,6,2,8e" 3.14159) "31415900.E-07")
(test '("~7,3,,-2e" 0.001) ".001E+0")
(test '("~8,3,,-2@e" 0.001) "+.001E+0")
(test '("~8,3,,-2@e" -0.001) "-.001E+0")
(test '("~8,3,,-2e" 0.001) "0.001E+0")
(test '("~7,,,-2e" 0.001) "0.00E+0")
(test '("~12,3,1e" 3.14159e12) " 3.142E+12")
(test '("~12,3,1,,'*e" 3.14159e12) "************")
(test '("~5,3,1e" 3.14159e12) "3.142E+12")
))
; general floating point (this test is from Steele's CL book)
(cond
(format:floats
(test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
0.0314159 0.0314159 0.0314159 0.0314159)
" 3.14E-2|314.2$-04|0.314E-01| 3.14E-2")
(test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
0.314159 0.314159 0.314159 0.314159)
" 0.31 |0.314 |0.314 | 0.31 ")
(test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
3.14159 3.14159 3.14159 3.14159)
" 3.1 | 3.14 | 3.14 | 3.1 ")
(test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
31.4159 31.4159 31.4159 31.4159)
" 31. | 31.4 | 31.4 | 31. ")
(test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
314.159 314.159 314.159 314.159)
" 3.14E+2| 314. | 314. | 3.14E+2")
(test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
3141.59 3141.59 3141.59 3141.59)
" 3.14E+3|314.2$+01|0.314E+04| 3.14E+3")
(test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
3.14E12 3.14E12 3.14E12 3.14E12)
"*********|314.0$+10|0.314E+13| 3.14E+12")
(test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
3.14E120 3.14E120 3.14E120 3.14E120)
"*********|?????????|%%%%%%%%%|3.14E+120")
(test '("~g" 0.0) "0.0 ") ; further ~g tests
(test '("~g" 0.1) "0.1 ")
(test '("~g" 0.01) "1.0E-2")
(test '("~g" 123.456) "123.456 ")
(test '("~g" 123456.7) "123456.7 ")
(test '("~g" 123456.78) "123456.78 ")
(test '("~g" 0.9282) "0.9282 ")
(test '("~g" 0.09282) "9.282E-2")
(test '("~g" 1) "1.0 ")
(test '("~g" 12) "12.0 ")
))
; dollar floating point
(cond
(format:floats
(test '("~$" 1.23) "1.23")
(test '("~$" 1.2) "1.20")
(test '("~$" 0.0) "0.00")
(test '("~$" 9.999) "10.00")
(test '("~3$" 9.9999) "10.000")
(test '("~,4$" 3.2) "0003.20")
(test '("~,4$" 10000.2) "10000.20")
(test '("~,4,10$" 3.2) " 0003.20")
(test '("~,4,10@$" 3.2) " +0003.20")
(test '("~,4,10:@$" 3.2) "+ 0003.20")
(test '("~,4,10:$" -3.2) "- 0003.20")
(test '("~,4,10$" -3.2) " -0003.20")
(test '("~,,10@$" 3.2) " +3.20")
(test '("~,,10:@$" 3.2) "+ 3.20")
(test '("~,,10:@$" -3.2) "- 3.20")
(test '("~,,10,'_@$" 3.2) "_____+3.20")
(test '("~,,4$" 1234.4) "1234.40")
))
; complex numbers
(cond
(format:complex-numbers
(test '("~i" 3.0) "3.0+0.0i")
(test '("~,3i" 3.0) "3.000+0.000i")
(test `("~7,2i" ,(string->number "3.0+5.0i")) " 3.00 +5.00i")
(test `("~7,2,1i" ,(string->number "3.0+5.0i")) " 30.00 +50.00i")
(test `("~7,2@i" ,(string->number "3.0+5.0i")) " +3.00 +5.00i")
(test `("~7,2,,,'*@i" ,(string->number "3.0+5.0i")) "**+3.00**+5.00i")
)) ; note: some parsers choke syntactically on reading a complex
; number though format:complex is #f; this is why we put them in
; strings
; inquiry test
(test '("~:q") format:version)
(if (not test-verbose) (display "done."))
(format #t "~%~a Test~:p completed. (~a failure~:p)~2%" total fails)
; eof

301
module/slib/gambit.init
View file

@ -1,301 +0,0 @@
;;;"gambit.init" Initialization for SLIB for Gambit -*-scheme-*-
;;; Author: Aubrey Jaffer
;;;
;;; This code is in the public domain.
;;; Updated 1992 February 1 for Gambit v1.71 -- by Ken Dickey
;;; Date: Wed, 12 Jan 1994 15:03:12 -0500
;;; From: barnett@armadillo.urich.edu (Lewis Barnett)
;;; Relative pathnames for Slib in MacGambit
;;; Hacked yet again for Gambit v2.4, Jan 1997, by Mike Pope
(define (software-type) 'MACOS) ; for MacGambit.
(define (software-type) 'UNIX) ; for Unix platforms.
(define (scheme-implementation-type) 'gambit)
;;; (scheme-implementation-home-page) should return a (string) URI
;;; (Uniform Resource Identifier) for this scheme implementation's home
;;; page; or false if there isn't one.
(define (scheme-implementation-home-page)
"http://www.iro.umontreal.ca/~gambit/index.html")
(define (scheme-implementation-version) "3.0")
;;; Jefferson R. Lowrey reports that in Gambit Version 3.0
;;; (argv) returns '("").
(define argv
(if (equal? '("") (argv)) ;Fix only if it is broken.
(lambda () '("Lowrey HD:Development:MacGambit 3.0:Interpreter"))
argv))
;;; (implementation-vicinity) should be defined to be the pathname of
;;; the directory where any auxillary files to your Scheme
;;; implementation reside.
(define implementation-vicinity
(case (software-type)
((UNIX) (lambda () "/usr/local/src/scheme/"))
((VMS) (lambda () "scheme$src:"))
((MS-DOS) (lambda () "C:\\scheme\\"))
((WINDOWS) (lambda () "c:/scheme/"))
((MACOS)
(let ((arg0 (list-ref (argv) 0)))
(let loop ((i (- (string-length arg0) 1)))
(cond ((negative? i) "")
((char=? #\: (string-ref arg0 i))
(set! arg0 (substring arg0 0 (+ i 1)))
(lambda () arg0))
(else (loop (- i 1)))))))))
;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
;;; This assumes that the slib files are in a folder
;;; called slib in the same directory as the MacGambit Interpreter.
(define library-vicinity
(let ((library-path
(case (software-type)
((UNIX) "/usr/local/lib/slib/")
((MACOS) (string-append (implementation-vicinity) "slib:"))
((AMIGA) "dh0:scm/Library/")
((VMS) "lib$scheme:")
((WINDOWS MS-DOS) "C:\\SLIB\\")
(else ""))))
(lambda () library-path)))
;;; (home-vicinity) should return the vicinity of the user's HOME
;;; directory, the directory which typically contains files which
;;; customize a computer environment for a user.
(define (home-vicinity) #f)
;;; *FEATURES* should be set to a list of symbols describing features
;;; of this implementation. Suggestions for features are:
(define *features*
'(
source ;can load scheme source files
;(slib:load-source "filename")
compiled ;can load compiled files
;(slib:load-compiled "filename")
rev4-report ;conforms to
; rev3-report ;conforms to
ieee-p1178 ;conforms to
sicp ;runs code from Structure and
;Interpretation of Computer
;Programs by Abelson and Sussman.
rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
;LIST->STRING, STRING-COPY,
;STRING-FILL!, LIST->VECTOR,
;VECTOR->LIST, and VECTOR-FILL!
; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
;SUBSTRING-FILL!,
;STRING-NULL?, APPEND!, 1+,
;-1+, <?, <=?, =?, >?, >=?
multiarg/and- ;/ and - can take more than 2 args.
multiarg-apply ;APPLY can take more than 2 args.
rationalize
delay ;has DELAY and FORCE
with-file ;has WITH-INPUT-FROM-FILE and
;WITH-OUTPUT-FROM-FILE
string-port ;has CALL-WITH-INPUT-STRING and
;CALL-WITH-OUTPUT-STRING
transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
char-ready?
; macro ;has R4RS high level macros
defmacro ;has Common Lisp DEFMACRO
; record ;has user defined data structures
; values ;proposed multiple values
; dynamic-wind ;proposed dynamic-wind
ieee-floating-point ;conforms to
full-continuation ;can return multiple times
; object-hash ;has OBJECT-HASH
; sort
; queue ;queues
pretty-print
; object->string
; format
trace ;has macros: TRACE and UNTRACE
; compiler ;has (COMPILER)
; ed ;(ED) is editor
system ;posix (system <string>)
; getenv ;posix (getenv <string>)
program-arguments ;returns list of strings (argv)
; Xwindows ;X support
; curses ;screen management package
; termcap ;terminal description package
; terminfo ;sysV terminal description
; current-time ;returns time in seconds since 1/1/1970
))
;;; (OUTPUT-PORT-WIDTH <port>)
(define (output-port-width . arg) 79)
;;; (OUTPUT-PORT-HEIGHT <port>)
(define (output-port-height . arg) 24)
;;; (CURRENT-ERROR-PORT)
(define current-error-port
(let ((port (current-output-port)))
(lambda () port)))
;;; (TMPNAM) makes a temporary file name.
(define tmpnam (let ((cntr 100))
(lambda () (set! cntr (+ 1 cntr))
(string-append "slib_" (number->string cntr)))))
;;; Gambit supports SYSTEM as an "Unstable Addition"; Watch for changes.
(define system ##shell-command)
;;; (FILE-EXISTS? <string>)
;(define (file-exists? f) #f)
;;; (DELETE-FILE <string>)
(define (delete-file f) #f)
;;; FORCE-OUTPUT flushes any pending output on optional arg output port
;;; use this definition if your system doesn't have such a procedure.
(define force-output flush-output)
;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
;;; port versions of CALL-WITH-*PUT-FILE.
;;; "rationalize" adjunct procedures.
(define (find-ratio x e)
(let ((rat (rationalize x e)))
(list (numerator rat) (denominator rat))))
(define (find-ratio-between x y)
(find-ratio (/ (+ x y) 2) (/ (- x y) 2)))
;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
;;; be returned by CHAR->INTEGER.
(define char-code-limit 256)
;; MOST-POSITIVE-FIXNUM is used in modular.scm
(define most-positive-fixnum #x1FFFFFFF) ; 3-bit tag for 68K
;;; Return argument
(define (identity x) x)
;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
(define slib:eval eval)
; Define program-arguments as argv
(define program-arguments argv)
;;; If your implementation provides R4RS macros:
;(define macro:eval slib:eval)
;(define macro:load load)
; Set up defmacro in terms of gambit's define-macro
(define-macro (defmacro name args . body)
`(define-macro (,name ,@args) ,@body))
(define *defmacros*
(list (cons 'defmacro
(lambda (name parms . body)
`(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body))
*defmacros*))))))
(define (defmacro? m) (and (assq m *defmacros*) #t))
(define (macroexpand-1 e)
(if (pair? e) (let ((a (car e)))
(cond ((symbol? a) (set! a (assq a *defmacros*))
(if a (apply (cdr a) (cdr e)) e))
(else e)))
e))
(define (macroexpand e)
(if (pair? e) (let ((a (car e)))
(cond ((symbol? a)
(set! a (assq a *defmacros*))
(if a (macroexpand (apply (cdr a) (cdr e))) e))
(else e)))
e))
(define gentemp
(let ((*gensym-counter* -1))
(lambda ()
(set! *gensym-counter* (+ *gensym-counter* 1))
(string->symbol
(string-append "slib:G" (number->string *gensym-counter*))))))
(define base:eval slib:eval)
(define defmacro:eval base:eval)
(define (defmacro:load <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))))
(call-with-input-file <pathname>
(lambda (port)
(let ((old-load-pathname *load-pathname*))
(set! *load-pathname* <pathname>)
(do ((o (read port) (read port)))
((eof-object? o))
(evl o))
(set! *load-pathname* old-load-pathname)))))
(define slib:warn
(lambda args
(let ((cep (current-error-port)))
(if (provided? 'trace) (print-call-stack cep))
(display "Warn: " cep)
(for-each (lambda (x) (display x cep)) args))))
;; define an error procedure for the library
(define (slib:error . args)
(if (provided? 'trace) (print-call-stack (current-error-port)))
(apply error args))
;; define these as appropriate for your system.
(define slib:tab (integer->char 9))
(define slib:form-feed (integer->char 12))
;;; Support for older versions of Scheme. Not enough code for its own file.
(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))
(define t #t)
(define nil #f)
;;; Define these if your implementation's syntax can support it and if
;;; they are not already defined.
(define (1+ n) (+ n 1))
(define (-1+ n) (- n 1))
(define 1- -1+)
(define in-vicinity string-append)
;;; Define SLIB:EXIT to be the implementation procedure to exit or
;;; return if exitting not supported.
(define slib:exit (lambda args (exit)))
;;; Here for backward compatability
(define scheme-file-suffix
(let ((suffix (case (software-type)
((NOSVE) "_scm")
(else ".scm"))))
(lambda () suffix)))
;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
;;; suffix all the module files in SLIB have. See feature 'SOURCE.
(define slib:load-source load)
;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
;;; by compiling "foo.scm" if this implementation can compile files.
;;; See feature 'COMPILED.
(define slib:load-compiled load)
;;; At this point SLIB:LOAD must be able to load SLIB files.
(define slib:load slib:load-source)
(slib:load (in-vicinity (library-vicinity) "require"))

266
module/slib/genwrite.scm
View file

@ -1,266 +0,0 @@
;;"genwrite.scm" generic write used by pretty-print and truncated-print.
;; Copyright (c) 1991, Marc Feeley
;; Author: Marc Feeley (feeley@iro.umontreal.ca)
;; Distribution restrictions: none
(define genwrite:newline-str (make-string 1 #\newline))
(define (generic-write obj display? width output)
(define (read-macro? l)
(define (length1? l) (and (pair? l) (null? (cdr l))))
(let ((head (car l)) (tail (cdr l)))
(case head
((quote quasiquote unquote unquote-splicing) (length1? tail))
(else #f))))
(define (read-macro-body l)
(cadr l))
(define (read-macro-prefix l)
(let ((head (car l)) (tail (cdr l)))
(case head
((quote) "'")
((quasiquote) "`")
((unquote) ",")
((unquote-splicing) ",@"))))
(define (out str col)
(and col (output str) (+ col (string-length str))))
(define (wr obj col)
(define (wr-expr expr col)
(if (read-macro? expr)
(wr (read-macro-body expr) (out (read-macro-prefix expr) col))
(wr-lst expr col)))
(define (wr-lst l col)
(if (pair? l)
(let loop ((l (cdr l))
(col (and col (wr (car l) (out "(" col)))))
(cond ((not col) col)
((pair? l)
(loop (cdr l) (wr (car l) (out " " col))))
((null? l) (out ")" col))
(else (out ")" (wr l (out " . " col))))))
(out "()" col)))
(cond ((pair? obj) (wr-expr obj col))
((null? obj) (wr-lst obj col))
((vector? obj) (wr-lst (vector->list obj) (out "#" col)))
((boolean? obj) (out (if obj "#t" "#f") col))
((number? obj) (out (number->string obj) col))
((symbol? obj) (out (symbol->string obj) col))
((procedure? obj) (out "#[procedure]" col))
((string? obj) (if display?
(out obj col)
(let loop ((i 0) (j 0) (col (out "\"" col)))
(if (and col (< j (string-length obj)))
(let ((c (string-ref obj j)))
(if (or (char=? c #\\)
(char=? c #\"))
(loop j
(+ j 1)
(out "\\"
(out (substring obj i j)
col)))
(loop i (+ j 1) col)))
(out "\""
(out (substring obj i j) col))))))
((char? obj) (if display?
(out (make-string 1 obj) col)
(out (case obj
((#\space) "space")
((#\newline) "newline")
(else (make-string 1 obj)))
(out "#\\" col))))
((input-port? obj) (out "#[input-port]" col))
((output-port? obj) (out "#[output-port]" col))
((eof-object? obj) (out "#[eof-object]" col))
(else (out "#[unknown]" col))))
(define (pp obj col)
(define (spaces n col)
(if (> n 0)
(if (> n 7)
(spaces (- n 8) (out " " col))
(out (substring " " 0 n) col))
col))
(define (indent to col)
(and col
(if (< to col)
(and (out genwrite:newline-str col) (spaces to 0))
(spaces (- to col) col))))
(define (pr obj col extra pp-pair)
(if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
(let ((result '())
(left (min (+ (- (- width col) extra) 1) max-expr-width)))
(generic-write obj display? #f
(lambda (str)
(set! result (cons str result))
(set! left (- left (string-length str)))
(> left 0)))
(if (> left 0) ; all can be printed on one line
(out (reverse-string-append result) col)
(if (pair? obj)
(pp-pair obj col extra)
(pp-list (vector->list obj) (out "#" col) extra pp-expr))))
(wr obj col)))
(define (pp-expr expr col extra)
(if (read-macro? expr)
(pr (read-macro-body expr)
(out (read-macro-prefix expr) col)
extra
pp-expr)
(let ((head (car expr)))
(if (symbol? head)
(let ((proc (style head)))
(if proc
(proc expr col extra)
(if (> (string-length (symbol->string head))
max-call-head-width)
(pp-general expr col extra #f #f #f pp-expr)
(pp-call expr col extra pp-expr))))
(pp-list expr col extra pp-expr)))))
; (head item1
; item2
; item3)
(define (pp-call expr col extra pp-item)
(let ((col* (wr (car expr) (out "(" col))))
(and col
(pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
; (item1
; item2
; item3)
(define (pp-list l col extra pp-item)
(let ((col (out "(" col)))
(pp-down l col col extra pp-item)))
(define (pp-down l col1 col2 extra pp-item)
(let loop ((l l) (col col1))
(and col
(cond ((pair? l)
(let ((rest (cdr l)))
(let ((extra (if (null? rest) (+ extra 1) 0)))
(loop rest
(pr (car l) (indent col2 col) extra pp-item)))))
((null? l)
(out ")" col))
(else
(out ")"
(pr l
(indent col2 (out "." (indent col2 col)))
(+ extra 1)
pp-item)))))))
(define (pp-general expr col extra named? pp-1 pp-2 pp-3)
(define (tail1 rest col1 col2 col3)
(if (and pp-1 (pair? rest))
(let* ((val1 (car rest))
(rest (cdr rest))
(extra (if (null? rest) (+ extra 1) 0)))
(tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
(tail2 rest col1 col2 col3)))
(define (tail2 rest col1 col2 col3)
(if (and pp-2 (pair? rest))
(let* ((val1 (car rest))
(rest (cdr rest))
(extra (if (null? rest) (+ extra 1) 0)))
(tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
(tail3 rest col1 col2)))
(define (tail3 rest col1 col2)
(pp-down rest col2 col1 extra pp-3))
(let* ((head (car expr))
(rest (cdr expr))
(col* (wr head (out "(" col))))
(if (and named? (pair? rest))
(let* ((name (car rest))
(rest (cdr rest))
(col** (wr name (out " " col*))))
(tail1 rest (+ col indent-general) col** (+ col** 1)))
(tail1 rest (+ col indent-general) col* (+ col* 1)))))
(define (pp-expr-list l col extra)
(pp-list l col extra pp-expr))
(define (pp-LAMBDA expr col extra)
(pp-general expr col extra #f pp-expr-list #f pp-expr))
(define (pp-IF expr col extra)
(pp-general expr col extra #f pp-expr #f pp-expr))
(define (pp-COND expr col extra)
(pp-call expr col extra pp-expr-list))
(define (pp-CASE expr col extra)
(pp-general expr col extra #f pp-expr #f pp-expr-list))
(define (pp-AND expr col extra)
(pp-call expr col extra pp-expr))
(define (pp-LET expr col extra)
(let* ((rest (cdr expr))
(named? (and (pair? rest) (symbol? (car rest)))))
(pp-general expr col extra named? pp-expr-list #f pp-expr)))
(define (pp-BEGIN expr col extra)
(pp-general expr col extra #f #f #f pp-expr))
(define (pp-DO expr col extra)
(pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
; define formatting style (change these to suit your style)
(define indent-general 2)
(define max-call-head-width 5)
(define max-expr-width 50)
(define (style head)
(case head
((lambda let* letrec define) pp-LAMBDA)
((if set!) pp-IF)
((cond) pp-COND)
((case) pp-CASE)
((and or) pp-AND)
((let) pp-LET)
((begin) pp-BEGIN)
((do) pp-DO)
(else #f)))
(pr obj col 0 pp-expr))
(if width
(out genwrite:newline-str (pp obj 0))
(wr obj 0)))
; (reverse-string-append l) = (apply string-append (reverse l))
(define (reverse-string-append l)
(define (rev-string-append l i)
(if (pair? l)
(let* ((str (car l))
(len (string-length str))
(result (rev-string-append (cdr l) (+ i len))))
(let loop ((j 0) (k (- (- (string-length result) i) len)))
(if (< j len)
(begin
(string-set! result k (string-ref str j))
(loop (+ j 1) (+ k 1)))
result)))
(make-string i)))
(rev-string-append l 0))

80
module/slib/getopt.scm
View file

@ -1,80 +0,0 @@
;;; "getopt.scm" POSIX command argument processing
;Copyright (C) 1993, 1994 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(define getopt:scan #f)
(define getopt:char #\-)
(define getopt:opt #f)
(define *optind* 1)
(define *optarg* 0)
(define (getopt argc argv optstring)
(let ((opts (string->list optstring))
(place #f)
(arg #f)
(argref (lambda () ((if (vector? argv) vector-ref list-ref)
argv *optind*))))
(and
(cond ((and getopt:scan (not (string=? "" getopt:scan))) #t)
((>= *optind* argc) #f)
(else
(set! arg (argref))
(cond ((or (<= (string-length arg) 1)
(not (char=? (string-ref arg 0) getopt:char)))
#f)
((and (= (string-length arg) 2)
(char=? (string-ref arg 1) getopt:char))
(set! *optind* (+ *optind* 1))
#f)
(else
(set! getopt:scan
(substring arg 1 (string-length arg)))
#t))))
(begin
(set! getopt:opt (string-ref getopt:scan 0))
(set! getopt:scan
(substring getopt:scan 1 (string-length getopt:scan)))
(if (string=? "" getopt:scan) (set! *optind* (+ *optind* 1)))
(set! place (member getopt:opt opts))
(cond ((not place) #\?)
((or (null? (cdr place)) (not (char=? #\: (cadr place))))
getopt:opt)
((not (string=? "" getopt:scan))
(set! *optarg* getopt:scan)
(set! *optind* (+ *optind* 1))
(set! getopt:scan #f)
getopt:opt)
((< *optind* argc)
(set! *optarg* (argref))
(set! *optind* (+ *optind* 1))
getopt:opt)
((and (not (null? opts)) (char=? #\: (car opts))) #\:)
(else #\?))))))
(define (getopt-- argc argv optstring)
(let* ((opt (getopt argc argv (string-append optstring "-:")))
(optarg *optarg*))
(cond ((eqv? #\- opt) ;long option
(do ((l (string-length *optarg*))
(i 0 (+ 1 i)))
((or (>= i l) (char=? #\= (string-ref optarg i)))
(cond
((>= i l) (set! *optarg* #f) optarg)
(else (set! *optarg* (substring optarg (+ 1 i) l))
(substring optarg 0 i))))))
(else opt))))

213
module/slib/getparam.scm
View file

@ -1,213 +0,0 @@
;;; "getparam.scm" convert getopt to passing parameters by name.
; Copyright 1995, 1996, 1997, 2001 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'getopt)
(require 'coerce)
(define (getopt->parameter-list argc argv optnames arities types aliases
. description)
(define (can-take-arg? opt)
(not (eq? 'boolean (list-ref arities (position opt optnames)))))
(let ((progname (list-ref argv (+ -1 *optind*)))
(optlist '())
(long-opt-list '())
(optstring #f)
(pos-args '())
(parameter-list (make-parameter-list optnames))
(curopt '*unclaimed-argument*)
(positional? (assv 0 aliases))
(unclaimeds '()))
(define (adjoin-val val curopt)
(define ntyp (list-ref types (position curopt optnames)))
(adjoin-parameters! parameter-list
(list curopt (case ntyp
((expression) val)
(else (coerce val ntyp))))))
(define (finish)
(cond
(positional?
(set! unclaimeds (reverse unclaimeds))
(do ((idx 2 (+ 1 idx))
(alias+ (assv 1 aliases) (assv idx aliases))
(alias- (assv -1 aliases) (assv (- idx) aliases)))
((or (not (or alias+ alias-)) (null? unclaimeds)))
(set! unclaimeds (reverse unclaimeds))
(cond (alias-
(set! curopt (cadr alias-))
(adjoin-val (car unclaimeds) curopt)
(set! unclaimeds (cdr unclaimeds))))
(set! unclaimeds (reverse unclaimeds))
(cond ((and alias+ (not (null? unclaimeds)))
(set! curopt (cadr alias+))
(adjoin-val (car unclaimeds) curopt)
(set! unclaimeds (cdr unclaimeds)))))
(let ((alias (assv '0 aliases)))
(cond (alias
(set! curopt (cadr alias))
(for-each (lambda (unc) (adjoin-val unc curopt)) unclaimeds)
(set! unclaimeds '()))))))
(cond ((not (null? unclaimeds))
(slib:warn 'getopt->parameter-list 'arguments 'unclaimed unclaimeds)
(apply parameter-list->getopt-usage
progname optnames arities types aliases description))
(else parameter-list)))
(set! aliases
(map (lambda (alias)
(cond ((string? (car alias))
(let ((str (string-copy (car alias))))
(do ((i (+ -1 (string-length str)) (+ -1 i)))
((negative? i) (cons str (cdr alias)))
(cond ((char=? #\ (string-ref str i))
(string-set! str i #\-))))))
((number? (car alias))
(set! positional? (car alias))
alias)
(else alias)))
aliases))
(for-each
(lambda (alias)
(define opt (car alias))
(cond ((number? opt) (set! pos-args (cons opt pos-args)))
((not (string? opt)))
((< 1 (string-length opt))
(set! long-opt-list (cons opt long-opt-list)))
((not (= 1 (string-length opt))))
((can-take-arg? (cadr alias))
(set! optlist (cons (string-ref opt 0) (cons #\: optlist))))
(else (set! optlist (cons (string-ref opt 0) optlist)))))
aliases)
(set! optstring (list->string (cons #\: optlist)))
(let loop ()
(let ((opt (getopt-- argc argv optstring)))
(case opt
((#\: #\?)
(slib:warn 'getopt->parameter-list
(case opt
((#\:) "argument missing after")
((#\?) "unrecognized option"))
(string #\- getopt:opt))
(apply parameter-list->getopt-usage
progname optnames arities types aliases description))
((#f)
(cond ((and (< *optind* argc)
(string=? "-" (list-ref argv *optind*)))
(set! *optind* (+ 1 *optind*))
(finish))
((< *optind* argc)
(let ((topt (assoc curopt aliases)))
(if topt (set! curopt (cadr topt)))
(cond
((and positional? (not topt))
(set! unclaimeds
(cons (list-ref argv *optind*) unclaimeds))
(set! *optind* (+ 1 *optind*)) (loop))
((and (member curopt optnames)
(adjoin-val (list-ref argv *optind*) curopt))
(set! *optind* (+ 1 *optind*)) (loop))
(else (slib:error 'getopt->parameter-list curopt
(list-ref argv *optind*)
'not 'supported)))))
(else (finish))))
(else
(cond ((char? opt) (set! opt (string opt))))
(let ((topt (assoc opt aliases)))
(if topt (set! topt (cadr topt)))
(cond
((not topt)
(slib:warn "Option not recognized -" opt)
(apply parameter-list->getopt-usage
progname optnames arities types aliases description))
((not (can-take-arg? topt))
(adjoin-parameters! parameter-list (list topt #t))
(loop))
(*optarg* (set! curopt topt) (adjoin-val *optarg* curopt) (loop))
(else
;;; (slib:warn 'getopt->parameter-list "= missing for option--" opt)
(set! curopt topt) (loop))))))))))
(define (parameter-list->getopt-usage comname optnames arities types aliases
. description)
(require 'printf)
(require 'common-list-functions)
(let ((aliast (map list optnames))
(strlen=1? (lambda (s) (= 1 (string-length s))))
(cep (current-error-port)))
(for-each (lambda (alias)
(let ((apr (assq (cadr alias) aliast)))
(set-cdr! apr (cons (car alias) (cdr apr)))))
aliases)
(fprintf cep "Usage: %s [OPTION ARGUMENT ...] ..." comname)
(do ((pos+ '()) (pos- '())
(idx 2 (+ 1 idx))
(alias+ (assv 1 aliases) (assv idx aliases))
(alias- (assv -1 aliases) (assv (- idx) aliases)))
((not (or alias+ alias-))
(for-each (lambda (alias) (fprintf cep " <%s>" (cadr alias)))
(reverse pos+))
(let ((alias (assv 0 aliases)))
(if alias (fprintf cep " <%s> ..." (cadr alias))))
(for-each (lambda (alias) (fprintf cep " <%s>" (cadr alias)))
pos-))
(cond (alias- (set! pos- (cons alias- pos-))))
(cond (alias+ (set! pos+ (cons alias+ pos+)))))
(fprintf cep "\\n\\n")
(for-each
(lambda (optname arity aliat)
(let loop ((initials (remove-if-not strlen=1? (remove-if number? (cdr aliat))))
(longname (remove-if strlen=1? (remove-if number? (cdr aliat)))))
(cond ((and (null? initials) (null? longname)))
(else (fprintf cep
(case arity
((boolean) " %3s %s\\n")
(else " %3s %s<%s> %s\\n"))
(if (null? initials)
""
(string-append "-" (car initials)
(if (null? longname) " " ",")))
(if (null? longname)
" "
(string-append "--" (car longname)
(case arity
((boolean) " ")
(else "="))))
(case arity
((boolean) "")
(else optname))
(case arity
((nary nary1) "...")
(else "")))
(loop (if (null? initials) '() (cdr initials))
(if (null? longname) '() (cdr longname)))))))
optnames arities aliast)
(for-each (lambda (desc) (fprintf cep " %s\\n" desc)) description))
#f)
(define (getopt->arglist argc argv optnames positions
arities types defaulters checks aliases . description)
(define progname (list-ref argv (+ -1 *optind*)))
(let* ((params (apply getopt->parameter-list
argc argv optnames arities types aliases description))
(fparams (and params (fill-empty-parameters defaulters params))))
(cond ((and (list? params)
(check-parameters checks fparams)
(parameter-list->arglist positions arities fparams)))
(params (apply parameter-list->getopt-usage
progname optnames arities types aliases description))
(else #f))))

227
module/slib/glob.scm
View file

@ -1,227 +0,0 @@
;;; "glob.scm" String matching for filenames (a la BASH).
;;; Copyright (C) 1998 Radey Shouman.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;;$Header: /home/ludo/src/guile/gitification/guile-cvs/guile/guile/guile-vm/module/slib/glob.scm,v 1.1 2001/04/14 11:24:45 kei Exp $
;;$Name: $
(define (glob:pattern->tokens pat)
(cond
((string? pat)
(let loop ((i 0)
(toks '()))
(if (>= i (string-length pat))
(reverse toks)
(let ((pch (string-ref pat i)))
(case pch
((#\? #\*)
(loop (+ i 1)
(cons (substring pat i (+ i 1)) toks)))
((#\[)
(let ((j
(let search ((j (+ i 2)))
(cond
((>= j (string-length pat))
(slib:error 'glob:make-matcher
"unmatched [" pat))
((char=? #\] (string-ref pat j))
(if (and (< (+ j 1) (string-length pat))
(char=? #\] (string-ref pat (+ j 1))))
(+ j 1)
j))
(else (search (+ j 1)))))))
(loop (+ j 1) (cons (substring pat i (+ j 1)) toks))))
(else
(let search ((j (+ i 1)))
(cond ((= j (string-length pat))
(loop j (cons (substring pat i j) toks)))
((memv (string-ref pat j) '(#\? #\* #\[))
(loop j (cons (substring pat i j) toks)))
(else (search (+ j 1)))))))))))
((pair? pat)
(for-each (lambda (elt) (or (string? elt)
(slib:error 'glob:pattern->tokens
"bad pattern" pat)))
pat)
pat)
(else (slib:error 'glob:pattern->tokens "bad pattern" pat))))
(define (glob:make-matcher pat ch=? ch<=?)
(define (match-end str k kmatch)
(and (= k (string-length str)) (reverse (cons k kmatch))))
(define (match-str pstr nxt)
(let ((plen (string-length pstr)))
(lambda (str k kmatch)
(and (<= (+ k plen) (string-length str))
(let loop ((i 0))
(cond ((= i plen)
(nxt str (+ k plen) (cons k kmatch)))
((ch=? (string-ref pstr i)
(string-ref str (+ k i)))
(loop (+ i 1)))
(else #f)))))))
(define (match-? nxt)
(lambda (str k kmatch)
(and (< k (string-length str))
(nxt str (+ k 1) (cons k kmatch)))))
(define (match-set1 chrs)
(let recur ((i 0))
(cond ((= i (string-length chrs))
(lambda (ch) #f))
((and (< (+ i 2) (string-length chrs))
(char=? #\- (string-ref chrs (+ i 1))))
(let ((nxt (recur (+ i 3))))
(lambda (ch)
(or (and (ch<=? ch (string-ref chrs (+ i 2)))
(ch<=? (string-ref chrs i) ch))
(nxt ch)))))
(else
(let ((nxt (recur (+ i 1)))
(chrsi (string-ref chrs i)))
(lambda (ch)
(or (ch=? chrsi ch) (nxt ch))))))))
(define (match-set tok nxt)
(let ((chrs (substring tok 1 (- (string-length tok) 1))))
(if (and (positive? (string-length chrs))
(memv (string-ref chrs 0) '(#\^ #\!)))
(let ((pred (match-set1 (substring chrs 1 (string-length chrs)))))
(lambda (str k kmatch)
(and (< k (string-length str))
(not (pred (string-ref str k)))
(nxt str (+ k 1) (cons k kmatch)))))
(let ((pred (match-set1 chrs)))
(lambda (str k kmatch)
(and (< k (string-length str))
(pred (string-ref str k))
(nxt str (+ k 1) (cons k kmatch))))))))
(define (match-* nxt)
(lambda (str k kmatch)
(let ((kmatch (cons k kmatch)))
(let loop ((kk (string-length str)))
(and (>= kk k)
(or (nxt str kk kmatch)
(loop (- kk 1))))))))
(let ((matcher
(let recur ((toks (glob:pattern->tokens pat)))
(if (null? toks)
match-end
(let ((pch (or (string=? (car toks) "")
(string-ref (car toks) 0))))
(case pch
((#\?) (match-? (recur (cdr toks))))
((#\*) (match-* (recur (cdr toks))))
((#\[) (match-set (car toks) (recur (cdr toks))))
(else (match-str (car toks) (recur (cdr toks))))))))))
(lambda (str) (matcher str 0 '()))))
(define (glob:caller-with-matches pat proc ch=? ch<=?)
(define (glob:wildcard? pat)
(cond ((string=? pat "") #f)
((memv (string-ref pat 0) '(#\* #\? #\[)) #t)
(else #f)))
(let* ((toks (glob:pattern->tokens pat))
(wild? (map glob:wildcard? toks))
(matcher (glob:make-matcher toks ch=? ch<=?)))
(lambda (str)
(let loop ((inds (matcher str))
(wild? wild?)
(res '()))
(cond ((not inds) #f)
((null? wild?)
(apply proc (reverse res)))
((car wild?)
(loop (cdr inds)
(cdr wild?)
(cons (substring str (car inds) (cadr inds)) res)))
(else
(loop (cdr inds) (cdr wild?) res)))))))
(define (glob:make-substituter pattern template ch=? ch<=?)
(define (wildcard? pat)
(cond ((string=? pat "") #f)
((memv (string-ref pat 0) '(#\* #\? #\[)) #t)
(else #f)))
(define (countq val lst)
(do ((lst lst (cdr lst))
(c 0 (if (eq? val (car lst)) (+ c 1) c)))
((null? lst) c)))
(let ((tmpl-literals (map (lambda (tok)
(if (wildcard? tok) #f tok))
(glob:pattern->tokens template)))
(pat-wild? (map wildcard? (glob:pattern->tokens pattern)))
(matcher (glob:make-matcher pattern ch=? ch<=?)))
(or (= (countq #t pat-wild?) (countq #f tmpl-literals))
(slib:error 'glob:make-substituter
"number of wildcards doesn't match" pattern template))
(lambda (str)
(let ((indices (matcher str)))
(and indices
(let loop ((inds indices)
(wild? pat-wild?)
(lits tmpl-literals)
(res '()))
(cond
((null? lits)
(apply string-append (reverse res)))
((car lits)
(loop inds wild? (cdr lits) (cons (car lits) res)))
((null? wild?) ;this should never happen.
(loop '() '() lits res))
((car wild?)
(loop (cdr inds) (cdr wild?) (cdr lits)
(cons (substring str (car inds) (cadr inds))
res)))
(else
(loop (cdr inds) (cdr wild?) lits res)))))))))
(define (glob:match?? pat)
(glob:make-matcher pat char=? char<=?))
(define (glob:match-ci?? pat)
(glob:make-matcher pat char-ci=? char-ci<=?))
(define filename:match?? glob:match??)
(define filename:match-ci?? glob:match-ci??)
(define (glob:substitute?? pat templ)
(cond ((procedure? templ)
(glob:caller-with-matches pat templ char=? char<=?))
((string? templ)
(glob:make-substituter pat templ char=? char<=?))
(else
(slib:error 'glob:substitute "bad second argument" templ))))
(define (glob:substitute-ci?? pat templ)
(cond ((procedure? templ)
(glob:caller-with-matches pat templ char-ci=? char-ci<=?))
((string? templ)
(glob:make-substituter pat templ char-ci=? char-ci<=?))
(else
(slib:error 'glob:substitute "bad second argument" templ))))
(define filename:substitute?? glob:substitute??)
(define filename:substitute-ci?? glob:substitute-ci??)
(define (replace-suffix str old new)
(let* ((f (glob:make-substituter (list "*" old) (list "*" new)
char=? char<=?))
(g (lambda (st)
(or (f st)
(slib:error 'replace-suffix "suffix doesn't match:"
old st)))))
(if (pair? str)
(map g str)
(g str))))

232
module/slib/guile.init
View file

@ -1,232 +0,0 @@
;;; "guile.init" configuration template of *features* for Scheme -*-scheme-*-
;;; Author: Aubrey Jaffer
;;;
;;; This code is in the public domain.
;;; (software-type) should be set to the generic operating system type.
;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
(define (software-type) 'UNIX)
;;; (scheme-implementation-type) should return the name of the scheme
;;; implementation loading this file.
(define (scheme-implementation-type) 'Guile)
;;; (scheme-implementation-home-page) should return a (string) URI
;;; (Uniform Resource Identifier) for this scheme implementation's home
;;; page; or false if there isn't one.
(define (scheme-implementation-home-page) "http://www.gnu.org/software/guile/")
;;; (scheme-implementation-version) should return a string describing
;;; the version the scheme implementation loading this file.
(define scheme-implementation-version version)
;;; (implementation-vicinity) should be defined to be the pathname of
;;; the directory where any auxillary files to your Scheme
;;; implementation reside.
(define implementation-vicinity
(let ((path (string-append (%package-data-dir) "/")))
(lambda () path)))
;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
(define library-vicinity
(let ((library-path
(or
;; Use this getenv if your implementation supports it.
(getenv "SCHEME_LIBRARY_PATH")
;; Use this path if your scheme does not support GETENV
;; or if SCHEME_LIBRARY_PATH is not set.
(let ((this-file (port-filename (current-load-port))))
(substring this-file 0 (- (string-length this-file) 10))))))
(lambda () library-path)))
;;; (home-vicinity) should return the vicinity of the user's HOME
;;; directory, the directory which typically contains files which
;;; customize a computer environment for a user.
(define home-vicinity
(let ((home-path (getenv "HOME")))
(lambda () home-path)))
;;; *FEATURES* should be set to a list of symbols describing features
;;; of this implementation. Suggestions for features are:
(define *features*
'(
source ;can load scheme source files
;(slib:load-source "filename")
compiled ;can load compiled files
;(slib:load-compiled "filename")
rev4-report ;conforms to
rev3-report ;conforms to
ieee-p1178 ;conforms to
; sicp ;runs code from Structure and
;Interpretation of Computer
;Programs by Abelson and Sussman.
rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
;LIST->STRING, STRING-COPY,
;STRING-FILL!, LIST->VECTOR,
;VECTOR->LIST, and VECTOR-FILL!
rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
;SUBSTRING-FILL!,
;STRING-NULL?, APPEND!, 1+,
;-1+, <?, <=?, =?, >?, >=?
multiarg/and- ;/ and - can take more than 2 args.
multiarg-apply ;APPLY can take more than 2 args.
; rationalize
delay ;has DELAY and FORCE
with-file ;has WITH-INPUT-FROM-FILE and
;WITH-OUTPUT-FROM-FILE
string-port ;has CALL-WITH-INPUT-STRING and
;CALL-WITH-OUTPUT-STRING
; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
char-ready?
; macro ;has R4RS high level macros
; macro-by-example
defmacro ;has Common Lisp DEFMACRO
eval ;R5RS two-argument eval
record ;has user defined data structures
values ;proposed multiple values
dynamic-wind ;proposed dynamic-wind
ieee-floating-point ;conforms to
full-continuation ;can return multiple times
; object-hash ;has OBJECT-HASH
sort
; queue ;queues
; pretty-print
object->string
; format
; trace ;has macros: TRACE and UNTRACE
; compiler ;has (COMPILER)
; ed ;(ED) is editor
system ;posix (system <string>)
getenv ;posix (getenv <string>)
program-arguments ;returns list of strings (argv)
; Xwindows ;X support
; curses ;screen management package
; termcap ;terminal description package
; terminfo ;sysV terminal description
current-time ;returns time in seconds since 1/1/1970
abort
array
array-for-each
random
hash
hash-table
line-i/o
logical
promise
string-case
; syntax-case
))
;; time
(define difftime -)
(define offset-time +)
;; random
(define (make-random-state . args)
(let ((seed (if (null? args) *random-state* (car args))))
(cond ((string? seed))
((number? seed) (set! seed (number->string seed)))
(else (let ()
(require 'object->string)
(set! seed (object->limited-string seed 50)))))
(seed->random-state seed)))
;;; (OUTPUT-PORT-WIDTH <port>)
(define (output-port-width . arg) 79)
;;; (OUTPUT-PORT-HEIGHT <port>)
(define (output-port-height . arg) 24)
;;; "rationalize" adjunct procedures.
;;(define (find-ratio x e)
;; (let ((rat (rationalize x e)))
;; (list (numerator rat) (denominator rat))))
;;(define (find-ratio-between x y)
;; (find-ratio (/ (+ x y) 2) (/ (- x y) 2)))
;;; Return argument
(define (identity x) x)
;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
(define (slib:eval x)
(eval x (interaction-environment)))
(define base:eval slib:eval)
(define (defmacro:eval x) (base:eval (defmacro:expand* x)))
(define (defmacro:expand* x)
(require 'defmacroexpand) (apply defmacro:expand* x '()))
(define (slib:eval-load <pathname> evl)
(if (not (file-exists? <pathname>))
(set! <pathname> (string-append <pathname> (scheme-file-suffix))))
(call-with-input-file <pathname>
(lambda (port)
(let ((old-load-pathname *load-pathname*))
(set! *load-pathname* <pathname>)
(do ((o (read port) (read port)))
((eof-object? o))
(evl o))
(set! *load-pathname* old-load-pathname)))))
(define (defmacro:load <pathname>)
(slib:eval-load <pathname> defmacro:eval))
(define slib:warn
(lambda args
(let ((cep (current-error-port)))
(if (provided? 'trace) (print-call-stack cep))
(display "Warn: " cep)
(for-each (lambda (x) (display x cep)) args))))
;;; define an error procedure for the library
(define (slib:error . args)
(if (provided? 'trace) (print-call-stack (current-error-port)))
(apply error args))
;;; define these as appropriate for your system.
(define slib:tab (integer->char 9))
(define slib:form-feed (integer->char 12))
;;; Support for older versions of Scheme. Not enough code for its own file.
(define t #t)
(define nil #f)
;;; Define SLIB:EXIT to be the implementation procedure to exit or
;;; return if exitting not supported.
(define slib:exit quit)
;;; Here for backward compatability
(define scheme-file-suffix
(let ((suffix (case (software-type)
((NOSVE) "_scm")
(else ".scm"))))
(lambda () suffix)))
;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
;;; suffix all the module files in SLIB have. See feature 'SOURCE.
(define (slib:load-source f) (load (string-append f (scheme-file-suffix))))
;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
;;; by compiling "foo.scm" if this implementation can compile files.
;;; See feature 'COMPILED.
(define (slib:load-compiled f) (load-compiled-file (string-append f ".go")))
;;; At this point SLIB:LOAD must be able to load SLIB files.
(define slib:load slib:load)
(slib:load (in-vicinity (library-vicinity) "require"))

153
module/slib/hash.scm
View file

@ -1,153 +0,0 @@
; "hash.scm", hashing functions for Scheme.
; Copyright (c) 1992, 1993, 1995 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(define (hash:hash-char-ci char n)
(modulo (char->integer (char-downcase char)) n))
(define hash:hash-char hash:hash-char-ci)
(define (hash:hash-symbol sym n)
(hash:hash-string (symbol->string sym) n))
;;; This can overflow on implemenatations where inexacts have a larger
;;; range than exact integers.
(define hash:hash-number
(if (provided? 'inexact)
(lambda (num n)
(if (integer? num)
(modulo (if (exact? num) num (inexact->exact num)) n)
(hash:hash-string-ci
(number->string (if (exact? num) (exact->inexact num) num))
n)))
(lambda (num n)
(if (integer? num)
(modulo num n)
(hash:hash-string-ci (number->string num) n)))))
(define (hash:hash-string-ci str n)
(let ((len (string-length str)))
(if (> len 5)
(let loop ((h (modulo 264 n)) (i 5))
(if (positive? i)
(loop (modulo (+ (* h 256)
(char->integer
(char-downcase
(string-ref str (modulo h len)))))
n)
(- i 1))
h))
(let loop ((h 0) (i (- len 1)))
(if (>= i 0)
(loop (modulo (+ (* h 256)
(char->integer
(char-downcase (string-ref str i))))
n)
(- i 1))
h)))))
(define hash:hash-string hash:hash-string-ci)
(define (hash:hash obj n)
(let hs ((d 10) (obj obj))
(cond
((number? obj) (hash:hash-number obj n))
((char? obj) (modulo (char->integer (char-downcase obj)) n))
((symbol? obj) (hash:hash-symbol obj n))
((string? obj) (hash:hash-string obj n))
((vector? obj)
(let ((len (vector-length obj)))
(if (> len 5)
(let lp ((h 1) (i (quotient d 2)))
(if (positive? i)
(lp (modulo (+ (* h 256)
(hs 2 (vector-ref obj (modulo h len))))
n)
(- i 1))
h))
(let loop ((h (- n 1)) (i (- len 1)))
(if (>= i 0)
(loop (modulo (+ (* h 256) (hs (quotient d len)
(vector-ref obj i)))
n)
(- i 1))
h)))))
((pair? obj)
(if (positive? d) (modulo (+ (hs (quotient d 2) (car obj))
(hs (quotient d 2) (cdr obj)))
n)
1))
(else
(modulo
(cond
((null? obj) 256)
((boolean? obj) (if obj 257 258))
((eof-object? obj) 259)
((input-port? obj) 260)
((output-port? obj) 261)
((procedure? obj) 262)
((and (provided? 'RECORD) (record? obj))
(let* ((rtd (record-type-descriptor obj))
(fns (record-type-field-names rtd))
(len (length fns)))
(if (> len 5)
(let lp ((h (modulo 266 n)) (i (quotient d 2)))
(if (positive? i)
(lp (modulo
(+ (* h 256)
(hs 2 ((record-accessor
rtd (list-ref fns (modulo h len)))
obj)))
n)
(- i 1))
h))
(let loop ((h (- n 1)) (i (- len 1)))
(if (>= i 0)
(loop (modulo
(+ (* h 256)
(hs (quotient d len)
((record-accessor
rtd (list-ref fns (modulo h len)))
obj)))
n)
(- i 1))
h)))))
(else 263))
n)))))
(define hash hash:hash)
(define hashv hash:hash)
;;; Object-hash is somewhat expensive on copying GC systems (like
;;; PC-Scheme and MITScheme). We use it only on strings, pairs,
;;; vectors, and records. This also allows us to use it for both
;;; hashq and hashv.
(if (provided? 'object-hash)
(set! hashv
(if (provided? 'record)
(lambda (obj k)
(if (or (string? obj) (pair? obj) (vector? obj) (record? obj))
(modulo (object-hash obj) k)
(hash:hash obj k)))
(lambda (obj k)
(if (or (string? obj) (pair? obj) (vector? obj))
(modulo (object-hash obj) k)
(hash:hash obj k))))))
(define hashq hashv)

79
module/slib/hashtab.scm
View file

@ -1,79 +0,0 @@
; "hashtab.scm", hash tables for Scheme.
; Copyright (c) 1992, 1993 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'hash)
(require 'alist)
(define (predicate->hash pred)
(cond ((eq? pred eq?) hashq)
((eq? pred eqv?) hashv)
((eq? pred equal?) hash)
((eq? pred =) hashv)
((eq? pred char=?) hashv)
((eq? pred char-ci=?) hashv)
((eq? pred string=?) hash)
((eq? pred string-ci=?) hash)
(else (slib:error "unknown predicate for hash" pred))))
(define (make-hash-table k) (make-vector k '()))
(define (predicate->hash-asso pred)
(let ((hashfun (predicate->hash pred))
(asso (predicate->asso pred)))
(lambda (key hashtab)
(asso key
(vector-ref hashtab (hashfun key (vector-length hashtab)))))))
(define (hash-inquirer pred)
(let ((hashfun (predicate->hash pred))
(ainq (alist-inquirer pred)))
(lambda (hashtab key)
(ainq (vector-ref hashtab (hashfun key (vector-length hashtab)))
key))))
(define (hash-associator pred)
(let ((hashfun (predicate->hash pred))
(asso (alist-associator pred)))
(lambda (hashtab key val)
(let* ((num (hashfun key (vector-length hashtab))))
(vector-set! hashtab num
(asso (vector-ref hashtab num) key val)))
hashtab)))
(define (hash-remover pred)
(let ((hashfun (predicate->hash pred))
(arem (alist-remover pred)))
(lambda (hashtab key)
(let* ((num (hashfun key (vector-length hashtab))))
(vector-set! hashtab num
(arem (vector-ref hashtab num) key)))
hashtab)))
(define (hash-map proc ht)
(define nht (make-vector (vector-length ht)))
(do ((i (+ -1 (vector-length ht)) (+ -1 i)))
((negative? i) nht)
(vector-set!
nht i
(alist-map proc (vector-ref ht i)))))
(define (hash-for-each proc ht)
(do ((i (+ -1 (vector-length ht)) (+ -1 i)))
((negative? i))
(alist-for-each proc (vector-ref ht i))))

448
module/slib/htmlform.scm
View file

@ -1,448 +0,0 @@
;;; "htmlform.scm" Generate HTML 2.0 forms. -*-scheme-*-
; Copyright 1997, 1998, 2000, 2001 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'sort)
(require 'printf)
(require 'parameters)
(require 'object->string)
(require 'string-search)
(require 'database-utilities)
(require 'common-list-functions)
;;;;@code{(require 'html-form)}
(define html:blank (string->symbol ""))
;;@body Returns a string with character substitutions appropriate to
;;send @1 as an @dfn{attribute-value}.
(define (html:atval txt) ; attribute-value
(if (symbol? txt) (set! txt (symbol->string txt)))
(if (number? txt)
(number->string txt)
(string-subst (if (string? txt) txt (object->string txt))
"&" "&amp;"
"\"" "&quot;"
"<" "&lt;"
">" "&gt;")))
;;@body Returns a string with character substitutions appropriate to
;;send @1 as an @dfn{plain-text}.
(define (html:plain txt) ; plain-text `Data Characters'
(cond ((eq? html:blank txt) "&nbsp;")
(else
(if (symbol? txt) (set! txt (symbol->string txt)))
(if (number? txt)
(number->string txt)
(string-subst (if (string? txt) txt (object->string txt))
"&" "&amp;"
"<" "&lt;"
">" "&gt;")))))
;;@body Returns a tag of meta-information suitable for passing as the
;;third argument to @code{html:head}. The tag produced is @samp{<META
;;NAME="@1" CONTENT="@2">}. The string or symbol @1 can be
;;@samp{author}, @samp{copyright}, @samp{keywords}, @samp{description},
;;@samp{date}, @samp{robots}, @dots{}.
(define (html:meta name content)
(sprintf #f "\n<META NAME=\"%s\" CONTENT=\"%s\">" name (html:atval content)))
;;@body Returns a tag of HTTP information suitable for passing as the
;;third argument to @code{html:head}. The tag produced is @samp{<META
;;HTTP-EQUIV="@1" CONTENT="@2">}. The string or symbol @1 can be
;;@samp{Expires}, @samp{PICS-Label}, @samp{Content-Type},
;;@samp{Refresh}, @dots{}.
(define (html:http-equiv name content)
(sprintf #f "\n<META HTTP-EQUIV=\"%s\" CONTENT=\"%s\">"
name (html:atval content)))
;;@args delay uri
;;@args delay
;;
;;Returns a tag suitable for passing as the third argument to
;;@code{html:head}. If @2 argument is supplied, then @1 seconds after
;;displaying the page with this tag, Netscape or IE browsers will fetch
;;and display @2. Otherwise, @1 seconds after displaying the page with
;;this tag, Netscape or IE browsers will fetch and redisplay this page.
(define (html:meta-refresh delay . uri)
(if (null? uri)
(sprintf #f "\n<META HTTP-EQUIV=\"Refresh\" CONTENT=\"%d\">" delay)
(sprintf #f "\n<META HTTP-EQUIV=\"Refresh\" CONTENT=\"%d;URL=%s\">"
delay (car uri))))
;;@args title backlink tags ...
;;@args title backlink
;;@args title
;;
;;Returns header string for an HTML page named @1. If @2 is a string,
;;it is used verbatim between the @samp{H1} tags; otherwise @1 is
;;used. If string arguments @3 ... are supplied, then they are
;;included verbatim within the @t{<HEAD>} section.
(define (html:head title . args)
(define backlink (if (null? args) #f (car args)))
(if (not (null? args)) (set! args (cdr args)))
(string-append
(sprintf #f "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">\\n")
(sprintf #f "<HTML>\\n")
(sprintf #f "%s"
(html:comment "HTML by SLIB"
"http://swissnet.ai.mit.edu/~jaffer/SLIB.html"))
(sprintf #f " <HEAD>\\n <TITLE>%s</TITLE>\\n %s\\n </HEAD>\\n"
(html:plain title) (apply string-append args))
(sprintf #f "<BODY><H1>%s</H1>\\n" (or backlink (html:plain title)))))
;;@body Returns HTML string to end a page.
(define (html:body . body)
(apply string-append
(append body (list (sprintf #f "</BODY>\\n</HTML>\\n")))))
;;@body Returns the strings @1, @2 as @dfn{PRE}formmated plain text
;;(rendered in fixed-width font). Newlines are inserted between @1,
;;@2. HTML tags (@samp{<tag>}) within @2 will be visible verbatim.
(define (html:pre line1 . lines)
(sprintf #f "<PRE>\\n%s%s</PRE>"
(html:plain line1)
(string-append
(apply string-append
(map (lambda (line) (sprintf #f "\\n%s" (html:plain line)))
lines)))))
;;@body Returns the strings @1 as HTML comments.
(define (html:comment line1 . lines)
(string-append
(apply string-append
(if (substring? "--" line1)
(slib:error 'html:comment "line contains --" line1)
(sprintf #f "<!--%s--" line1))
(map (lambda (line)
(if (substring? "--" line)
(slib:error 'html:comment "line contains --" line)
(sprintf #f "\\n --%s--" line)))
lines))
(sprintf #f ">\\n")))
(define (html:strong-doc name doc)
(set! name (if name (html:plain name) ""))
(set! doc (if doc (html:plain doc) ""))
(if (equal? "" doc)
(if (equal? "" name)
""
(sprintf #f "<STRONG>%s</STRONG>" (html:plain name)))
(sprintf #f "<STRONG>%s</STRONG> (%s)"
(html:plain name) (html:plain doc))))
;;@section HTML Forms
;;@body The symbol @1 is either @code{get}, @code{head}, @code{post},
;;@code{put}, or @code{delete}. The strings @3 form the body of the
;;form. @0 returns the HTML @dfn{form}.
(define (html:form method action . body)
(cond ((not (memq method '(get head post put delete)))
(slib:error 'html:form "method unknown:" method)))
(string-append
(apply string-append
(sprintf #f "<FORM METHOD=%#a ACTION=%#a>\\n"
(html:atval method) (html:atval action))
body)
(sprintf #f "</FORM>\\n")))
;;@body Returns HTML string which will cause @1=@2 in form.
(define (html:hidden name value)
(sprintf #f "<INPUT TYPE=HIDDEN NAME=%#a VALUE=%#a>"
(html:atval name) (html:atval value)))
;;@body Returns HTML string for check box.
(define (html:checkbox pname default)
(sprintf #f "<INPUT TYPE=CHECKBOX NAME=%#a %s>"
(html:atval pname)
(if default "CHECKED" "")))
;;@body Returns HTML string for one-line text box.
(define (html:text pname default . size)
(set! size (if (null? size) #f (car size)))
(cond (default
(sprintf #f "<INPUT NAME=%#a SIZE=%d VALUE=%#a>"
(html:atval pname)
(or size
(max 5
(min 20 (string-length
(if (symbol? default)
(symbol->string default) default)))))
(html:atval default)))
(size (sprintf #f "<INPUT NAME=%#a SIZE=%d>" (html:atval pname) size))
(else (sprintf #f "<INPUT NAME=%#a>" (html:atval pname)))))
;;@body Returns HTML string for multi-line text box.
(define (html:text-area pname default-list)
(set! default-list (map (lambda (d) (sprintf #f "%a" d)) default-list))
(string-append
(sprintf #f "<TEXTAREA NAME=%#a ROWS=%d COLS=%d>\\n"
(html:atval pname) (max 1 (length default-list))
(min 32 (apply max 5 (map string-length default-list))))
(let* ((str (apply string-append
(map (lambda (line)
(sprintf #f "%s\\n" (html:plain line)))
default-list)))
(len (+ -1 (string-length str))))
(if (positive? len) (substring str 0 len) str))
(sprintf #f "</TEXTAREA>\\n")))
(define (html:s<? s1 s2)
(if (and (number? s1) (number? s2))
(< s1 s2)
(string<? (if (symbol? s1) (symbol->string s1) s1)
(if (symbol? s2) (symbol->string s2) s2))))
(define (by-car proc)
(lambda (s1 s2) (proc (car s1) (car s2))))
;;@body Returns HTML string for pull-down menu selector.
(define (html:select pname arity default-list foreign-values)
(set! foreign-values (sort foreign-values (by-car html:s<?)))
(let ((value-list (map car foreign-values))
(visibles (map cadr foreign-values)))
(string-append
(sprintf #f "<SELECT NAME=%#a SIZE=%d%s>"
(html:atval pname)
(case arity
((single optional) 1)
((nary nary1) 5))
(case arity
((nary nary1) " MULTIPLE")
(else "")))
(apply string-append
(map (lambda (value visible)
(sprintf #f "<OPTION VALUE=%#a%s>%s"
(html:atval value)
(if (member value default-list) " SELECTED" "")
(html:plain visible)))
(case arity
((optional nary) (cons html:blank value-list))
(else value-list))
(case arity
((optional nary) (cons html:blank visibles))
(else visibles))))
(sprintf #f "</SELECT>"))))
;;@body Returns HTML string for any-of selector.
(define (html:buttons pname arity default-list foreign-values)
(set! foreign-values (sort foreign-values (by-car html:s<?)))
(let ((value-list (map car foreign-values))
(visibles (map cadr foreign-values)))
(string-append
(sprintf #f "<MENU>")
(case arity
((single optional)
(apply
string-append
(map (lambda (value visible)
(sprintf #f
"<LI><INPUT TYPE=RADIO NAME=%#a VALUE=%#a%s> %s\\n"
(html:atval pname) (html:atval value)
(if (member value default-list) " CHECKED" "")
(html:plain visible)))
value-list
visibles)))
((nary nary1)
(apply
string-append
(map (lambda (value visible)
(sprintf #f
"<LI><INPUT TYPE=CHECKBOX NAME=%#a VALUE=%#a%s> %s\\n"
(html:atval pname) (html:atval value)
(if (member value default-list) " CHECKED" "")
(html:plain visible)))
value-list
visibles))))
(sprintf #f "</MENU>"))))
;;@args submit-label command
;;@args submit-label
;;
;;The string or symbol @1 appears on the button which submits the form.
;;If the optional second argument @2 is given, then @code{*command*=@2}
;;and @code{*button*=@1} are set in the query. Otherwise,
;;@code{*command*=@1} is set in the query.
(define (form:submit submit-label . command)
(if (null? command)
(sprintf #f "<INPUT TYPE=SUBMIT NAME=%#a VALUE=%#a>"
(html:atval '*command*)
(html:atval submit-label))
(sprintf #f "%s<INPUT TYPE=SUBMIT NAME=%#a VALUE=%#a>"
(html:hidden '*command* (car command))
(html:atval '*button*)
(html:atval submit-label))))
;;@body The @2 appears on the button which submits the form.
(define (form:image submit-label image-src)
(sprintf #f "<INPUT TYPE=IMAGE NAME=%#a SRC=%#a>"
(html:atval submit-label)
(html:atval image-src)))
;;@body Returns a string which generates a @dfn{reset} button.
(define (form:reset) "<INPUT TYPE=RESET>")
(define (html:delimited-list . rows)
(apply string-append
"<DL>"
(append rows '("</DL>"))))
;;@body Returns a string which generates an INPUT element for the field
;;named @1. The element appears in the created form with its
;;representation determined by its @2 and domain. For domains which
;;are foreign-keys:
;;
;;@table @code
;;@item single
;;select menu
;;@item optional
;;select menu
;;@item nary
;;check boxes
;;@item nary1
;;check boxes
;;@end table
;;
;;If the foreign-key table has a field named @samp{visible-name}, then
;;the contents of that field are the names visible to the user for
;;those choices. Otherwise, the foreign-key itself is visible.
;;
;;For other types of domains:
;;
;;@table @code
;;@item single
;;text area
;;@item optional
;;text area
;;@item boolean
;;check box
;;@item nary
;;text area
;;@item nary1
;;text area
;;@end table
(define (form:element pname arity default-list foreign-values)
(define dflt (if (null? default-list) #f
(sprintf #f "%a" (car default-list))))
;;(print 'form:element pname arity default-list foreign-values)
(case (length foreign-values)
((0) (case arity
((boolean)
(html:checkbox pname dflt))
((single optional)
(html:text pname (if (car default-list) dflt "")))
(else (html:text-area pname default-list))))
((1) (html:checkbox pname dflt))
(else ((case arity
((single optional) html:select)
(else html:buttons))
pname arity default-list foreign-values))))
;;@body
;;
;;Returns a HTML string for a form element embedded in a line of a
;;delimited list. Apply map @0 to the list returned by
;;@code{command->p-specs}.
(define (form:delimited pname doc aliat arity default-list foreign-values)
(define longname
(remove-if (lambda (s) (= 1 (string-length s))) (cdr aliat)))
(set! longname (if (null? longname) #f (car longname)))
(if longname
(string-append
"<DT>" (html:strong-doc longname doc) "<DD>"
(form:element pname arity default-list foreign-values))
""))
;;@body
;;
;;The symbol @2 names a command table in the @1 relational database.
;;The symbol @3 names a key in @2.
;;
;;@0 returns a list of lists of @var{pname}, @var{doc}, @var{aliat},
;;@var{arity}, @var{default-list}, and @var{foreign-values}. The
;;returned list has one element for each parameter of command @3.
;;
;;This example demonstrates how to create a HTML-form for the @samp{build}
;;command.
;;
;;@example
;;(require (in-vicinity (implementation-vicinity) "build.scm"))
;;(call-with-output-file "buildscm.html"
;; (lambda (port)
;; (display
;; (string-append
;; (html:head 'commands)
;; (html:body
;; (sprintf #f "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n"
;; (html:plain 'build)
;; (html:plain ((comtab 'get 'documentation) 'build)))
;; (html:form
;; 'post
;; (or "http://localhost:8081/buildscm" "/cgi-bin/build.cgi")
;; (apply html:delimited-list
;; (apply map form:delimited
;; (command->p-specs build '*commands* 'build)))
;; (form:submit 'build)
;; (form:reset))))
;; port)))
;;@end example
(define (command->p-specs rdb command-table command)
(define rdb-open (rdb 'open-table))
(define (row-refer idx) (lambda (row) (list-ref row idx)))
(let ((comtab (rdb-open command-table #f))
;;(domain->type ((rdb-open '*domains-data* #f) 'get 'type-id))
(get-foreign-values
(let ((ftn ((rdb-open '*domains-data* #f) 'get 'foreign-table)))
(lambda (domain-name)
(define tab-name (ftn domain-name))
(if tab-name
(get-foreign-choices (rdb-open tab-name #f))
'())))))
(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))
(pnames (map (row-refer (position 'name pcnames)) param-rows)))
(define foreign-values (map get-foreign-values domains))
(define aliast (map list pnames))
(for-each (lambda (alias)
(if (> (string-length (car alias)) 1)
(let ((apr (assq (cadr alias) aliast)))
(set-cdr! apr (cons (car alias) (cdr apr))))))
(map list
((parameter-names 'get* 'name))
(map (parameter-table 'get 'name)
((parameter-names 'get* 'parameter-index)))))
(list pnames
(map (row-refer (position 'documentation pcnames)) param-rows)
aliast
(map (row-refer (position 'arity pcnames)) param-rows)
;;(map domain->type domains)
(map cdr ;(lambda (lst) (if (null? lst) lst (cdr lst)))
(fill-empty-parameters
(map slib:eval
(map (row-refer (position 'defaulter pcnames))
param-rows))
(make-parameter-list
(map (row-refer (position 'name pcnames)) param-rows))))
foreign-values)))))

204
module/slib/htmlform.txi
View file

@ -1,204 +0,0 @@
@code{(require 'html-form)}
@defun html:atval txt
Returns a string with character substitutions appropriate to
send @var{txt} as an @dfn{attribute-value}.
@cindex attribute-value
@end defun
@defun html:plain txt
Returns a string with character substitutions appropriate to
send @var{txt} as an @dfn{plain-text}.
@cindex plain-text
@end defun
@defun html:meta name content
Returns a tag of meta-information suitable for passing as the
third argument to @code{html:head}. The tag produced is @samp{<META
NAME="@var{name}" CONTENT="@var{content}">}. The string or symbol @var{name} can be
@samp{author}, @samp{copyright}, @samp{keywords}, @samp{description},
@samp{date}, @samp{robots}, @dots{}.
@end defun
@defun html:http-equiv name content
Returns a tag of HTTP information suitable for passing as the
third argument to @code{html:head}. The tag produced is @samp{<META
HTTP-EQUIV="@var{name}" CONTENT="@var{content}">}. The string or symbol @var{name} can be
@samp{Expires}, @samp{PICS-Label}, @samp{Content-Type},
@samp{Refresh}, @dots{}.
@end defun
@defun html:meta-refresh delay uri
@defunx html:meta-refresh delay
Returns a tag suitable for passing as the third argument to
@code{html:head}. If @var{uri} argument is supplied, then @var{delay} seconds after
displaying the page with this tag, Netscape or IE browsers will fetch
and display @var{uri}. Otherwise, @var{delay} seconds after displaying the page with
this tag, Netscape or IE browsers will fetch and redisplay this page.
@end defun
@defun html:head title backlink tags @dots{}
@defunx html:head title backlink
@defunx html:head title
Returns header string for an HTML page named @var{title}. If @var{backlink} is a string,
it is used verbatim between the @samp{H1} tags; otherwise @var{title} is
used. If string arguments @var{tags} ... are supplied, then they are
included verbatim within the @t{<HEAD>} section.
@end defun
@defun html:body body @dots{}
Returns HTML string to end a page.
@end defun
@defun html:pre line1 line @dots{}
Returns the strings @var{line1}, @var{lines} as @dfn{PRE}formmated plain text
@cindex PRE
(rendered in fixed-width font). Newlines are inserted between @var{line1},
@var{lines}. HTML tags (@samp{<tag>}) within @var{lines} will be visible verbatim.
@end defun
@defun html:comment line1 line @dots{}
Returns the strings @var{line1} as HTML comments.
@end defun
@section HTML Forms
@defun html:form method action body @dots{}
The symbol @var{method} is either @code{get}, @code{head}, @code{post},
@code{put}, or @code{delete}. The strings @var{body} form the body of the
form. @code{html:form} returns the HTML @dfn{form}.
@cindex form
@end defun
@defun html:hidden name value
Returns HTML string which will cause @var{name}=@var{value} in form.
@end defun
@defun html:checkbox pname default
Returns HTML string for check box.
@end defun
@defun html:text pname default size @dots{}
Returns HTML string for one-line text box.
@end defun
@defun html:text-area pname default-list
Returns HTML string for multi-line text box.
@end defun
@defun html:select pname arity default-list foreign-values
Returns HTML string for pull-down menu selector.
@end defun
@defun html:buttons pname arity default-list foreign-values
Returns HTML string for any-of selector.
@end defun
@defun form:submit submit-label command
@defunx form:submit submit-label
The string or symbol @var{submit-label} appears on the button which submits the form.
If the optional second argument @var{command} is given, then @code{*command*=@var{command}}
and @code{*button*=@var{submit-label}} are set in the query. Otherwise,
@code{*command*=@var{submit-label}} is set in the query.
@end defun
@defun form:image submit-label image-src
The @var{image-src} appears on the button which submits the form.
@end defun
@defun form:reset
Returns a string which generates a @dfn{reset} button.
@cindex reset
@end defun
@defun form:element pname arity default-list foreign-values
Returns a string which generates an INPUT element for the field
named @var{pname}. The element appears in the created form with its
representation determined by its @var{arity} and domain. For domains which
are foreign-keys:
@table @code
@item single
select menu
@item optional
select menu
@item nary
check boxes
@item nary1
check boxes
@end table
If the foreign-key table has a field named @samp{visible-name}, then
the contents of that field are the names visible to the user for
those choices. Otherwise, the foreign-key itself is visible.
For other types of domains:
@table @code
@item single
text area
@item optional
text area
@item boolean
check box
@item nary
text area
@item nary1
text area
@end table
@end defun
@defun form:delimited pname doc aliat arity default-list foreign-values
Returns a HTML string for a form element embedded in a line of a
delimited list. Apply map @code{form:delimited} to the list returned by
@code{command->p-specs}.
@end defun
@defun command->p-specs rdb command-table command
The symbol @var{command-table} names a command table in the @var{rdb} relational database.
The symbol @var{command} names a key in @var{command-table}.
@code{command->p-specs} returns a list of lists of @var{pname}, @var{doc}, @var{aliat},
@var{arity}, @var{default-list}, and @var{foreign-values}. The
returned list has one element for each parameter of command @var{command}.
This example demonstrates how to create a HTML-form for the @samp{build}
command.
@example
(require (in-vicinity (implementation-vicinity) "build.scm"))
(call-with-output-file "buildscm.html"
(lambda (port)
(display
(string-append
(html:head 'commands)
(html:body
(sprintf #f "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n"
(html:plain 'build)
(html:plain ((comtab 'get 'documentation) 'build)))
(html:form
'post
(or "http://localhost:8081/buildscm" "/cgi-bin/build.cgi")
(apply html:delimited-list
(apply map form:delimited
(command->p-specs build '*commands* 'build)))
(form:submit 'build)
(form:reset))))
port)))
@end example
@end defun

438
module/slib/http-cgi.scm
View file

@ -1,438 +0,0 @@
;;; "http-cgi.scm" service HTTP or CGI requests. -*-scheme-*-
; Copyright 1997, 1998, 2000, 2001 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'uri)
(require 'scanf)
(require 'printf)
(require 'coerce)
(require 'line-i/o)
(require 'html-form)
(require 'parameters)
(require 'string-case)
;;@code{(require 'http)} or @code{(require 'cgi)}
(define http:crlf (string (integer->char 13) #\newline))
(define (http:read-header port)
(define alist '())
(do ((line (read-line port) (read-line port)))
((or (zero? (string-length line))
(and (= 1 (string-length line))
(char-whitespace? (string-ref line 0)))
(eof-object? line))
(if (and (= 1 (string-length line))
(char-whitespace? (string-ref line 0)))
(set! http:crlf (string (string-ref line 0) #\newline)))
(if (eof-object? line) line alist))
(let ((len (string-length line))
(idx (string-index line #\:)))
(if (char-whitespace? (string-ref line (+ -1 len)))
(set! len (+ -1 len)))
(and idx (do ((idx2 (+ idx 1) (+ idx2 1)))
((or (>= idx2 len)
(not (char-whitespace? (string-ref line idx2))))
(set! alist
(cons
(cons (string-ci->symbol (substring line 0 idx))
(substring line idx2 len))
alist)))))
;;Else -- ignore malformed line
;;(else (slib:error 'http:read-header 'malformed-input line))
)))
(define (http:read-query-string request-line header port)
(case (car request-line)
((get head)
(let* ((request-uri (cadr request-line))
(len (string-length request-uri)))
(and (> len 3)
(string-index request-uri #\?)
(substring request-uri
(+ 1 (string-index request-uri #\?))
(if (eqv? #\/ (string-ref request-uri (+ -1 len)))
(+ -1 len)
len)))))
((post put delete)
(let ((content-length (assq 'content-length header)))
(and content-length
(set! content-length (string->number (cdr content-length))))
(and content-length
(let ((str (make-string content-length #\ )))
(do ((idx 0 (+ idx 1)))
((>= idx content-length)
(if (>= idx (string-length str)) str (substring str 0 idx)))
(let ((chr (read-char port)))
(if (char? chr)
(string-set! str idx chr)
(set! content-length idx))))))))
(else #f)))
(define (http:status-line status-code reason)
(sprintf #f "HTTP/1.1 %d %s%s" status-code reason http:crlf))
;;@body Returns a string containing lines for each element of @1; the
;;@code{car} of which is followed by @samp{: }, then the @code{cdr}.
(define (http:header alist)
(string-append
(apply string-append
(map (lambda (pair)
(sprintf #f "%s: %s%s" (car pair) (cdr pair) http:crlf))
alist))
http:crlf))
;;@body Returns the concatenation of strings @2 with the
;;@code{(http:header @1)} and the @samp{Content-Length} prepended.
(define (http:content alist . body)
(define hunk (apply string-append body))
(string-append (http:header
(cons (cons "Content-Length"
(number->string (string-length hunk)))
alist))
hunk))
;;@body String appearing at the bottom of error pages.
(define *http:byline* #f)
;;@body @1 and @2 should be an integer and string as specified in
;;@cite{RFC 2068}. The returned page (string) will show the @1 and @2
;;and any additional @3 @dots{}; with @var{*http:byline*} or SLIB's
;;default at the bottom.
(define (http:error-page status-code reason-phrase . html-strings)
(define byline
(or
*http:byline*
(sprintf
#f
"<A HREF=http://swissnet.ai.mit.edu/~jaffer/SLIB.html>SLIB</A> %s server"
(if (getenv "SERVER_PROTOCOL") "CGI/1.1" "HTTP/1.1"))))
(string-append (http:status-line status-code reason-phrase)
(http:content
'(("Content-Type" . "text/html"))
(html:head (sprintf #f "%d %s" status-code reason-phrase))
(apply html:body
(append html-strings
(list (sprintf #f "<HR>\\n%s\\n" byline)))))))
;;@body The string or symbol @1 is the page title. @2 is a non-negative
;;integer. The @4 @dots{} are typically used to explain to the user why
;;this page is being forwarded.
;;
;;@0 returns an HTML string for a page which automatically forwards to
;;@3 after @2 seconds. The returned page (string) contains any @4
;;@dots{} followed by a manual link to @3, in case the browser does not
;;forward automatically.
(define (http:forwarding-page title delay uri . html-strings)
(string-append
(html:head title #f (html:meta-refresh delay uri))
(apply html:body
(append html-strings
(list (sprintf #f "\\n\\n<HR>\\nReturn to %s.\\n"
(html:link uri title)))))))
;;@body reads the @dfn{URI} and @dfn{query-string} from @2. If the
;;query is a valid @samp{"POST"} or @samp{"GET"} query, then @0 calls
;;@1 with three arguments, the @var{request-line}, @var{query-string},
;;and @var{header-alist}. Otherwise, @0 calls @1 with the
;;@var{request-line}, #f, and @var{header-alist}.
;;
;;If @1 returns a string, it is sent to @3. If @1 returns a list,
;;then an error page with number 525 and strings from the list. If @1
;;returns #f, then a @samp{Bad Request} (400) page is sent to @3.
;;
;;Otherwise, @0 replies (to @3) with appropriate HTML describing the
;;problem.
(define (http:serve-query serve-proc input-port output-port)
(let* ((request-line (http:read-request-line input-port))
(header (and request-line (http:read-header input-port)))
(query-string (and header (http:read-query-string
request-line header input-port))))
(display (http:service serve-proc request-line query-string header)
output-port)))
(define (http:service serve-proc request-line query-string header)
(cond ((not request-line) (http:error-page 400 "Bad Request."))
((string? (car request-line))
(http:error-page 501 "Not Implemented" (html:plain request-line)))
((not (memq (car request-line) '(get post)))
(http:error-page 405 "Method Not Allowed" (html:plain request-line)))
((serve-proc request-line query-string header) =>
(lambda (reply)
(cond ((string? reply)
(string-append (http:status-line 200 "OK")
reply))
((and (pair? reply) (list? reply))
(if (number? (car reply))
(apply http:error-page reply)
(apply http:error-page 525 reply)))
(else (http:error-page 500 "Internal Server Error")))))
((not query-string)
(http:error-page 400 "Bad Request" (html:plain request-line)))
(else
(http:error-page 500 "Internal Server Error" (html:plain header)))))
;;@
;;
;;This example services HTTP queries from @var{port-number}:
;;@example
;;
;;(define socket (make-stream-socket AF_INET 0))
;;(and (socket:bind socket port-number) ; AF_INET INADDR_ANY
;; (socket:listen socket 10) ; Queue up to 10 requests.
;; (dynamic-wind
;; (lambda () #f)
;; (lambda ()
;; (do ((port (socket:accept socket) (socket:accept socket)))
;; (#f)
;; (let ((iport (duplicate-port port "r"))
;; (oport (duplicate-port port "w")))
;; (http:serve-query build:serve iport oport)
;; (close-port iport)
;; (close-port oport))
;; (close-port port)))
;; (lambda () (close-port socket))))
;;@end example
(define (http:read-start-line port)
(do ((line (read-line port) (read-line port)))
((or (not (equal? "" line)) (eof-object? line)) line)))
;; @body
;; Request lines are a list of three itmes:
;;
;; @enumerate 0
;;
;; @item Method
;;
;; A symbol (@code{options}, @code{get}, @code{head}, @code{post},
;; @code{put}, @code{delete}, @code{trace} @dots{}).
;;
;; @item Request-URI
;;
;; A string. For direct HTTP, at the minimum it will be the string
;; @samp{"/"}.
;;
;; @item HTTP-Version
;;
;; A string. For example, @samp{HTTP/1.0}.
;; @end enumerate
(define (http:read-request-line port)
(let ((lst (scanf-read-list "%s %s %s %s" (http:read-start-line port))))
(and (list? lst)
(= 3 (length lst))
(cons (string-ci->symbol (car lst)) (cdr lst)))))
(define (cgi:request-line)
(define method (getenv "REQUEST_METHOD"))
(and method
(list (string-ci->symbol method)
(getenv "SCRIPT_NAME")
(getenv "SERVER_PROTOCOL"))))
(define (cgi:query-header)
(define assqs '())
(cond ((and (getenv "SERVER_NAME") (getenv "SERVER_PORT"))
(set! assqs (cons (cons 'host (string-append (getenv "SERVER_NAME")
":"
(getenv "SERVER_PORT")))
assqs))))
(for-each
(lambda (envar)
(define valstr (getenv envar))
(if valstr (set! assqs
(cons (cons (string-ci->symbol
(string-subst envar "HTTP_" "" "_" "-"))
valstr)
assqs))))
'(
;;"AUTH_TYPE"
"CONTENT_LENGTH"
"CONTENT_TYPE"
"DOCUMENT_ROOT"
"GATEWAY_INTERFACE"
"HTTP_ACCEPT"
"HTTP_ACCEPT_CHARSET"
"HTTP_ACCEPT_ENCODING"
"HTTP_ACCEPT_LANGUAGE"
"HTTP_CONNECTION"
"HTTP_HOST"
;;"HTTP_PRAGMA"
"HTTP_REFERER"
"HTTP_USER_AGENT"
"PATH_INFO"
"PATH_TRANSLATED"
"QUERY_STRING"
"REMOTE_ADDR"
"REMOTE_HOST"
;;"REMOTE_IDENT"
;;"REMOTE_USER"
"REQUEST_URI"
"SCRIPT_FILENAME"
"SCRIPT_NAME"
;;"SERVER_SIGNATURE"
;;"SERVER_SOFTWARE"
))
assqs)
;; @body Reads the @dfn{query-string} from @code{(current-input-port)}.
;; @0 reads a @samp{"POST"} or @samp{"GET"} queries, depending on the
;; value of @code{(getenv "REQUEST_METHOD")}.
(define (cgi:read-query-string)
(define request-method (getenv "REQUEST_METHOD"))
(cond ((and request-method (string-ci=? "GET" request-method))
(getenv "QUERY_STRING"))
((and request-method (string-ci=? "POST" request-method))
(let ((content-length (getenv "CONTENT_LENGTH")))
(and content-length
(set! content-length (string->number content-length)))
(and content-length
(let ((str (make-string content-length #\ )))
(do ((idx 0 (+ idx 1)))
((>= idx content-length)
(if (>= idx (string-length str))
str
(substring str 0 idx)))
(let ((chr (read-char)))
(if (char? chr)
(string-set! str idx chr)
(set! content-length idx))))))))
(else #f)))
;;@body reads the @dfn{URI} and @dfn{query-string} from
;;@code{(current-input-port)}. If the query is a valid @samp{"POST"}
;;or @samp{"GET"} query, then @0 calls @1 with three arguments, the
;;@var{request-line}, @var{query-string}, and @var{header-alist}.
;;Otherwise, @0 calls @1 with the @var{request-line}, #f, and
;;@var{header-alist}.
;;
;;If @1 returns a string, it is sent to @code{(current-input-port)}.
;;If @1 returns a list, then an error page with number 525 and strings
;;from the list. If @1 returns #f, then a @samp{Bad Request} (400)
;;page is sent to @code{(current-input-port)}.
;;
;;Otherwise, @0 replies (to @code{(current-input-port)}) with
;;appropriate HTML describing the problem.
(define (cgi:serve-query serve-proc)
(let* ((script-name (getenv "SCRIPT_NAME"))
(request-line (cgi:request-line))
(header (and request-line (cgi:query-header)))
(query-string (and header (cgi:read-query-string)))
(reply (http:service serve-proc request-line query-string header)))
(display (if (and script-name
(not (eqv? 0 (substring? "nph-" script-name))))
;; Eat http status line.
(substring reply (+ 2 (substring? http:crlf reply))
(string-length reply))
reply))))
(define (coerce->list str type)
(case type
((expression)
(slib:warn 'coerce->list 'unsafe 'read)
(do ((tok (read port) (read port))
(lst '() (cons tok lst)))
((or (null? tok) (eof-object? tok)) lst)))
((symbol)
(call-with-input-string str
(lambda (port)
(do ((tok (scanf-read-list " %s" port)
(scanf-read-list " %s" port))
(lst '() (cons (string-ci->symbol (car tok)) lst)))
((or (null? tok) (eof-object? tok)) lst)))))
(else
(call-with-input-string str
(lambda (port)
(do ((tok (scanf-read-list " %s" port)
(scanf-read-list " %s" port))
(lst '() (cons (coerce (car tok) type) lst)))
((or (null? tok) (eof-object? tok)) lst)))))))
(define (query-alist->parameter-list alist optnames arities types)
(let ((parameter-list (make-parameter-list optnames)))
(for-each
(lambda (lst)
(let* ((value (cadr lst))
(name (car lst))
(opt-pos (position name optnames)))
(cond ((not opt-pos)
(slib:warn 'query-alist->parameter-list
'unknown 'parameter name))
((eq? (list-ref arities opt-pos) 'boolean)
(adjoin-parameters! parameter-list (list name #t)))
((and (equal? value "")
(not (memq (list-ref types opt-pos) '(expression string))))
(adjoin-parameters! parameter-list (list name #f)))
(value
(adjoin-parameters!
parameter-list
(cons name
(case (list-ref arities opt-pos)
((nary nary1)
(coerce->list value (list-ref types opt-pos)))
(else
(list (coerce value (list-ref types opt-pos)))))))))))
alist)
parameter-list))
;;@args rdb command-table
;;@args rdb command-table #t
;;
;;Returns a procedure of one argument. When that procedure is called
;;with a @var{query-alist} (as returned by @code{uri:decode-query}, the
;;value of the @samp{*command*} association will be the command invoked
;;in @2. If @samp{*command*} is not in the @var{query-alist} then the
;;value of @samp{*suggest*} is tried. If neither name is in the
;;@var{query-alist}, then the literal value @samp{*default*} is tried in
;;@2.
;;
;;If optional third argument is non-false, then the command is called
;;with just the parameter-list; otherwise, command is called with the
;;arguments described in its table.
(define (make-query-alist-command-server rdb command-table . just-params?)
(define comsrvcal (make-command-server rdb command-table))
(set! just-params? (if (null? just-params?) #f (car just-params?)))
(lambda (query-alist)
(define comnam #f)
(define find-command?
(lambda (cname)
(define tryp (parameter-list-ref query-alist cname))
(cond ((not tryp) #f)
(comnam
(set! query-alist (remove-parameter cname query-alist)))
(else
(set! query-alist (remove-parameter cname query-alist))
(set! comnam (string-ci->symbol (car tryp)))))))
(find-command? '*command*)
(find-command? '*suggest*)
(find-command? '*button*)
(cond ((not comnam) (set! comnam '*default*)))
(cond
(comnam
(comsrvcal comnam
(lambda (comname comval options positions
arities types defaulters dirs aliases)
(let* ((params (query-alist->parameter-list
query-alist options arities types))
(fparams (fill-empty-parameters defaulters params)))
(and (list? fparams)
(check-parameters dirs fparams)
(if just-params?
(comval fparams)
(let ((arglist (parameter-list->arglist
positions arities fparams)))
(and arglist
(apply comval arglist))))))))))))

110
module/slib/http-cgi.txi
View file

@ -1,110 +0,0 @@
@code{(require 'http)} or @code{(require 'cgi)}
@defun http:header alist
Returns a string containing lines for each element of @var{alist}; the
@code{car} of which is followed by @samp{: }, then the @code{cdr}.
@end defun
@defun http:content alist body @dots{}
Returns the concatenation of strings @var{body} with the
@code{(http:header @var{alist})} and the @samp{Content-Length} prepended.
@end defun
@defvar *http:byline*
String appearing at the bottom of error pages.
@end defvar
@defun http:error-page status-code reason-phrase html-string @dots{}
@var{status-code} and @var{reason-phrase} should be an integer and string as specified in
@cite{RFC 2068}. The returned page (string) will show the @var{status-code} and @var{reason-phrase}
and any additional @var{html-strings} @dots{}; with @var{*http:byline*} or SLIB's
default at the bottom.
@end defun
@defun http:forwarding-page title delay uri html-string @dots{}
The string or symbol @var{title} is the page title. @var{delay} is a non-negative
integer. The @var{html-strings} @dots{} are typically used to explain to the user why
this page is being forwarded.
@code{http:forwarding-page} returns an HTML string for a page which automatically forwards to
@var{uri} after @var{delay} seconds. The returned page (string) contains any @var{html-strings}
@dots{} followed by a manual link to @var{uri}, in case the browser does not
forward automatically.
@end defun
@defun http:serve-query serve-proc input-port output-port
reads the @dfn{URI} and @dfn{query-string} from @var{input-port}. If the
@cindex URI
@cindex query-string
query is a valid @samp{"POST"} or @samp{"GET"} query, then @code{http:serve-query} calls
@var{serve-proc} with three arguments, the @var{request-line}, @var{query-string},
and @var{header-alist}. Otherwise, @code{http:serve-query} calls @var{serve-proc} with the
@var{request-line}, #f, and @var{header-alist}.
If @var{serve-proc} returns a string, it is sent to @var{output-port}. If @var{serve-proc} returns a list,
then an error page with number 525 and strings from the list. If @var{serve-proc}
returns #f, then a @samp{Bad Request} (400) page is sent to @var{output-port}.
Otherwise, @code{http:serve-query} replies (to @var{output-port}) with appropriate HTML describing the
problem.
@end defun
This example services HTTP queries from @var{port-number}:
@example
(define socket (make-stream-socket AF_INET 0))
(and (socket:bind socket port-number) ; AF_INET INADDR_ANY
(socket:listen socket 10) ; Queue up to 10 requests.
(dynamic-wind
(lambda () #f)
(lambda ()
(do ((port (socket:accept socket) (socket:accept socket)))
(#f)
(let ((iport (duplicate-port port "r"))
(oport (duplicate-port port "w")))
(http:serve-query build:serve iport oport)
(close-port iport)
(close-port oport))
(close-port port)))
(lambda () (close-port socket))))
@end example
@defun cgi:serve-query serve-proc
reads the @dfn{URI} and @dfn{query-string} from
@cindex URI
@cindex query-string
@code{(current-input-port)}. If the query is a valid @samp{"POST"}
or @samp{"GET"} query, then @code{cgi:serve-query} calls @var{serve-proc} with three arguments, the
@var{request-line}, @var{query-string}, and @var{header-alist}.
Otherwise, @code{cgi:serve-query} calls @var{serve-proc} with the @var{request-line}, #f, and
@var{header-alist}.
If @var{serve-proc} returns a string, it is sent to @code{(current-input-port)}.
If @var{serve-proc} returns a list, then an error page with number 525 and strings
from the list. If @var{serve-proc} returns #f, then a @samp{Bad Request} (400)
page is sent to @code{(current-input-port)}.
Otherwise, @code{cgi:serve-query} replies (to @code{(current-input-port)}) with
appropriate HTML describing the problem.
@end defun
@defun make-query-alist-command-server rdb command-table
@defunx make-query-alist-command-server rdb command-table #t
Returns a procedure of one argument. When that procedure is called
with a @var{query-alist} (as returned by @code{uri:decode-query}, the
value of the @samp{*command*} association will be the command invoked
in @var{command-table}. If @samp{*command*} is not in the @var{query-alist} then the
value of @samp{*suggest*} is tried. If neither name is in the
@var{query-alist}, then the literal value @samp{*default*} is tried in
@var{command-table}.
If optional third argument is non-false, then the command is called
with just the parameter-list; otherwise, command is called with the
arguments described in its table.
@end defun

82
module/slib/lineio.scm
View file

@ -1,82 +0,0 @@
; "lineio.scm", line oriented input/output functions for Scheme.
; Copyright (c) 1992, 1993 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;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.
;;@args
;;@args port
;;Returns a string of the characters up to, but not including a
;;newline or end of file, updating @var{port} to point to the
;;character following the newline. If no characters are available, an
;;end of file object is returned. The @var{port} argument may be
;;omitted, in which case it defaults to the value returned by
;;@code{current-input-port}.
(define (read-line . port)
(let* ((char (apply read-char port)))
(if (eof-object? char)
char
(do ((char char (apply read-char port))
(clist '() (cons char clist)))
((or (eof-object? char) (char=? #\newline char))
(list->string (reverse clist)))))))
;;@args string
;;@args string port
;;Fills @1 with characters up to, but not including a newline or end
;;of file, updating the @var{port} to point to the last character read
;;or following the newline if it was read. If no characters are
;;available, an end of file object is returned. If a newline or end
;;of file was found, the number of characters read is returned.
;;Otherwise, @code{#f} is returned. The @var{port} argument may be
;;omitted, in which case it defaults to the value returned by
;;@code{current-input-port}.
(define (read-line! str . port)
(let* ((char (apply read-char port))
(midx (+ -1 (string-length str))))
(if (eof-object? char)
char
(do ((char char (apply read-char port))
(i 0 (+ 1 i)))
((or (eof-object? char)
(char=? #\newline char)
(> i midx))
(if (> i midx) #f i))
(string-set! str i char)))))
;;@args string
;;@args string port
;;Writes @1 followed by a newline to the given @var{port} and returns
;;an unspecified value. The @var{Port} argument may be omitted, in
;;which case it defaults to the value returned by
;;@code{current-input-port}.@refill
(define (write-line str . port)
(apply display str port)
(apply newline port))
;;@args path
;;@args path port
;;Displays the contents of the file named by @1 to @var{port}. The
;;@var{port} argument may be ommited, in which case it defaults to the
;;value returned by @code{current-output-port}.
(define (display-file path . port)
(set! port (if (null? port) (current-output-port) (car port)))
(call-with-input-file path
(lambda (inport)
(do ((line (read-line inport) (read-line inport)))
((eof-object? line))
(write-line line port)))))

45
module/slib/lineio.txi
View file

@ -1,45 +0,0 @@
@defun read-line
@defunx read-line port
Returns a string of the characters up to, but not including a
newline or end of file, updating @var{port} to point to the
character following the newline. If no characters are available, an
end of file object is returned. The @var{port} argument may be
omitted, in which case it defaults to the value returned by
@code{current-input-port}.
@end defun
@defun read-line! string
@defunx read-line! string port
Fills @var{string} with characters up to, but not including a newline or end
of file, updating the @var{port} to point to the last character read
or following the newline if it was read. If no characters are
available, an end of file object is returned. If a newline or end
of file was found, the number of characters read is returned.
Otherwise, @code{#f} is returned. The @var{port} argument may be
omitted, in which case it defaults to the value returned by
@code{current-input-port}.
@end defun
@defun write-line string
@defunx write-line string port
Writes @var{string} followed by a newline to the given @var{port} and returns
an unspecified value. The @var{Port} argument may be omitted, in
which case it defaults to the value returned by
@code{current-input-port}.@refill
@end defun
@defun display-file path
@defunx display-file path port
Displays the contents of the file named by @var{path} to @var{port}. The
@var{port} argument may be ommited, in which case it defaults to the
value returned by @code{current-output-port}.
@end defun

168
module/slib/logical.scm
View file

@ -1,168 +0,0 @@
;;;; "logical.scm", bit access and operations for integers for Scheme
;;; Copyright (C) 1991, 1993 Aubrey Jaffer.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(define logical:integer-expt
(if (provided? 'inexact)
expt
(lambda (n k)
(logical:ipow-by-squaring n k 1 *))))
(define (logical:ipow-by-squaring x k acc proc)
(cond ((zero? k) acc)
((= 1 k) (proc acc x))
(else (logical:ipow-by-squaring (proc x x)
(quotient k 2)
(if (even? k) acc (proc acc x))
proc))))
(define (logical:logand n1 n2)
(cond ((= n1 n2) n1)
((zero? n1) 0)
((zero? n2) 0)
(else
(+ (* (logical:logand (logical:ash-4 n1) (logical:ash-4 n2)) 16)
(vector-ref (vector-ref logical:boole-and (modulo n1 16))
(modulo n2 16))))))
(define (logical:logior n1 n2)
(cond ((= n1 n2) n1)
((zero? n1) n2)
((zero? n2) n1)
(else
(+ (* (logical:logior (logical:ash-4 n1) (logical:ash-4 n2)) 16)
(- 15 (vector-ref (vector-ref logical:boole-and
(- 15 (modulo n1 16)))
(- 15 (modulo n2 16))))))))
(define (logical:logxor n1 n2)
(cond ((= n1 n2) 0)
((zero? n1) n2)
((zero? n2) n1)
(else
(+ (* (logical:logxor (logical:ash-4 n1) (logical:ash-4 n2)) 16)
(vector-ref (vector-ref logical:boole-xor (modulo n1 16))
(modulo n2 16))))))
(define (logical:lognot n) (- -1 n))
(define (logical:logtest int1 int2)
(not (zero? (logical:logand int1 int2))))
(define (logical:logbit? index int)
(logical:logtest (logical:integer-expt 2 index) int))
(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))))
(if (negative? int)
(+ -1 (quotient (+ 1 int) n))
(quotient int n)))
(* (logical:integer-expt 2 cnt) int)))
(define (logical:ash-4 x)
(if (negative? x)
(+ -1 (quotient (+ 1 x) 16))
(quotient x 16)))
(define (logical:logcount n)
(cond ((zero? n) 0)
((negative? n) (logical:logcount (logical:lognot n)))
(else
(+ (logical:logcount (logical:ash-4 n))
(vector-ref '#(0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4)
(modulo n 16))))))
(define (logical:integer-length n)
(case n
((0 -1) 0)
((1 -2) 1)
((2 3 -3 -4) 2)
((4 5 6 7 -5 -6 -7 -8) 3)
(else (+ 4 (logical:integer-length (logical:ash-4 n))))))
(define logical:boole-xor
'#(#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
#(1 0 3 2 5 4 7 6 9 8 11 10 13 12 15 14)
#(2 3 0 1 6 7 4 5 10 11 8 9 14 15 12 13)
#(3 2 1 0 7 6 5 4 11 10 9 8 15 14 13 12)
#(4 5 6 7 0 1 2 3 12 13 14 15 8 9 10 11)
#(5 4 7 6 1 0 3 2 13 12 15 14 9 8 11 10)
#(6 7 4 5 2 3 0 1 14 15 12 13 10 11 8 9)
#(7 6 5 4 3 2 1 0 15 14 13 12 11 10 9 8)
#(8 9 10 11 12 13 14 15 0 1 2 3 4 5 6 7)
#(9 8 11 10 13 12 15 14 1 0 3 2 5 4 7 6)
#(10 11 8 9 14 15 12 13 2 3 0 1 6 7 4 5)
#(11 10 9 8 15 14 13 12 3 2 1 0 7 6 5 4)
#(12 13 14 15 8 9 10 11 4 5 6 7 0 1 2 3)
#(13 12 15 14 9 8 11 10 5 4 7 6 1 0 3 2)
#(14 15 12 13 10 11 8 9 6 7 4 5 2 3 0 1)
#(15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0)))
(define logical:boole-and
'#(#(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
#(0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1)
#(0 0 2 2 0 0 2 2 0 0 2 2 0 0 2 2)
#(0 1 2 3 0 1 2 3 0 1 2 3 0 1 2 3)
#(0 0 0 0 4 4 4 4 0 0 0 0 4 4 4 4)
#(0 1 0 1 4 5 4 5 0 1 0 1 4 5 4 5)
#(0 0 2 2 4 4 6 6 0 0 2 2 4 4 6 6)
#(0 1 2 3 4 5 6 7 0 1 2 3 4 5 6 7)
#(0 0 0 0 0 0 0 0 8 8 8 8 8 8 8 8)
#(0 1 0 1 0 1 0 1 8 9 8 9 8 9 8 9)
#(0 0 2 2 0 0 2 2 8 8 10 10 8 8 10 10)
#(0 1 2 3 0 1 2 3 8 9 10 11 8 9 10 11)
#(0 0 0 0 4 4 4 4 8 8 8 8 12 12 12 12)
#(0 1 0 1 4 5 4 5 8 9 8 9 12 13 12 13)
#(0 0 2 2 4 4 6 6 8 8 10 10 12 12 14 14)
#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)))
(define logand logical:logand)
(define logior logical:logior)
(define logxor logical:logxor)
(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-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)

54
module/slib/macrotst.scm
View file

@ -1,54 +0,0 @@
;;;"macrotst.scm" Test for R4RS Macros
;;; From Revised^4 Report on the Algorithmic Language Scheme
;;; Editors: William Clinger and Jonathon Rees
;
; We intend this report to belong to the entire Scheme community, and so
; we grant permission to copy it in whole or in part without fee. In
; particular, we encourage implementors of Scheme to use this report as
; a starting point for manuals and other documentation, modifying it as
; necessary.
;;; To run this code type
;;; (require 'macro)
;;; (macro:load "macrotst.scm")
(write "this code should print now, outer, and 7") (newline)
(write
(let-syntax ((when (syntax-rules ()
((when test stmt1 stmt2 ...)
(if test
(begin stmt1
stmt2 ...))))))
(let ((if #t))
(when if (set! if 'now))
if)))
(newline)
;;; ==> now
(write
(let ((x 'outer))
(let-syntax ((m (syntax-rules () ((m) x))))
(let ((x 'inner))
(m)))))
(newline)
;;; ==> outer
(write
(letrec-syntax
((or (syntax-rules ()
((or) #f)
((or e) e)
((or e1 e2 ...)
(let ((temp e1))
(if temp temp (or e2 ...)))))))
(let ((x #f)
(y 7)
(temp 8)
(let odd?)
(if even?))
(or x
(let temp)
(if y)
y))))
(newline)
;;; ==> 7

276
module/slib/macscheme.init
View file

@ -1,276 +0,0 @@
;;;"macscheme.init" Configuration of *features* for MacScheme -*-scheme-*-
;;; Author: Aubrey Jaffer
;;;
;;; This code is in the public domain.
;;; From: jjb@isye.gatech.edu (John Bartholdi)
;;; (software-type) should be set to the generic operating system type.
;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
(define (software-type) 'MACOS)
;;; (scheme-implementation-type) should return the name of the scheme
;;; implementation loading this file.
(define (scheme-implementation-type) 'MacScheme)
;;; (scheme-implementation-home-page) should return a (string) URI
;;; (Uniform Resource Identifier) for this scheme implementation's home
;;; page; or false if there isn't one.
(define (scheme-implementation-home-page) #f)
;;; (scheme-implementation-version) should return a string describing
;;; the version the scheme implementation loading this file.
(define (scheme-implementation-version) "4.2")
;;; (implementation-vicinity) should be defined to be the pathname of
;;; the directory where any auxillary files to your Scheme
;;; implementation reside.
(define (implementation-vicinity) "Macintosh.HD:MacScheme 4.2:")
;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
(define (library-vicinity) "Macintosh.HD:MacScheme 4.2:slib:")
;;; (home-vicinity) should return the vicinity of the user's HOME
;;; directory, the directory which typically contains files which
;;; customize a computer environment for a user.
(define (home-vicinity) #f)
;;; *FEATURES* should be set to a list of symbols describing features
;;; of this implementation. Suggestions for features are:
(define *features*
'(
source ;can load scheme source files
;(slib:load-source "filename")
; compiled ;can load compiled files
;(slib:load-compiled "filename")
rev4-report ;conforms to
rev3-report ;conforms to
ieee-p1178 ;conforms to
; sicp ;runs code from Structure and
;Interpretation of Computer
;Programs by Abelson and Sussman.
rev4-optional-procedures ;LIST-TAIL, STRING->LIST,
;LIST->STRING, STRING-COPY,
;STRING-FILL!, LIST->VECTOR,
;VECTOR->LIST, and VECTOR-FILL!
rev3-procedures ;LAST-PAIR, T, and NIL
; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
;SUBSTRING-FILL!,
;STRING-NULL?, APPEND!, 1+,
;-1+, <?, <=?, =?, >?, >=?
multiarg/and- ;/ and - can take more than 2 args.
multiarg-apply ;APPLY can take more than 2 args.
rationalize
delay ;has DELAY and FORCE
with-file ;has WITH-INPUT-FROM-FILE and
;WITH-OUTPUT-FROM-FILE
string-port ;has CALL-WITH-INPUT-STRING and
;CALL-WITH-OUTPUT-STRING
; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
; char-ready?
; macro ;has R4RS high level macros
; defmacro ;has Common Lisp DEFMACRO
; record ;has user defined data structures
; values ;proposed multiple values
; dynamic-wind ;proposed dynamic-wind
ieee-floating-point ;conforms to
full-continuation ;can return multiple times
; object-hash ;has OBJECT-HASH
; sort
; queue ;queues
pretty-print
; object->string
; format
; trace ;has macros: TRACE and UNTRACE
compiler ;has (COMPILER)
; ed ;(ED) is editor
; system ;posix (system <string>)
; getenv ;posix (getenv <string>)
; program-arguments ;returns list of strings (argv)
; Xwindows ;X support
; curses ;screen management package
; termcap ;terminal description package
; terminfo ;sysV terminal description
))
;;; (OUTPUT-PORT-WIDTH <port>)
(define (output-port-width . arg) 79)
;;; (OUTPUT-PORT-HEIGHT <port>)
(define (output-port-height . arg) 24)
;;; (CURRENT-ERROR-PORT)
(define current-error-port
(let ((port (current-output-port)))
(lambda () port)))
;;; (TMPNAM) makes a temporary file name.
(define tmpnam (let ((cntr 100))
(lambda () (set! cntr (+ 1 cntr))
(string-append "slib_" (number->string cntr)))))
;;; (FILE-EXISTS? <string>)
(define (file-exists? f) #f)
;;; (DELETE-FILE <string>)
(define (delete-file f) #f)
;;; FORCE-OUTPUT flushes any pending output on optional arg output port
;;; use this definition if your system doesn't have such a procedure.
(define (force-output . arg) #t)
;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
;;; port versions of CALL-WITH-*PUT-FILE.
(define (call-with-output-string f)
(let ((outsp (open-output-string)))
(f outsp)
(let ((s (get-output-string outsp)))
(close-output-port outsp)
s)))
(define (call-with-input-string s f)
(let* ((insp (open-input-string s))
(res (f insp)))
(close-input-port insp)
res))
;;; "rationalize" adjunct procedures.
(define (find-ratio x e)
(let ((rat (rationalize x e)))
(list (numerator rat) (denominator rat))))
(define (find-ratio-between x y)
(find-ratio (/ (+ x y) 2) (/ (- x y) 2)))
;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
;;; be returned by CHAR->INTEGER.
(define char-code-limit 256)
;;; MOST-POSITIVE-FIXNUM is used in modular.scm
(define most-positive-fixnum 536870911)
;;; Return argument
(define (identity x) x)
;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
(define slib:eval eval)
;;; If your implementation provides R4RS macros:
;(define macro:eval slib:eval)
;(define macro:load load)
(define *defmacros*
(list (cons 'defmacro
(lambda (name parms . body)
`(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body))
*defmacros*))))))
(define (defmacro? m) (and (assq m *defmacros*) #t))
(define (macroexpand-1 e)
(if (pair? e) (let ((a (car e)))
(cond ((symbol? a) (set! a (assq a *defmacros*))
(if a (apply (cdr a) (cdr e)) e))
(else e)))
e))
(define (macroexpand e)
(if (pair? e) (let ((a (car e)))
(cond ((symbol? a)
(set! a (assq a *defmacros*))
(if a (macroexpand (apply (cdr a) (cdr e))) e))
(else e)))
e))
(define gentemp
(let ((*gensym-counter* -1))
(lambda ()
(set! *gensym-counter* (+ *gensym-counter* 1))
(string->symbol
(string-append "slib:G" (number->string *gensym-counter*))))))
(define base:eval slib:eval)
(define (defmacro:eval x) (base:eval (defmacro:expand* x)))
(define (defmacro:expand* x)
(require 'defmacroexpand) (apply defmacro:expand* x '()))
(define (defmacro:load <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))))
(call-with-input-file <pathname>
(lambda (port)
(let ((old-load-pathname *load-pathname*))
(set! *load-pathname* <pathname>)
(do ((o (read port) (read port)))
((eof-object? o))
(evl o))
(set! *load-pathname* old-load-pathname)))))
(define slib:warn
(lambda args
(let ((cep (current-error-port)))
(if (provided? 'trace) (print-call-stack cep))
(display "Warn: " cep)
(for-each (lambda (x) (display x cep)) args))))
;;; define an error procedure for the library
(define slib:error
(lambda args
(if (provided? 'trace) (print-call-stack (current-error-port)))
(cerror "Error: " args)))
;;; define these as appropriate for your system.
(define slib:tab #\tab)
(define slib:form-feed #\page)
;;; Define these if your implementation's syntax can support it and if
;;; they are not already defined.
;(define (1+ n) (+ n 1))
;(define (-1+ n) (+ n -1))
;(define 1- -1+)
(define in-vicinity string-append)
;;; Define SLIB:EXIT to be the implementation procedure to exit or
;;; return if exitting not supported.
; MacScheme does not return a value when it exits,
; so simply invoke system procedure exit with 0 args.
(define slib:exit (lambda args (exit)))
;;; Here for backward compatability
(define scheme-file-suffix
(let ((suffix (case (software-type)
((NOSVE) "_scm")
(else ".scm"))))
(lambda () suffix)))
;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
;;; suffix all the module files in SLIB have. See feature 'SOURCE.
;(define slib:load-source load)
(define (slib:load-source f) (load (string-append f (scheme-file-suffix))))
;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
;;; by compiling "foo.scm" if this implementation can compile files.
;;; See feature 'COMPILED.
(define slib:load-compiled load)
;;; At this point SLIB:LOAD must be able to load SLIB files.
(define slib:load slib:load-source)
(slib:load (in-vicinity (library-vicinity) "require"))

126
module/slib/macwork.scm
View file

@ -1,126 +0,0 @@
;;;; "macwork.scm": Will Clinger's macros that work. -*- Scheme -*-
;Copyright 1992 William Clinger
;
; Permission to copy this software, in whole or in part, to use this
; software for any lawful purpose, and to redistribute this software
; is granted subject to the restriction that all copies made of this
; software must include this copyright notice in full.
;
; I also request that you send me a copy of any improvements that you
; make to this software so that they may be incorporated within it to
; the benefit of the Scheme community.
(slib:load (in-vicinity (program-vicinity) "mwexpand"))
;;;; Miscellaneous routines.
(define (mw:warn msg . more)
(display "WARNING from macro expander:")
(newline)
(display msg)
(newline)
(for-each (lambda (x) (write x) (newline))
more))
(define (mw:error msg . more)
(display "ERROR detected during macro expansion:")
(newline)
(display msg)
(newline)
(for-each (lambda (x) (write x) (newline))
more)
(mw:quit #f))
(define (mw:bug msg . more)
(display "BUG in macro expander: ")
(newline)
(display msg)
(newline)
(for-each (lambda (x) (write x) (newline))
more)
(mw:quit #f))
; Given a <formals>, returns a list of bound variables.
(define (mw:make-null-terminated x)
(cond ((null? x) '())
((pair? x)
(cons (car x) (mw:make-null-terminated (cdr x))))
(else (list x))))
; Returns the length of the given list, or -1 if the argument
; is not a list. Does not check for circular lists.
(define (mw:safe-length x)
(define (loop x n)
(cond ((null? x) n)
((pair? x) (loop (cdr x) (+ n 1)))
(else -1)))
(loop x 0))
(require 'common-list-functions)
; Given an association list, copies the association pairs.
(define (mw:syntax-copy alist)
(map (lambda (x) (cons (car x) (cdr x)))
alist))
;;;; Implementation-dependent parameters and preferences that determine
; how identifiers are represented in the output of the macro expander.
;
; The basic problem is that there are no reserved words, so the
; syntactic keywords of core Scheme that are used to express the
; output need to be represented by data that cannot appear in the
; input. This file defines those data.
; The following definitions assume that identifiers of mixed case
; cannot appear in the input.
;(define mw:begin1 (string->symbol "Begin"))
;(define mw:define1 (string->symbol "Define"))
;(define mw:quote1 (string->symbol "Quote"))
;(define mw:lambda1 (string->symbol "Lambda"))
;(define mw:if1 (string->symbol "If"))
;(define mw:set!1 (string->symbol "Set!"))
(define mw:begin1 'begin)
(define mw:define1 'define)
(define mw:quote1 'quote)
(define mw:lambda1 'lambda)
(define mw:if1 'if)
(define mw:set!1 'set!)
; The following defines an implementation-dependent expression
; that evaluates to an undefined (not unspecified!) value, for
; use in expanding the (define x) syntax.
(define mw:undefined (list (string->symbol "Undefined")))
; A variable is renamed by suffixing a vertical bar followed by a unique
; integer. In IEEE and R4RS Scheme, a vertical bar cannot appear as part
; of an identifier, but presumably this is enforced by the reader and not
; by the compiler. Any other character that cannot appear as part of an
; identifier may be used instead of the vertical bar.
(define mw:suffix-character #\|)
(slib:load (in-vicinity (program-vicinity) "mwdenote"))
(slib:load (in-vicinity (program-vicinity) "mwsynrul"))
(define macro:expand macwork:expand)
;;; Here are EVAL, EVAL! and LOAD which expand macros. You can replace the
;;; implementation's eval and load with them if you like.
(define base:eval slib:eval)
(define base:load load)
(define (macwork:eval x) (base:eval (macwork:expand x)))
(define macro:eval macwork:eval)
(define (macwork:load <pathname>)
(slib:eval-load <pathname> macwork:eval))
(define macro:load macwork:load)
(provide 'macros-that-work)
(provide 'macro)

96
module/slib/makcrc.scm
View file

@ -1,96 +0,0 @@
;;;; "makcrc.scm" Compute Cyclic Checksums
;;; Copyright (C) 1995, 1996, 1997, 2001 Aubrey Jaffer.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;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 'byte)
(require 'logical)
(define (make-port-crc . margs)
(define (make-mask hibit)
(+ (ash (+ -1 (ash 1 (+ 1 (- hibit 2)))) 1) 1))
(define chunk-bits (integer-length (+ -1 char-code-limit)))
(define accum-bits #f)
(define generator #f)
(case (length margs)
((0) #t)
((1) (if (< (car margs) 128)
(set! accum-bits (car margs))
(set! generator (car margs))))
((2)
(set! accum-bits (car margs))
(set! generator (cadr margs)))
(else (slib:error 'make-port-crc 'args margs)))
(cond ((not generator)
(case accum-bits
((#f 32) (set! accum-bits 32)
(set! generator #b00000100110000010001110110110111)) ; CRC-32
((16) (set! generator #b0001000000001011)) ; CRC-16
;;((16) (set! generator #b0001000000100001)) ; CRC-CCIT
;;((08) (set! generator #b101011))
(else (slib:error 'make-port-crc "no default polynomial for"
accum-bits "bits"))))
((not accum-bits)
(set! accum-bits (+ -1 (integer-length generator)))))
(set! generator (logand generator (lognot (ash 1 accum-bits))))
(cond ((>= (integer-length generator) accum-bits)
(slib:error 'make-port-crc
"generator longer than" accum-bits "bits")))
(let* ((chunk-mask (make-mask chunk-bits))
(crctab (make-vector (+ 1 chunk-mask))))
(define (accum src)
`(set!
crc
(logxor (ash (logand ,(make-mask (- accum-bits chunk-bits)) crc)
,chunk-bits)
(vector-ref crctab
(logand ,chunk-mask
(logxor
(ash crc ,(- chunk-bits accum-bits))
,src))))))
(define (make-crc-table)
(letrec ((r (make-vector chunk-bits))
(remd (lambda (m)
(define rem 0)
(do ((i 0 (+ 1 i)))
((>= i chunk-bits) rem)
(if (logbit? i m)
(set! rem (logxor rem (vector-ref r i))))))))
(vector-set! r 0 generator)
(do ((i 1 (+ 1 i)))
((>= i chunk-bits))
(let ((r-1 (vector-ref r (+ -1 i)))
(m-1 (make-mask (+ -1 accum-bits))))
(vector-set! r i (if (logbit? (+ -1 accum-bits) r-1)
(logxor (ash (logand m-1 r-1) 1) generator)
(ash (logand m-1 r-1) 1)))))
(do ((i 0 (+ 1 i)))
((> i chunk-mask))
(vector-set! crctab i (remd i)))))
(make-crc-table)
`(lambda (port)
(define crc 0)
(define byte-count 0)
(define crctab ',crctab)
(do ((ci (read-byte port) (read-byte port)))
((eof-object? ci))
,(accum 'ci)
(set! byte-count (+ 1 byte-count)))
(do ((byte-count byte-count (ash byte-count ,(- chunk-bits))))
((zero? byte-count))
,(accum 'byte-count))
(logxor ,(make-mask accum-bits) crc))))

443
module/slib/mbe.scm
View file

@ -1,443 +0,0 @@
;;;; "mbe.scm" "Macro by Example" (Eugene Kohlbecker, R4RS)
;;; From: Dorai Sitaram, dorai@cs.rice.edu, 1991, 1999
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;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.
;;; revised Dec. 6, 1993 to R4RS syntax (if not semantics).
;;; revised Mar. 2 1994 for SLIB (jaffer@ai.mit.edu).
;;; corrections, Apr. 24, 1997.
;;; corr., Jan. 30, 1999. (mflatt@cs.rice.edu, dorai@cs.rice.edu)
;;; A vanilla implementation of hygienic macro-by-example as described
;;; by Eugene Kohlbecker and in R4RS Appendix. This file requires
;;; defmacro.
(require 'common-list-functions) ;nconc, some, every
;(require 'rev2-procedures) ;append! alternate for nconc
(require 'rev4-optional-procedures) ;list-tail
(require 'defmacroexpand)
(define hyg:rassq
(lambda (k al)
(let loop ((al al))
(if (null? al) #f
(let ((c (car al)))
(if (eq? (cdr c) k) c
(loop (cdr al))))))))
(define hyg:tag
(lambda (e kk al)
(cond ((pair? e)
(let* ((a-te-al (hyg:tag (car e) kk al))
(d-te-al (hyg:tag (cdr e) kk (cdr a-te-al))))
(cons (cons (car a-te-al) (car d-te-al))
(cdr d-te-al))))
((vector? e)
(list->vector
(hyg:tag (vector->list e) kk al)))
((symbol? e)
(cond ((eq? e '...) (cons '... al))
((memq e kk) (cons e al))
((hyg:rassq e al) =>
(lambda (c)
(cons (car c) al)))
(else
(let ((te (gentemp)))
(cons te (cons (cons te e) al))))))
(else (cons e al)))))
;;untagging
(define hyg:untag
(lambda (e al tmps)
(if (pair? e)
(let ((a (hyg:untag (car e) al tmps)))
(if (list? e)
(case a
((quote) (hyg:untag-no-tags e al))
((quasiquote) (list a (hyg:untag-quasiquote (cadr e) al tmps)))
((if begin)
`(,a ,@(map (lambda (e1)
(hyg:untag e1 al tmps)) (cdr e))))
((set! define)
`(,a ,(hyg:untag-vanilla (cadr e) al tmps)
,@(map (lambda (e1)
(hyg:untag e1 al tmps)) (cddr e))))
((lambda) (hyg:untag-lambda (cadr e) (cddr e) al tmps))
((letrec) (hyg:untag-letrec (cadr e) (cddr e) al tmps))
((let)
(let ((e2 (cadr e)))
(if (symbol? e2)
(hyg:untag-named-let e2 (caddr e) (cdddr e) al tmps)
(hyg:untag-let e2 (cddr e) al tmps))))
((let*) (hyg:untag-let* (cadr e) (cddr e) al tmps))
((do) (hyg:untag-do (cadr e) (caddr e) (cdddr e) al tmps))
((case)
`(case ,(hyg:untag-vanilla (cadr e) al tmps)
,@(map
(lambda (c)
`(,(hyg:untag-vanilla (car c) al tmps)
,@(hyg:untag-list (cdr c) al tmps)))
(cddr e))))
((cond)
`(cond ,@(map
(lambda (c)
(hyg:untag-list c al tmps))
(cdr e))))
(else (cons a (hyg:untag-list (cdr e) al tmps))))
(cons a (hyg:untag-list* (cdr e) al tmps))))
(hyg:untag-vanilla e al tmps))))
(define hyg:untag-list
(lambda (ee al tmps)
(map (lambda (e)
(hyg:untag e al tmps)) ee)))
(define hyg:untag-list*
(lambda (ee al tmps)
(let loop ((ee ee))
(if (pair? ee)
(cons (hyg:untag (car ee) al tmps)
(loop (cdr ee)))
(hyg:untag ee al tmps)))))
(define hyg:untag-no-tags
(lambda (e al)
(cond ((pair? e)
(cons (hyg:untag-no-tags (car e) al)
(hyg:untag-no-tags (cdr e) al)))
((vector? e)
(list->vector
(hyg:untag-no-tags (vector->list e) al)))
((not (symbol? e)) e)
((assq e al) => cdr)
(else e))))
(define hyg:untag-quasiquote
(lambda (form al tmps)
(let qq ((x form) (level 0))
(cond
((pair? x)
(let ((first (qq (car x) level)))
(cond
((and (eq? first 'unquote) (list? x))
(let ((rest (cdr x)))
(if (or (not (pair? rest))
(not (null? (cdr rest))))
(slib:error 'unquote 'takes-exactly-one-expression)
(if (zero? level)
(list 'unquote (hyg:untag (car rest) al tmps))
(cons first (qq rest (sub1 level)))))))
((and (eq? first 'quasiquote) (list? x))
(cons 'quasiquote (qq (cdr x) (add1 level))))
((and (eq? first 'unquote-splicing) (list? x))
(slib:error 'unquote-splicing 'invalid-context-within-quasiquote))
((pair? first)
(let ((car-first (qq (car first) level)))
(if (and (eq? car-first 'unquote-splicing)
(list? first))
(let ((rest (cdr first)))
(if (or (not (pair? rest))
(not (null? (cdr rest))))
(slib:error 'unquote-splicing
'takes-exactly-one-expression)
(list (list 'unquote-splicing
(if (zero? level)
(hyg:untag (cadr rest) al tmps)
(qq (cadr rest) (sub1 level)))
(qq (cdr x) level)))))
(cons (cons car-first
(qq (cdr first) level))
(qq (cdr x) level)))))
(else
(cons first (qq (cdr x) level))))))
((vector? x)
(list->vector
(qq (vector->list x) level)))
(else (hyg:untag-no-tags x al))))))
(define hyg:untag-lambda
(lambda (bvv body al tmps)
(let ((tmps2 (nconc (hyg:flatten bvv) tmps)))
`(lambda ,bvv
,@(hyg:untag-list body al tmps2)))))
(define hyg:untag-letrec
(lambda (varvals body al tmps)
(let ((tmps (nconc (map car varvals) tmps)))
`(letrec
,(map
(lambda (varval)
`(,(car varval)
,(hyg:untag (cadr varval) al tmps)))
varvals)
,@(hyg:untag-list body al tmps)))))
(define hyg:untag-let
(lambda (varvals body al tmps)
(let ((tmps2 (nconc (map car varvals) tmps)))
`(let
,(map
(lambda (varval)
`(,(car varval)
,(hyg:untag (cadr varval) al tmps)))
varvals)
,@(hyg:untag-list body al tmps2)))))
(define hyg:untag-named-let
(lambda (lname varvals body al tmps)
(let ((tmps2 (cons lname (nconc (map car varvals) tmps))))
`(let ,lname
,(map
(lambda (varval)
`(,(car varval)
,(hyg:untag (cadr varval) al tmps)))
varvals)
,@(hyg:untag-list body al tmps2)))))
(define hyg:untag-let*
(lambda (varvals body al tmps)
(let ((tmps2 (nconc (nreverse (map car varvals)) tmps)))
`(let*
,(let loop ((varvals varvals)
(i (length varvals)))
(if (null? varvals) '()
(let ((varval (car varvals)))
(cons `(,(car varval)
,(hyg:untag (cadr varval)
al (list-tail tmps2 i)))
(loop (cdr varvals) (- i 1))))))
,@(hyg:untag-list body al tmps2)))))
(define hyg:untag-do
(lambda (varinistps exit-test body al tmps)
(let ((tmps2 (nconc (map car varinistps) tmps)))
`(do
,(map
(lambda (varinistp)
(let ((var (car varinistp)))
`(,var ,@(hyg:untag-list (cdr varinistp) al
(cons var tmps)))))
varinistps)
,(hyg:untag-list exit-test al tmps2)
,@(hyg:untag-list body al tmps2)))))
(define hyg:untag-vanilla
(lambda (e al tmps)
(cond ((pair? e)
(cons (hyg:untag-vanilla (car e) al tmps)
(hyg:untag-vanilla (cdr e) al tmps)))
((vector? e)
(list->vector
(hyg:untag-vanilla (vector->list e) al tmps)))
((not (symbol? e)) e)
((memq e tmps) e)
((assq e al) => cdr)
(else e))))
(define hyg:flatten
(lambda (e)
(let loop ((e e) (r '()))
(cond ((pair? e) (loop (car e)
(loop (cdr e) r)))
((null? e) r)
(else (cons e r))))))
;;;; End of hygiene filter.
;;; finds the leftmost index of list l where something equal to x
;;; occurs
(define mbe:position
(lambda (x l)
(let loop ((l l) (i 0))
(cond ((not (pair? l)) #f)
((equal? (car l) x) i)
(else (loop (cdr l) (+ i 1)))))))
;;; (mbe:append-map f l) == (apply append (map f l))
(define mbe:append-map
(lambda (f l)
(let loop ((l l))
(if (null? l) '()
(append (f (car l)) (loop (cdr l)))))))
;;; tests if expression e matches pattern p where k is the list of
;;; keywords
(define mbe:matches-pattern?
(lambda (p e k)
(cond ((mbe:ellipsis? p)
(and (or (null? e) (pair? e))
(let* ((p-head (car p))
(p-tail (cddr p))
(e-head=e-tail (mbe:split-at-ellipsis e p-tail)))
(and e-head=e-tail
(let ((e-head (car e-head=e-tail))
(e-tail (cdr e-head=e-tail)))
(and (every
(lambda (x) (mbe:matches-pattern? p-head x k))
e-head)
(mbe:matches-pattern? p-tail e-tail k)))))))
((pair? p)
(and (pair? e)
(mbe:matches-pattern? (car p) (car e) k)
(mbe:matches-pattern? (cdr p) (cdr e) k)))
((symbol? p) (if (memq p k) (eq? p e) #t))
(else (equal? p e)))))
;;; gets the bindings of pattern variables of pattern p for
;;; expression e;
;;; k is the list of keywords
(define mbe:get-bindings
(lambda (p e k)
(cond ((mbe:ellipsis? p)
(let* ((p-head (car p))
(p-tail (cddr p))
(e-head=e-tail (mbe:split-at-ellipsis e p-tail))
(e-head (car e-head=e-tail))
(e-tail (cdr e-head=e-tail)))
(cons (cons (mbe:get-ellipsis-nestings p-head k)
(map (lambda (x) (mbe:get-bindings p-head x k))
e-head))
(mbe:get-bindings p-tail e-tail k))))
((pair? p)
(append (mbe:get-bindings (car p) (car e) k)
(mbe:get-bindings (cdr p) (cdr e) k)))
((symbol? p)
(if (memq p k) '() (list (cons p e))))
(else '()))))
;;; expands pattern p using environment r;
;;; k is the list of keywords
(define mbe:expand-pattern
(lambda (p r k)
(cond ((mbe:ellipsis? p)
(append (let* ((p-head (car p))
(nestings (mbe:get-ellipsis-nestings p-head k))
(rr (mbe:ellipsis-sub-envs nestings r)))
(map (lambda (r1)
(mbe:expand-pattern p-head (append r1 r) k))
rr))
(mbe:expand-pattern (cddr p) r k)))
((pair? p)
(cons (mbe:expand-pattern (car p) r k)
(mbe:expand-pattern (cdr p) r k)))
((symbol? p)
(if (memq p k) p
(let ((x (assq p r)))
(if x (cdr x) p))))
(else p))))
;;; returns a list that nests a pattern variable as deeply as it
;;; is ellipsed
(define mbe:get-ellipsis-nestings
(lambda (p k)
(let sub ((p p))
(cond ((mbe:ellipsis? p) (cons (sub (car p)) (sub (cddr p))))
((pair? p) (append (sub (car p)) (sub (cdr p))))
((symbol? p) (if (memq p k) '() (list p)))
(else '())))))
;;; finds the subenvironments in r corresponding to the ellipsed
;;; variables in nestings
(define mbe:ellipsis-sub-envs
(lambda (nestings r)
(let ((sub-envs-list
(let loop ((r r) (sub-envs-list '()))
(if (null? r) (nreverse sub-envs-list)
(let ((c (car r)))
(loop (cdr r)
(if (mbe:contained-in? nestings (car c))
(cons (cdr c) sub-envs-list)
sub-envs-list)))))))
(case (length sub-envs-list)
((0) #f)
((1) (car sub-envs-list))
(else
(let loop ((sub-envs-list sub-envs-list) (final-sub-envs '()))
(if (some null? sub-envs-list) (nreverse final-sub-envs)
(loop (map cdr sub-envs-list)
(cons (mbe:append-map car sub-envs-list)
final-sub-envs)))))))))
;;; checks if nestings v and y have an intersection
(define mbe:contained-in?
(lambda (v y)
(if (or (symbol? v) (symbol? y)) (eq? v y)
(some (lambda (v_i)
(some (lambda (y_j)
(mbe:contained-in? v_i y_j))
y))
v))))
;;; split expression e so that its second half matches with
;;; pattern p-tail
(define mbe:split-at-ellipsis
(lambda (e p-tail)
(if (null? p-tail) (cons e '())
(let ((i (mbe:position (car p-tail) e)))
(if i (cons (butlast e (- (length e) i))
(list-tail e i))
(slib:error 'mbe:split-at-ellipsis 'bad-arg))))))
;;; tests if x is an ellipsing pattern, i.e., of the form
;;; (blah ... . blah2)
(define mbe:ellipsis?
(lambda (x)
(and (pair? x) (pair? (cdr x)) (eq? (cadr x) '...))))
;define-syntax
(defmacro define-syntax (macro-name syn-rules)
(if (or (not (pair? syn-rules))
(not (eq? (car syn-rules) 'syntax-rules)))
(slib:error 'define-syntax 'not-an-r4rs-high-level-macro
macro-name syn-rules)
(let ((keywords (cons macro-name (cadr syn-rules)))
(clauses (cddr syn-rules)))
`(defmacro ,macro-name macro-arg
(let ((macro-arg (cons ',macro-name macro-arg))
(keywords ',keywords))
(cond ,@(map
(lambda (clause)
(let ((in-pattern (car clause))
(out-pattern (cadr clause)))
`((mbe:matches-pattern? ',in-pattern macro-arg
keywords)
(let ((tagged-out-pattern+alist
(hyg:tag
',out-pattern
(nconc (hyg:flatten ',in-pattern)
keywords) '())))
(hyg:untag
(mbe:expand-pattern
(car tagged-out-pattern+alist)
(mbe:get-bindings ',in-pattern macro-arg
keywords)
keywords)
(cdr tagged-out-pattern+alist)
'())))))
clauses)
(else (slib:error ',macro-name 'no-matching-clause
',clauses))))))))
(define macro:eval slib:eval)
(define macro:load slib:load)
(provide 'macro)
;eof

114
module/slib/minimize.scm
View file

@ -1,114 +0,0 @@
;;; "minimize.scm" finds minimum f(x) for x0 <= x <= x1.
;;; Author: Lars Arvestad
;;;
;;; This code is in the public domain.
;;@noindent
;;
;;The Golden Section Search
;;@footnote{David Kahaner, Cleve Moler, and Stephen Nash
;;@cite{Numerical Methods and Software}
;;Prentice-Hall, 1989, ISBN 0-13-627258-4}
;;algorithm finds minima of functions which
;;are expensive to compute or for which derivatives are not available.
;;Although optimum for the general case, convergence is slow,
;;requiring nearly 100 iterations for the example (x^3-2x-5).
;;
;;@noindent
;;
;;If the derivative is available, Newton-Raphson is probably a better
;;choice. If the function is inexpensive to compute, consider
;;approximating the derivative.
;;@body
;;
;;@var{x_0} are @var{x_1} real numbers. The (single argument)
;;procedure @var{f} is unimodal over the open interval (@var{x_0},
;;@var{x_1}). That is, there is exactly one point in the interval for
;;which the derivative of @var{f} is zero.
;;
;;@0 returns a pair (@var{x} . @var{f}(@var{x})) where @var{f}(@var{x})
;;is the minimum. The @var{prec} parameter is the stop criterion. If
;;@var{prec} is a positive number, then the iteration continues until
;;@var{x} is within @var{prec} from the true value. If @var{prec} is
;;a negative integer, then the procedure will iterate @var{-prec}
;;times or until convergence. If @var{prec} is a procedure of seven
;;arguments, @var{x0}, @var{x1}, @var{a}, @var{b}, @var{fa}, @var{fb},
;;and @var{count}, then the iterations will stop when the procedure
;;returns @code{#t}.
;;
;;Analytically, the minimum of x^3-2x-5 is 0.816497.
;;@example
;;(define func (lambda (x) (+ (* x (+ (* x x) -2)) -5)))
;;(golden-section-search func 0 1 (/ 10000))
;; ==> (816.4883855245578e-3 . -6.0886621077391165)
;;(golden-section-search func 0 1 -5)
;; ==> (819.6601125010515e-3 . -6.088637561916407)
;;(golden-section-search func 0 1
;; (lambda (a b c d e f g ) (= g 500)))
;; ==> (816.4965933140557e-3 . -6.088662107903635)
;;@end example
(define golden-section-search
(let ((gss 'golden-section-search:)
(r (/ (- (sqrt 5) 1) 2))) ; 1 / golden-section
(lambda (f x0 x1 prec)
(cond ((not (procedure? f)) (slib:error gss 'procedure? f))
((not (number? x0)) (slib:error gss 'number? x0))
((not (number? x1)) (slib:error gss 'number? x1))
((>= x0 x1) (slib:error gss x0 'not '< x1)))
(let ((stop?
(cond
((procedure? prec) prec)
((number? prec)
(if (>= prec 0)
(lambda (x0 x1 a b fa fb count) (<= (abs (- x1 x0)) prec))
(if (integer? prec)
(lambda (x0 x1 a b fa fb count) (>= count (- prec)))
(slib:error gss 'integer? prec))))
(else (slib:error gss 'procedure? prec))))
(a0 (+ x0 (* (- x1 x0) (- 1 r))))
(b0 (+ x0 (* (- x1 x0) r)))
(delta #f)
(fmax #f)
(fmin #f))
(let loop ((left x0)
(right x1)
(a a0)
(b b0)
(fa (f a0))
(fb (f b0))
(count 1))
(define finish
(lambda (x fx)
(if (> fx fmin) (slib:warn gss fx 'not 'min (list '> fmin)))
(if (and (> count 9) (or (eqv? x0 left) (eqv? x1 right)))
(slib:warn gss 'min 'not 'found))
(cons x fx)))
(case count
((1)
(set! fmax (max fa fb))
(set! fmin (min fa fb)))
((2)
(set! fmin (min fmin fa fb))
(if (eqv? fmax fa fb) (slib:error gss 'flat? fmax)))
(else
(set! fmin (min fmin fa fb))))
(cond ((stop? left right a b fa fb count)
(if (< fa fb)
(finish a fa)
(finish b fb)))
((< fa fb)
(let ((a-next (+ left (* (- b left) (- 1 r)))))
(cond ((and delta (< delta (- b a)))
(finish a fa))
(else (set! delta (- b a))
(loop left b a-next a (f a-next) fa
(+ 1 count))))))
(else
(let ((b-next (+ a (* (- right a) r))))
(cond ((and delta (< delta (- b a)))
(finish b fb))
(else (set! delta (- b a))
(loop a right b b-next fb (f b-next)
(+ 1 count))))))))))))

48
module/slib/minimize.txi
View file

@ -1,48 +0,0 @@
@noindent
The Golden Section Search
@footnote{David Kahaner, Cleve Moler, and Stephen Nash
@cite{Numerical Methods and Software}
Prentice-Hall, 1989, ISBN 0-13-627258-4}
algorithm finds minima of functions which
are expensive to compute or for which derivatives are not available.
Although optimum for the general case, convergence is slow,
requiring nearly 100 iterations for the example (x^3-2x-5).
@noindent
If the derivative is available, Newton-Raphson is probably a better
choice. If the function is inexpensive to compute, consider
approximating the derivative.
@defun golden-section-search f x0 x1 prec
@var{x_0} are @var{x_1} real numbers. The (single argument)
procedure @var{f} is unimodal over the open interval (@var{x_0},
@var{x_1}). That is, there is exactly one point in the interval for
which the derivative of @var{f} is zero.
@code{golden-section-search} returns a pair (@var{x} . @var{f}(@var{x})) where @var{f}(@var{x})
is the minimum. The @var{prec} parameter is the stop criterion. If
@var{prec} is a positive number, then the iteration continues until
@var{x} is within @var{prec} from the true value. If @var{prec} is
a negative integer, then the procedure will iterate @var{-prec}
times or until convergence. If @var{prec} is a procedure of seven
arguments, @var{x0}, @var{x1}, @var{a}, @var{b}, @var{fa}, @var{fb},
and @var{count}, then the iterations will stop when the procedure
returns @code{#t}.
Analytically, the minimum of x^3-2x-5 is 0.816497.
@example
(define func (lambda (x) (+ (* x (+ (* x x) -2)) -5)))
(golden-section-search func 0 1 (/ 10000))
==> (816.4883855245578e-3 . -6.0886621077391165)
(golden-section-search func 0 1 -5)
==> (819.6601125010515e-3 . -6.088637561916407)
(golden-section-search func 0 1
(lambda (a b c d e f g ) (= g 500)))
==> (816.4965933140557e-3 . -6.088662107903635)
@end example
@end defun

1466
module/slib/mitcomp.pat
View file

File diff suppressed because it is too large Load diff

283
module/slib/mitscheme.init
View file

@ -1,283 +0,0 @@
;;;"mitscheme.init" Initialization for SLIB for MITScheme -*-scheme-*-
;;; Author: Aubrey Jaffer
;;;
;;; This code is in the public domain.
;;; 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) (if (getenv "HOMEDRIVE") 'MS-DOS 'UNIX))
;;; (scheme-implementation-type) should return the name of the scheme
;;; implementation loading this file.
(define (scheme-implementation-type) 'MITScheme)
;;; (scheme-implementation-home-page) should return a (string) URI
;;; (Uniform Resource Identifier) for this scheme implementation's home
;;; page; or false if there isn't one.
(define (scheme-implementation-home-page)
"http://swissnet.ai.mit.edu/scheme-home.html")
;;; (scheme-implementation-version) should return a string describing
;;; the version the scheme implementation loading this file.
(define (scheme-implementation-version)
(let* ((str (with-output-to-string identify-world))
(beg (+ (string-search-forward "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
;;; implementation reside.
(define (implementation-vicinity)
(case (software-type)
((MS-DOS) "c:\\scheme\\")
((UNIX) "/usr/local/lib/mit-scheme/")
((VMS) "scheme$src:")))
;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
(define library-vicinity
(let ((library-path
(or (getenv "SCHEME_LIBRARY_PATH")
;; 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:")
(else "")))))
(lambda () library-path)))
;;; (home-vicinity) should return the vicinity of the user's HOME
;;; directory, the directory which typically contains files which
;;; customize a computer environment for a user.
(define home-vicinity
(let ((home-path (getenv "HOME")))
(lambda () home-path)))
;;; *features* should be set to a list of symbols describing features
;;; of this implementation. See Template.scm for the list of feature
;;; names.
(define *features*
'(
source ;can load scheme source files
;(slib:load-source "filename")
compiled ;can load compiled files
;(slib:load-compiled "filename")
rev4-report
ieee-p1178
sicp
rev4-optional-procedures
rev3-procedures
rev2-procedures
multiarg/and-
multiarg-apply
rationalize
object-hash
delay
with-file
string-port
transcript
char-ready?
record
values
dynamic-wind
ieee-floating-point
full-continuation
; sort
queue
pretty-print
object->string
trace ;has macros: TRACE and UNTRACE
defmacro
compiler
getenv
Xwindows
current-time
))
(define current-time current-file-time)
(define difftime -)
(define offset-time +)
;;; (OUTPUT-PORT-WIDTH <port>)
(define output-port-width output-port/x-size)
;;; (OUTPUT-PORT-HEIGHT <port>)
(define (output-port-height . arg) 24)
;;; (CURRENT-ERROR-PORT)
(define current-error-port
(let ((port console-output-port))
(lambda () port)))
;;; (TMPNAM) makes a temporary file name.
(define tmpnam
(let ((cntr 100))
(lambda () (set! cntr (+ 1 cntr))
(let ((tmp (string-append "slib_" (number->string cntr))))
(if (file-exists? tmp) (tmpnam) tmp)))))
;;; FORCE-OUTPUT flushes any pending output on optional arg output port.
(define force-output flush-output)
;;; MITScheme 7.2 is missing flush-output. Use this instead
;(define (force-output . arg) #t)
;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
;;; port versions of CALL-WITH-*PUT-FILE.
(define (call-with-output-string proc)
(let ((co (current-output-port)))
(with-output-to-string
(lambda ()
(let ((port (current-output-port)))
(with-output-to-port co
(lambda () (proc port))))))))
(define (call-with-input-string string proc)
(let ((ci (current-input-port)))
(with-input-from-string string
(lambda ()
(let ((port (current-input-port)))
(with-input-from-port ci
(lambda () (proc port))))))))
(define object->string write-to-string)
(define object->limited-string write-to-string)
;;; "rationalize" adjunct procedures.
(define (find-ratio x e)
(let ((rat (rationalize x e)))
(list (numerator rat) (denominator rat))))
(define (find-ratio-between x y)
(find-ratio (/ (+ x y) 2) (/ (- x y) 2)))
;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
;;; be returned by CHAR->INTEGER. It is defined incorrectly (65536)
;;; by MITScheme version 8.0.
(define char-code-limit 256)
;;; MOST-POSITIVE-FIXNUM is used in modular.scm
(define most-positive-fixnum #x03FFFFFF)
;;; Return argument
(define (identity x) x)
;;; 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))
(define *macros* '(defmacro))
(define (defmacro? m) (and (memq m *macros*) #t))
(syntax-table-define system-global-syntax-table 'defmacro
(macro defmacargs
(let ((macname (car defmacargs)) (macargs (cadr defmacargs))
(macbdy (cddr defmacargs)))
`(begin
(set! *macros* (cons ',macname *macros*))
(syntax-table-define system-global-syntax-table ',macname
(macro ,macargs ,@macbdy))))))
(define (macroexpand-1 e)
(if (pair? e) (let ((a (car e)))
(if (and (symbol? a) (defmacro? a))
(apply (syntax-table-ref system-global-syntax-table a)
(cdr e))
e))
e))
(define (macroexpand e)
(if (pair? e) (let ((a (car e)))
(if (and (symbol? a) (defmacro? a))
(macroexpand
(apply (syntax-table-ref system-global-syntax-table a)
(cdr e)))
e))
e))
(define gentemp
(let ((*gensym-counter* -1))
(lambda ()
(set! *gensym-counter* (+ *gensym-counter* 1))
(string->symbol
(string-append "slib:G" (number->string *gensym-counter*))))))
(define defmacro:eval slib:eval)
(define defmacro:load load)
;;; If your implementation provides R4RS macros:
;(define macro:eval slib:eval)
;(define macro:load load)
(define (slib:eval-load <pathname> evl)
(if (not (file-exists? <pathname>))
(set! <pathname> (string-append <pathname> (scheme-file-suffix))))
(call-with-input-file <pathname>
(lambda (port)
(let ((old-load-pathname *load-pathname*))
(set! *load-pathname* <pathname>)
(do ((o (read port) (read port)))
((eof-object? o))
(evl o))
(set! *load-pathname* old-load-pathname)))))
(define record-modifier record-updater) ;some versions need this?
(define slib:warn
(lambda args
(let ((cep (current-error-port)))
(if (provided? 'trace) (print-call-stack cep))
(display "Warn: " cep)
(for-each (lambda (x) (display x cep)) args))))
;; define an error procedure for the library
(define (slib:error . args)
(if (provided? 'trace) (print-call-stack (current-error-port)))
(apply error-procedure (append args (list (the-environment)))))
;; define these as appropriate for your system.
(define slib:tab (integer->char 9))
(define slib:form-feed (integer->char 12))
(define in-vicinity string-append)
;;; Define SLIB:EXIT to be the implementation procedure to exit or
;;; return if exitting not supported.
(define slib:exit
(lambda args
(cond ((null? args) (exit))
((eqv? #t (car args)) (exit))
((and (number? (car args)) (integer? (car args))) (exit (car args)))
(else (exit 1)))))
;;; Here for backward compatability
(define (scheme-file-suffix) ".scm")
;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
;;; suffix all the module files in SLIB have. See feature 'SOURCE.
(define slib:load-source load)
;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
;;; by compiling "foo.scm" if this implementation can compile files.
;;; See feature 'COMPILED.
(define slib:load-compiled load)
;;; At this point SLIB:LOAD must be able to load SLIB files.
(define slib:load slib:load-source)
(slib:load (in-vicinity (library-vicinity) "require.scm"))

198
module/slib/mklibcat.scm
View file

@ -1,198 +0,0 @@
;"mklibcat.scm" Build catalog for SLIB
;Copyright (C) 1997 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;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.
(call-with-output-file (in-vicinity (implementation-vicinity) "slibcat")
(lambda (op)
(display ";\"slibcat\" SLIB catalog for " op)
(display (scheme-implementation-type) op)
(display (scheme-implementation-version) op)
(display ". -*-scheme-*-" op) (newline op)
(display ";" op) (newline op)
(display "; DO NOT EDIT THIS FILE -- it is automagically generated" op)
(newline op) (newline op)
(display "(" op) (newline op)
(for-each
(lambda (asp) (display " " op) (write asp op) (newline op))
(append
(list (cons 'schelog
(in-vicinity (sub-vicinity (library-vicinity) "schelog")
"schelog"))
(cons 'portable-scheme-debugger
(in-vicinity (sub-vicinity (library-vicinity) "psd")
"psd-slib"))
(cons 'jfilter
(in-vicinity (sub-vicinity (library-vicinity) "jfilter")
"jfilter")))
(map (lambda (p)
(if (symbol? (cdr p)) p
(cons
(car p)
(if (pair? (cdr p))
(cons
(cadr p)
(in-vicinity (library-vicinity) (cddr p)))
(in-vicinity (library-vicinity) (cdr p))))))
'(
(rev4-optional-procedures . "sc4opt")
(rev2-procedures . "sc2")
(multiarg/and- . "mularg")
(multiarg-apply . "mulapply")
(rationalize . "ratize")
(transcript . "trnscrpt")
(with-file . "withfile")
(dynamic-wind . "dynwind")
(dynamic . "dynamic")
(fluid-let defmacro . "fluidlet")
(alist . "alist")
(hash . "hash")
(sierpinski . "sierpinski")
(soundex . "soundex")
(hash-table . "hashtab")
(logical . "logical")
(random . "random")
(random-inexact . "randinex")
(modular . "modular")
(factor . "factor")
(primes . factor)
(charplot . "charplot")
(sort . "sort")
(tsort . topological-sort)
(topological-sort . "tsort")
(common-list-functions . "comlist")
(tree . "tree")
(coerce . "coerce")
(format . "format")
(generic-write . "genwrite")
(pretty-print . "pp")
(pprint-file . "ppfile")
(object->string . "obj2str")
(string-case . "strcase")
(stdio . "stdio")
(printf . "printf")
(scanf . "scanf")
(line-i/o . "lineio")
(string-port . "strport")
(getopt . "getopt")
(debug . "debug")
(qp . "qp")
(break defmacro . "break")
(trace defmacro . "trace")
(eval . "eval")
(record . "record")
(promise . "promise")
(synchk . "synchk")
(defmacroexpand . "defmacex")
(macro-by-example defmacro . "mbe")
(syntax-case . "scainit")
(syntactic-closures . "scmacro")
(macros-that-work . "macwork")
(macro . macro-by-example)
(object . "object")
(yasos macro . "yasyn")
(oop . yasos)
(collect macro . "collect")
(struct defmacro . "struct")
(structure syntax-case . "structure")
(values . "values")
(queue . "queue")
(priority-queue . "priorque")
(array . "array")
(array-for-each . "arraymap")
(repl . "repl")
(process . "process")
(chapter-order . "chap")
(posix-time . "psxtime")
(common-lisp-time . "cltime")
(time-zone . "timezone")
(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")
(fft . "fft")
(wt-tree . "wttree")
(string-search . "strsrch")
(root . "root")
(minimize . "minimize")
(precedence-parse . "prec")
(parse . precedence-parse)
(commutative-ring . "cring")
(self-set . "selfset")
(determinant . "determ")
(byte . "byte")
(tzfile . "tzfile")
(schmooz . "schmooz")
(net-clients . "nclients")
(db->html . "db2html")
(http . "http-cgi")
(cgi . http)
(uri . "uri")
(uniform-resource-identifier . uri)
(pnm . "pnm")
(metric-units . "simetrix")
(new-catalog . "mklibcat")
))))
(display " " op)
(let* ((req (in-vicinity (library-vicinity)
(string-append "require" (scheme-file-suffix)))))
(write (cons '*SLIB-VERSION* (or (require:version req) *SLIB-VERSION*))
op))
(newline op)
(display ")" op) (newline op)
(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)
(let ((path (in-vicinity vicinity name)))
(and (file-exists? path)
(call-with-input-file path
(lambda (ip)
(newline op)
(display "; " op)
(write path op)
(display " SLIB " op)
(display specificity op)
(display "-specific catalog additions" op)
(newline op) (newline op)
(do ((c (read-char ip) (read-char ip)))
((eof-object? c))
(write-char c op)))))))))
(catcat (library-vicinity) "sitecat" "site")
(catcat (implementation-vicinity) "implcat" "implementation")
(catcat (implementation-vicinity) "sitecat" "site"))
))
(set! *catalog* #f)

158
module/slib/modular.scm
View file

@ -1,158 +0,0 @@
;;;; "modular.scm", modular fixnum arithmetic for Scheme
;;; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(define (symmetric:modulus n)
(cond ((or (not (number? n)) (not (positive? n)) (even? n))
(slib:error 'symmetric:modulus n))
(else (quotient (+ -1 n) -2))))
(define (modulus->integer m)
(cond ((negative? m) (- 1 m m))
((zero? m) #f)
(else m)))
(define (modular:normalize m k)
(cond ((positive? m) (modulo k m))
((zero? m) k)
((<= m k (- m)) k)
((or (provided? 'bignum)
(<= m (quotient (+ -1 most-positive-fixnum) 2)))
(let* ((pm (+ 1 (* -2 m)))
(s (modulo k pm)))
(if (<= s (- m)) s (- s pm))))
((positive? k) (+ (+ (+ k -1) m) m))
(else (- (- (+ k 1) m) m))))
;;;; NOTE: The rest of these functions assume normalized arguments!
(require 'logical)
(define (modular:extended-euclid x y)
(define q 0)
(do ((r0 x r1) (r1 y (remainder r0 r1))
(u0 1 u1) (u1 0 (- u0 (* q u1)))
(v0 0 v1) (v1 1 (- v0 (* q v1))))
;; (assert (= r0 (+ (* u0 x) (* v0 y))))
;; (assert (= r1 (+ (* u1 x) (* v1 y))))
((zero? r1) (list r0 u0 v0))
(set! q (quotient r0 r1))))
(define (modular:invertable? m a)
(eqv? 1 (gcd (or (modulus->integer m) 0) a)))
(define (modular:invert m a)
(cond ((eqv? 1 (abs a)) a) ; unit
(else
(let ((pm (modulus->integer m)))
(cond
(pm
(let ((d (modular:extended-euclid (modular:normalize pm a) pm)))
(if (= 1 (car d))
(modular:normalize m (cadr d))
(slib:error 'modular:invert "can't invert" m a))))
(else (slib:error 'modular:invert "can't invert" m a)))))))
(define (modular:negate m a)
(if (zero? a) 0
(if (negative? m) (- a)
(- m a))))
;;; Being careful about overflow here
(define (modular:+ m a b)
(cond ((positive? m)
(modulo (+ (- a m) b) m))
((zero? m) (+ a b))
((negative? a)
(if (negative? b)
(let ((s (+ (- a m) b)))
(if (negative? s)
(- s -1 m)
(+ s m)))
(+ a b)))
((negative? b) (+ a b))
(else (let ((s (+ (+ a m) b)))
(if (positive? s)
(+ s -1 m)
(- s m))))))
(define (modular:- m a b)
(cond ((positive? m) (modulo (- a b) m))
((zero? m) (- a b))
(else (modular:+ m a (- b)))))
;;; See: L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package
;;; with Splitting Facilities." ACM Transactions on Mathematical
;;; Software, 17:98-111 (1991)
;;; modular:r = 2**((nb-2)/2) where nb = number of bits in a word.
(define modular:r
(ash 1 (quotient (integer-length most-positive-fixnum) 2)))
(define modular:*
(if (provided? 'bignum)
(lambda (m a b)
(cond ((zero? m) (* a b))
((positive? m) (modulo (* a b) m))
(else (modular:normalize m (* a b)))))
(lambda (m a b)
(let ((a0 a)
(p 0))
(cond
((zero? m) (* a b))
((negative? m)
"This doesn't work for the full range of modulus M;"
"Someone please create or convert the following"
"algorighm to work with symmetric representation"
(modular:normalize m (* a b)))
(else
(cond
((< a modular:r))
((< b modular:r) (set! a b) (set! b a0) (set! a0 a))
(else
(set! a0 (modulo a modular:r))
(let ((a1 (quotient a modular:r))
(qh (quotient m modular:r))
(rh (modulo m modular:r)))
(cond ((>= a1 modular:r)
(set! a1 (- a1 modular:r))
(set! p (modulo (- (* modular:r (modulo b qh))
(* (quotient b qh) rh)) m))))
(cond ((not (zero? a1))
(let ((q (quotient m a1)))
(set! p (- p (* (quotient b q) (modulo m a1))))
(set! p (modulo (+ (if (positive? p) (- p m) p)
(* a1 (modulo b q))) m)))))
(set! p (modulo (- (* modular:r (modulo p qh))
(* (quotient p qh) rh)) m)))))
(if (zero? a0)
p
(let ((q (quotient m a0)))
(set! p (- p (* (quotient b q) (modulo m a0))))
(modulo (+ (if (positive? p) (- p m) p)
(* a0 (modulo b q))) m)))))))))
(define (modular:expt m a b)
(cond ((= a 1) 1)
((= a (- m 1)) (if (odd? b) a 1))
((zero? a) 0)
((zero? m) (integer-expt a b))
(else
(logical:ipow-by-squaring a b 1
(lambda (c d) (modular:* m c d))))))
(define extended-euclid modular:extended-euclid)

28
module/slib/mulapply.scm
View file

@ -1,28 +0,0 @@
; "mulapply.scm" Redefine APPLY take more than 2 arguments.
;Copyright (C) 1991 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(define two-arg:apply apply)
(define apply
(lambda args
(two-arg:apply (car args) (apply:append-to-last (cdr args)))))
(define (apply:append-to-last lst)
(if (null? (cdr lst))
(car lst)
(cons (car lst) (apply:append-to-last (cdr lst)))))

12
module/slib/mularg.scm
View file

@ -1,12 +0,0 @@
;;; "mularg.scm" Redefine - and / to take more than 2 arguments.
(define / /)
(define - -)
(let ((maker
(lambda (op)
(lambda (d1 . ds)
(cond ((null? ds) (op d1))
((null? (cdr ds)) (op d1 (car ds)))
(else (for-each (lambda (d) (set! d1 (op d1 d))) ds) d1))))))
(set! / (maker /))
(set! - (maker -)))

289
module/slib/mwdenote.scm
View file

@ -1,289 +0,0 @@
;"mwdenote.scm" Syntactic Environments
; Copyright 1992 William Clinger
;
; Permission to copy this software, in whole or in part, to use this
; software for any lawful purpose, and to redistribute this software
; is granted subject to the restriction that all copies made of this
; software must include this copyright notice in full.
;
; I also request that you send me a copy of any improvements that you
; make to this software so that they may be incorporated within it to
; the benefit of the Scheme community.
;;;; Syntactic environments.
; A syntactic environment maps identifiers to denotations,
; where a denotation is one of
;
; (special <special>)
; (macro <rules> <env>)
; (identifier <id>)
;
; and where <special> is one of
;
; quote
; lambda
; if
; set!
; begin
; define
; define-syntax
; let-syntax
; letrec-syntax
; syntax-rules
;
; and where <rules> is a compiled <transformer spec> (see R4RS),
; <env> is a syntactic environment, and <id> is an identifier.
(define mw:standard-syntax-environment
'((quote . (special quote))
(lambda . (special lambda))
(if . (special if))
(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)) ;; @@ "
(quasiquote . (special quasiquote)) ;; @@ "
(unquote . (special unquote)) ;; @@ "
(unquote-splicing . (special unquote-splicing)) ; @@ "
(do . (special do)) ;; @@ "
(define-syntax . (special define-syntax))
(let-syntax . (special let-syntax))
(letrec-syntax . (special letrec-syntax))
(syntax-rules . (special syntax-rules))
(... . (identifier ...))
(::: . (identifier :::))))
; An unforgeable synonym for lambda, used to expand definitions.
(define mw:lambda0 (string->symbol " lambda "))
; The mw:global-syntax-environment will always be a nonempty
; association list since there is no way to remove the entry
; for mw:lambda0. That entry is used as a header by destructive
; operations.
(define mw:global-syntax-environment
(cons (cons mw:lambda0
(cdr (assq 'lambda mw:standard-syntax-environment)))
(mw:syntax-copy mw:standard-syntax-environment)))
(define (mw:global-syntax-environment-set! env)
(set-cdr! mw:global-syntax-environment env))
(define (mw:syntax-bind-globally! id denotation)
(if (and (mw:identifier? denotation)
(eq? id (mw:identifier-name denotation)))
(letrec ((remove-bindings-for-id
(lambda (bindings)
(cond ((null? bindings) '())
((eq? (caar bindings) id)
(remove-bindings-for-id (cdr bindings)))
(else (cons (car bindings)
(remove-bindings-for-id (cdr bindings))))))))
(mw:global-syntax-environment-set!
(remove-bindings-for-id (cdr mw:global-syntax-environment))))
(let ((x (assq id mw:global-syntax-environment)))
(if x
(set-cdr! x denotation)
(mw:global-syntax-environment-set!
(cons (cons id denotation)
(cdr mw:global-syntax-environment)))))))
(define (mw:syntax-divert env1 env2)
(append env2 env1))
(define (mw:syntax-extend env ids denotations)
(mw:syntax-divert env (map cons ids denotations)))
(define (mw:syntax-lookup-raw env id)
(let ((entry (assq id env)))
(if entry
(cdr entry)
#f)))
(define (mw:syntax-lookup env id)
(or (mw:syntax-lookup-raw env id)
(mw:make-identifier-denotation id)))
(define (mw:syntax-assign! env id denotation)
(let ((entry (assq id env)))
(if entry
(set-cdr! entry denotation)
(mw:bug "Bug detected in mw:syntax-assign!" env id denotation))))
(define mw:denote-of-quote
(mw:syntax-lookup mw:standard-syntax-environment 'quote))
(define mw:denote-of-lambda
(mw:syntax-lookup mw:standard-syntax-environment 'lambda))
(define mw:denote-of-if
(mw:syntax-lookup mw:standard-syntax-environment 'if))
(define mw:denote-of-set!
(mw:syntax-lookup mw:standard-syntax-environment 'set!))
(define mw:denote-of-begin
(mw:syntax-lookup mw:standard-syntax-environment 'begin))
(define mw:denote-of-define
(mw:syntax-lookup mw:standard-syntax-environment 'define))
(define mw:denote-of-define-syntax
(mw:syntax-lookup mw:standard-syntax-environment 'define-syntax))
(define mw:denote-of-let-syntax
(mw:syntax-lookup mw:standard-syntax-environment 'let-syntax))
(define mw:denote-of-letrec-syntax
(mw:syntax-lookup mw:standard-syntax-environment 'letrec-syntax))
(define mw:denote-of-syntax-rules
(mw:syntax-lookup mw:standard-syntax-environment 'syntax-rules))
(define mw:denote-of-...
(mw:syntax-lookup mw:standard-syntax-environment '...))
(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
(define mw:denote-of-let*
(mw:syntax-lookup mw:standard-syntax-environment 'let*)) ;; @@ KenD
(define mw:denote-of-letrec
(mw:syntax-lookup mw:standard-syntax-environment 'letrec)) ;; @@ KenD
(define mw:denote-of-quasiquote
(mw:syntax-lookup mw:standard-syntax-environment 'quasiquote)) ;; @@ KenD
(define mw:denote-of-unquote
(mw:syntax-lookup mw:standard-syntax-environment 'unquote)) ;; @@ KenD
(define mw:denote-of-unquote-splicing
(mw:syntax-lookup mw:standard-syntax-environment 'unquote-splicing)) ;@@ KenD
(define mw:denote-of-do
(mw:syntax-lookup mw:standard-syntax-environment 'do)) ;; @@ KenD
(define mw:denote-class car)
;(define (mw:special? denotation)
; (eq? (mw:denote-class denotation) 'special))
;(define (mw:macro? denotation)
; (eq? (mw:denote-class denotation) 'macro))
(define (mw:identifier? denotation)
(eq? (mw:denote-class denotation) 'identifier))
(define (mw:make-identifier-denotation id)
(list 'identifier id))
(define macwork:rules cadr)
(define macwork:env caddr)
(define mw:identifier-name cadr)
(define (mw:same-denotation? d1 d2)
(or (eq? d1 d2)
(and (mw:identifier? d1)
(mw:identifier? d2)
(eq? (mw:identifier-name d1)
(mw:identifier-name d2)))))
; Renaming of variables.
; 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.
; @@ 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.
(define (mw:rename-vars vars)
(set! mw:renaming-counter (+ mw:renaming-counter 1))
(let ((suffix (string-append (string mw:suffix-character)
(number->string mw:renaming-counter))))
(map (lambda (var)
(if (symbol? var)
(cons var
(string->symbol
(string-append (symbol->string var) suffix)))
(slib:error "Illegal variable" var)))
vars)))
; Given a syntactic environment env to be extended, an alist returned
; by mw:rename-vars, and a syntactic environment env2, extends env by
; binding the fresh identifiers to the denotations of the original
; identifiers in env2.
(define (mw:syntax-alias env alist env2)
(mw:syntax-divert
env
(map (lambda (name-pair)
(let ((old-name (car name-pair))
(new-name (cdr name-pair)))
(cons new-name
(mw:syntax-lookup env2 old-name))))
alist)))
; Given a syntactic environment and an alist returned by mw:rename-vars,
; extends the environment by binding the old identifiers to the fresh
; identifiers.
(define (mw:syntax-rename env alist)
(mw:syntax-divert env
(map (lambda (old new)
(cons old (mw:make-identifier-denotation new)))
(map car alist)
(map cdr alist))))
; Given a <formals> and an alist returned by mw:rename-vars that contains
; a new name for each formal identifier in <formals>, renames the
; formal identifiers.
(define (mw:rename-formals formals alist)
(cond ((null? formals) '())
((pair? formals)
(cons (cdr (assq (car formals) alist))
(mw:rename-formals (cdr formals) alist)))
(else (cdr (assq formals alist)))))
(define mw:renaming-counter 0)

565
module/slib/mwexpand.scm
View file

@ -1,565 +0,0 @@
;"mwexpand.scm" macro expander
; Copyright 1992 William Clinger
;
; Permission to copy this software, in whole or in part, to use this
; software for any lawful purpose, and to redistribute this software
; is granted subject to the restriction that all copies made of this
; software must include this copyright notice in full.
;
; I also request that you send me a copy of any improvements that you
; make to this software so that they may be incorporated within it to
; the benefit of the Scheme community.
; The external entry points and kernel of the macro expander.
;
; Part of this code is snarfed from the Twobit macro expander.
(define mw:define-syntax-scope
(let ((flag 'letrec))
(lambda args
(cond ((null? args) flag)
((not (null? (cdr args)))
(apply mw:warn
"Too many arguments passed to define-syntax-scope"
args))
((memq (car args) '(letrec letrec* let*))
(set! flag (car args)))
(else (mw:warn "Unrecognized argument to define-syntax-scope"
(car args)))))))
(define mw:quit ; assigned by macwork:expand
(lambda (v) v))
(define (macwork:expand def-or-exp)
(call-with-current-continuation
(lambda (k)
(set! mw:quit k)
(set! mw:renaming-counter 0)
(mw:desugar-definitions def-or-exp mw:global-syntax-environment))))
(define (mw:desugar-definitions exp env)
(letrec
((define-loop
(lambda (exp rest first)
(cond ((and (pair? exp)
(eq? (mw:syntax-lookup env (car exp))
mw:denote-of-begin)
(pair? (cdr exp)))
(define-loop (cadr exp) (append (cddr exp) rest) first))
((and (pair? exp)
(eq? (mw:syntax-lookup env (car exp))
mw:denote-of-define))
(let ((exp (desugar-define exp env)))
(cond ((and (null? first) (null? rest))
exp)
((null? rest)
(cons mw:begin1 (reverse (cons exp first))))
(else (define-loop (car rest)
(cdr rest)
(cons exp first))))))
((and (pair? exp)
(eq? (mw:syntax-lookup env (car exp))
mw:denote-of-define-syntax)
(null? first))
(define-syntax-loop exp rest))
((and (null? first) (null? rest))
(mw:expand exp env))
((null? rest)
(cons mw:begin1 (reverse (cons (mw:expand exp env) first))))
(else (cons mw:begin1
(append (reverse first)
(map (lambda (exp) (mw:expand exp env))
(cons exp rest))))))))
(desugar-define
(lambda (exp env)
(cond
((null? (cdr exp)) (mw:error "Malformed definition" exp))
; (define foo) syntax is transformed into (define foo (undefined)).
((null? (cddr exp))
(let ((id (cadr exp)))
(redefinition id)
(mw:syntax-bind-globally! id (mw:make-identifier-denotation id))
(list mw:define1 id mw:undefined)))
((pair? (cadr exp))
; mw:lambda0 is an unforgeable lambda, needed here because the
; lambda expression will undergo further expansion.
(desugar-define `(,mw:define1 ,(car (cadr exp))
(,mw:lambda0 ,(cdr (cadr exp))
,@(cddr exp)))
env))
((> (length exp) 3) (mw:error "Malformed definition" exp))
(else (let ((id (cadr exp)))
(redefinition id)
(mw:syntax-bind-globally! id (mw:make-identifier-denotation id))
`(,mw:define1 ,id ,(mw:expand (caddr exp) env)))))))
(define-syntax-loop
(lambda (exp rest)
(cond ((and (pair? exp)
(eq? (mw:syntax-lookup env (car exp))
mw:denote-of-begin)
(pair? (cdr exp)))
(define-syntax-loop (cadr exp) (append (cddr exp) rest)))
((and (pair? exp)
(eq? (mw:syntax-lookup env (car exp))
mw:denote-of-define-syntax))
(if (pair? (cdr exp))
(redefinition (cadr exp)))
(if (null? rest)
(mw:define-syntax exp env)
(begin (mw:define-syntax exp env)
(define-syntax-loop (car rest) (cdr rest)))))
((null? rest)
(mw:expand exp env))
(else (cons mw:begin1
(map (lambda (exp) (mw:expand exp env))
(cons exp rest)))))))
(redefinition
(lambda (id)
(if (symbol? id)
(if (not (mw:identifier?
(mw:syntax-lookup mw:global-syntax-environment id)))
(mw:warn "Redefining keyword" id))
(mw:error "Malformed variable or keyword" id)))))
; body of letrec
(define-loop exp '() '())))
; Given an expression and a syntactic environment,
; returns an expression in core Scheme.
(define (mw:expand exp env)
(if (not (pair? exp))
(mw:atom exp env)
(let ((keyword (mw:syntax-lookup env (car exp))))
(case (mw:denote-class keyword)
((special)
(cond
((eq? keyword mw:denote-of-quote) (mw:quote exp))
((eq? keyword mw:denote-of-lambda) (mw:lambda exp env))
((eq? keyword mw:denote-of-if) (mw:if exp env))
((eq? keyword mw:denote-of-set!) (mw:set exp env))
((eq? keyword mw:denote-of-begin) (mw:begin exp env))
((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))
((eq? keyword mw:denote-of-letrec) (mw:letrec exp env))
((eq? keyword mw:denote-of-quasiquote) (mw:quasiquote exp env))
((eq? keyword mw:denote-of-do) (mw:do exp env))
((or (eq? keyword mw:denote-of-define)
(eq? keyword mw:denote-of-define-syntax))
;; slight hack to allow expansion into defines -KenD
(if mw:in-define?
(mw:error "Definition out of context" exp)
(begin
(set! mw:in-define? #t)
(let ( (result (mw:desugar-definitions exp env)) )
(set! mw:in-define? #f)
result))
))
(else (mw:bug "Bug detected in mw:expand" exp env))))
((macro) (mw:macro exp env))
((identifier) (mw:application exp env))
(else (mw:bug "Bug detected in mw:expand" exp env))
) )
) )
(define mw:in-define? #f) ; should be fluid
(define (mw:atom exp env)
(cond ((not (symbol? exp))
; Here exp ought to be a boolean, number, character, or string,
; but I'll allow for non-standard extensions by passing exp
; to the underlying Scheme system without further checking.
exp)
(else (let ((denotation (mw:syntax-lookup env exp)))
(case (mw:denote-class denotation)
((special macro)
(mw:error "Syntactic keyword used as a variable" exp env))
((identifier) (mw:identifier-name denotation))
(else (mw:bug "Bug detected by mw:atom" exp env)))))))
(define (mw:quote exp)
(if (= (mw:safe-length exp) 2)
(list mw:quote1 (mw:strip (cadr exp)))
(mw:error "Malformed quoted constant" exp)))
(define (mw:lambda exp env)
(if (> (mw:safe-length exp) 2)
(let* ((formals (cadr exp))
(alist (mw:rename-vars (mw:make-null-terminated formals)))
(env (mw:syntax-rename env alist))
(body (cddr exp)))
(list mw:lambda1
(mw:rename-formals formals alist)
(mw:body body env)))
(mw:error "Malformed lambda expression" exp)))
(define (mw:body body env)
(define (loop body env defs)
(if (null? body)
(mw:error "Empty body"))
(let ((exp (car body)))
(if (and (pair? exp)
(symbol? (car exp)))
(let ((denotation (mw:syntax-lookup env (car exp))))
(case (mw:denote-class denotation)
((special)
(cond ((eq? denotation mw:denote-of-begin)
(loop (append (cdr exp) (cdr body)) env defs))
((eq? denotation mw:denote-of-define)
(loop (cdr body) env (cons exp defs)))
(else (mw:finalize-body body env defs))))
((macro)
(mw:transcribe exp
env
(lambda (exp env)
(loop (cons exp (cdr body))
env
defs))))
((identifier)
(mw:finalize-body body env defs))
(else (mw:bug "Bug detected in mw:body" body env))))
(mw:finalize-body body env defs))))
(loop body env '()))
(define (mw:finalize-body body env defs)
(if (null? defs)
(let ((body (map (lambda (exp) (mw:expand exp env))
body)))
(if (null? (cdr body))
(car body)
(cons mw:begin1 body)))
(let* ((alist (mw:rename-vars '(quote lambda set!)))
(env (mw:syntax-alias env alist mw:standard-syntax-environment))
(new-quote (cdr (assq 'quote alist)))
(new-lambda (cdr (assq 'lambda alist)))
(new-set! (cdr (assq 'set! alist))))
(define (desugar-definition def)
(if (> (mw:safe-length def) 2)
(cond ((pair? (cadr def))
(desugar-definition
`(,(car def)
,(car (cadr def))
(,new-lambda
,(cdr (cadr def))
,@(cddr def)))))
((= (length def) 3)
(cdr def))
(else (mw:error "Malformed definition" def env)))
(mw:error "Malformed definition" def env)))
(mw:letrec
`(letrec ,(map desugar-definition (reverse defs)) ,@body)
env)))
)
(define (mw:if exp env)
(let ((n (mw:safe-length exp)))
(if (or (= n 3) (= n 4))
(cons mw:if1 (map (lambda (exp) (mw:expand exp env)) (cdr exp)))
(mw:error "Malformed if expression" exp env))))
(define (mw:set exp env)
(if (= (mw:safe-length exp) 3)
`(,mw:set!1 ,(mw:expand (cadr exp) env) ,(mw:expand (caddr exp) env))
(mw:error "Malformed assignment" exp env)))
(define (mw:begin exp env)
(if (positive? (mw:safe-length exp))
`(,mw:begin1 ,@(map (lambda (exp) (mw:expand exp env)) (cdr exp)))
(mw:error "Malformed begin expression" exp env)))
(define (mw:application exp env)
(if (> (mw:safe-length exp) 0)
(map (lambda (exp) (mw:expand exp env))
exp)
(mw:error "Malformed application")))
; I think the environment argument should always be global here.
(define (mw:define-syntax exp env)
(cond ((and (= (mw:safe-length exp) 3)
(symbol? (cadr exp)))
(mw:define-syntax1 (cadr exp)
(caddr exp)
env
(mw:define-syntax-scope)))
((and (= (mw:safe-length exp) 4)
(symbol? (cadr exp))
(memq (caddr exp) '(letrec letrec* let*)))
(mw:define-syntax1 (cadr exp)
(cadddr exp)
env
(caddr exp)))
(else (mw:error "Malformed define-syntax" exp env))))
(define (mw:define-syntax1 keyword spec env scope)
(case scope
((letrec) (mw:define-syntax-letrec keyword spec env))
((letrec*) (mw:define-syntax-letrec* keyword spec env))
((let*) (mw:define-syntax-let* keyword spec env))
(else (mw:bug "Weird scope" scope)))
(list mw:quote1 keyword))
(define (mw:define-syntax-letrec keyword spec env)
(mw:syntax-bind-globally!
keyword
(mw:compile-transformer-spec spec env)))
(define (mw:define-syntax-letrec* keyword spec env)
(let* ((env (mw:syntax-extend (mw:syntax-copy env)
(list keyword)
'((fake denotation))))
(transformer (mw:compile-transformer-spec spec env)))
(mw:syntax-assign! env keyword transformer)
(mw:syntax-bind-globally! keyword transformer)))
(define (mw:define-syntax-let* keyword spec env)
(mw:syntax-bind-globally!
keyword
(mw:compile-transformer-spec spec (mw:syntax-copy env))))
(define (mw:let-syntax exp env)
(if (and (> (mw:safe-length exp) 2)
(comlist:every (lambda (binding)
(and (pair? binding)
(symbol? (car binding))
(pair? (cdr binding))
(null? (cddr binding))))
(cadr exp)))
(mw:body (cddr exp)
(mw:syntax-extend env
(map car (cadr exp))
(map (lambda (spec)
(mw:compile-transformer-spec
spec
env))
(map cadr (cadr exp)))))
(mw:error "Malformed let-syntax" exp env)))
(define (mw:letrec-syntax exp env)
(if (and (> (mw:safe-length exp) 2)
(comlist:every (lambda (binding)
(and (pair? binding)
(symbol? (car binding))
(pair? (cdr binding))
(null? (cddr binding))))
(cadr exp)))
(let ((env (mw:syntax-extend env
(map car (cadr exp))
(map (lambda (id)
'(fake denotation))
(cadr exp)))))
(for-each (lambda (id spec)
(mw:syntax-assign!
env
id
(mw:compile-transformer-spec spec env)))
(map car (cadr exp))
(map cadr (cadr exp)))
(mw:body (cddr exp) env))
(mw:error "Malformed let-syntax" exp env)))
(define (mw:macro exp env)
(mw:transcribe exp
env
(lambda (exp env)
(mw:expand exp env))))
; To do:
; Clean up alist hacking et cetera.
;;-----------------------------------------------------------------
;; The following was added to allow expansion without flattening
;; LETs to LAMBDAs so that the origianl structure of the program
;; is preserved by macro expansion. I.e. so that usual.scm is not
;; required. -- added KenD
(define (mw:process-let-bindings alist binding-list env) ;; helper proc
(map (lambda (bind)
(list (cdr (assq (car bind) alist)) ; renamed name
(mw:body (cdr bind) env))) ; alpha renamed value expression
binding-list)
)
(define (mw:strip-begin exp) ;; helper proc: mw:body sometimes puts one in
(if (and (pair? exp) (eq? (car exp) 'begin))
(cdr exp)
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)))
#f
(cadr exp))) ; named let?
(binds (if name (caddr exp) (cadr exp)))
(body (if name (cdddr exp) (cddr exp)))
(vars (if (null? binds) #f (map car binds)))
(alist (if vars (mw:rename-vars vars) #f))
(newenv (if alist (mw:syntax-rename env alist) env))
)
(if name ;; extend env with new name
(let ( (rename (mw:rename-vars (list name))) )
(set! alist (append rename alist))
(set! newenv (mw:syntax-rename newenv rename))
) )
`(let
,@(if name (list (cdr (assq name alist))) '())
,(mw:process-let-bindings alist binds env)
,(mw:body body newenv))
) )
; LETREC differs from LET in that the binding values are processed in the
; new rather than the original environment.
(define (mw:letrec exp env)
(let* ( (binds (cadr exp))
(body (cddr exp))
(vars (if (null? binds) #f (map car binds)))
(alist (if vars (mw:rename-vars vars) #f))
(newenv (if alist (mw:syntax-rename env alist) env))
)
`(letrec
,(mw:process-let-bindings alist binds newenv)
,(mw:body body newenv))
) )
; LET* adds to ENV for each new binding.
(define (mw:let* exp env)
(let ( (binds (cadr exp))
(body (cddr exp))
)
(let bind-loop ( (bindings binds) (newbinds '()) (newenv env) )
(if (null? bindings)
`(let* ,(reverse newbinds) ,(mw:body body newenv))
(let* ( (bind (car bindings))
(var (car bind))
(valexp (cdr bind))
(rename (mw:rename-vars (list var)))
(next-newenv (mw:syntax-rename newenv rename))
)
(bind-loop (cdr bindings)
(cons (list (cdr (assq var rename))
(mw:body valexp newenv))
newbinds)
next-newenv))
) ) ) )
; DO
(define (mw:process-do-bindings var-init-steps alist oldenv newenv) ;; helper proc
(map (lambda (vis)
(let ( (v (car vis))
(i (cadr vis))
(s (if (null? (cddr vis)) (car vis) (caddr vis))))
`( ,(cdr (assq v alist)) ; renamed name
,(mw:body (list i) oldenv) ; init in outer/old env
,(mw:body (list s) newenv) ))) ; step in letrec/inner/new env
var-init-steps)
)
(define (mw:do exp env)
(let* ( (vis (cadr exp)) ; (Var Init Step ...)
(ts (caddr exp)) ; (Test Sequence ...)
(com (cdddr exp)) ; (COMmand ...)
(vars (if (null? vis) #f (map car vis)))
(rename (if vars (mw:rename-vars vars) #f))
(newenv (if vars (mw:syntax-rename env rename) env))
)
`(do ,(if vars (mw:process-do-bindings vis rename env newenv) '())
,(if (null? ts) '() (mw:strip-begin (mw:body (list ts) newenv)))
,@(if (null? com) '() (list (mw:body com newenv))))
) )
;
; Quasiquotation (backquote)
;
; At level 0, unquoted forms are left painted (not mw:strip'ed).
; At higher levels, forms which are unquoted to level 0 are painted.
; This includes forms within quotes. E.g.:
; (lambda (a)
; (quasiquote
; (a (unquote a) b (quasiquote (a (unquote (unquote a)) b)))))
;or equivalently:
; (lambda (a) `(a ,a b `(a ,,a b)))
;=>
; (lambda (a|1) `(a ,a|1 b `(a ,,a|1 b)))
(define (mw:quasiquote exp env)
(define (mw:atom exp env)
(if (not (symbol? exp))
exp
(let ((denotation (mw:syntax-lookup env exp)))
(case (mw:denote-class denotation)
((special macro identifier) (mw:identifier-name denotation))
(else (mw:bug "Bug detected by mw:atom" exp env))))
) )
(define (quasi subexp level)
(cond
((null? subexp) subexp)
((not (or (pair? subexp) (vector? subexp)))
(if (zero? level) (mw:atom subexp env) subexp) ; the work is here
)
((vector? subexp)
(let* ((l (vector-length subexp))
(v (make-vector l)))
(do ((i 0 (+ i 1)))
((= i l) v)
(vector-set! v i (quasi (vector-ref subexp i) level))
)
)
)
(else
(let ( (keyword (mw:syntax-lookup env (car subexp))) )
(cond
((eq? keyword mw:denote-of-unquote)
(cons 'unquote (quasi (cdr subexp) (- level 1)))
)
((eq? keyword mw:denote-of-unquote-splicing)
(cons 'unquote-splicing (quasi (cdr subexp) (- level 1)))
)
((eq? keyword mw:denote-of-quasiquote)
(cons 'quasiquote (quasi (cdr subexp) (+ level 1)))
)
(else
(cons (quasi (car subexp) level) (quasi (cdr subexp) level))
)
)
) ) ; end else, let
) ; end cond
)
(quasi exp 0) ; need to unquote to level 0 to paint
)
;; --- E O F ---

343
module/slib/mwsynrul.scm
View file

@ -1,343 +0,0 @@
; "mwsynrul.scm" Compiler for a <transformer spec>.
; Copyright 1992 William Clinger
;
; Permission to copy this software, in whole or in part, to use this
; software for any lawful purpose, and to redistribute this software
; is granted subject to the restriction that all copies made of this
; software must include this copyright notice in full.
;
; I also request that you send me a copy of any improvements that you
; make to this software so that they may be incorporated within it to
; the benefit of the Scheme community.
;;;; Compiler for a <transformer spec>.
;;; The input is a <transformer spec> and a syntactic environment.
;;; Syntactic environments are described in another file.
;;; Transormer specs are in slib.texi.
(define mw:pattern-variable-flag (list 'v))
(define mw:ellipsis-pattern-flag (list 'e))
(define mw:ellipsis-template-flag mw:ellipsis-pattern-flag)
(define (mw:make-patternvar v rank)
(vector mw:pattern-variable-flag v rank))
(define (mw:make-ellipsis-pattern P vars)
(vector mw:ellipsis-pattern-flag P vars))
(define (mw:make-ellipsis-template T vars)
(vector mw:ellipsis-template-flag T vars))
(define (mw:patternvar? x)
(and (vector? x)
(= (vector-length x) 3)
(eq? (vector-ref x 0) mw:pattern-variable-flag)))
(define (mw:ellipsis-pattern? x)
(and (vector? x)
(= (vector-length x) 3)
(eq? (vector-ref x 0) mw:ellipsis-pattern-flag)))
(define (mw:ellipsis-template? x)
(and (vector? x)
(= (vector-length x) 3)
(eq? (vector-ref x 0) mw:ellipsis-template-flag)))
(define (mw:patternvar-name V) (vector-ref V 1))
(define (mw:patternvar-rank V) (vector-ref V 2))
(define (mw:ellipsis-pattern P) (vector-ref P 1))
(define (mw:ellipsis-pattern-vars P) (vector-ref P 2))
(define (mw:ellipsis-template T) (vector-ref T 1))
(define (mw:ellipsis-template-vars T) (vector-ref T 2))
(define (mw:pattern-variable v vars)
(cond ((null? vars) #f)
((eq? v (mw:patternvar-name (car vars)))
(car vars))
(else (mw:pattern-variable v (cdr vars)))))
; Given a <transformer spec> and a syntactic environment,
; returns a macro denotation.
;
; A macro denotation is of the form
;
; (macro (<rule> ...) env)
;
; where each <rule> has been compiled as described above.
(define (mw:compile-transformer-spec spec env)
(if (and (> (mw:safe-length spec) 1)
(eq? (mw:syntax-lookup env (car spec))
mw:denote-of-syntax-rules))
(let ((literals (cadr spec))
(rules (cddr spec)))
(if (or (not (list? literals))
(not (comlist:every (lambda (rule)
(and (= (mw:safe-length rule) 2)
(pair? (car rule))))
rules)))
(mw:error "Malformed syntax-rules" spec))
(list 'macro
(map (lambda (rule)
(mw:compile-rule rule literals env))
rules)
env))
(mw:error "Malformed syntax-rules" spec)))
(define (mw:compile-rule rule literals env)
(mw:compile-pattern (cdr (car rule))
literals
env
(lambda (compiled-rule patternvars)
; should check uniqueness of pattern variables here!!!!!
(cons compiled-rule
(mw:compile-template
(cadr rule)
patternvars
env)))))
(define (mw:compile-pattern P literals env k)
(define (loop P vars rank k)
(cond ((symbol? P)
(if (memq P literals)
(k P vars)
(let ((var (mw:make-patternvar P rank)))
(k var (cons var vars)))))
((null? P) (k '() vars))
((pair? P)
(if (and (pair? (cdr P))
(symbol? (cadr P))
(eq? (mw:syntax-lookup env (cadr P))
mw:denote-of-...))
(if (null? (cddr P))
(loop (car P)
'()
(+ rank 1)
(lambda (P vars1)
(k (mw:make-ellipsis-pattern P vars1)
(comlist:union vars1 vars))))
(mw:error "Malformed pattern" P))
(loop (car P)
vars
rank
(lambda (P1 vars)
(loop (cdr P)
vars
rank
(lambda (P2 vars)
(k (cons P1 P2) vars)))))))
((vector? P)
(loop (vector->list P)
vars
rank
(lambda (P vars)
(k (vector P) vars))))
(else (k P vars))))
(loop P '() 0 k))
(define (mw:compile-template T vars env)
(define (loop T inserted referenced rank escaped? k)
(cond ((symbol? T)
(let ((x (mw:pattern-variable T vars)))
(if x
(if (>= rank (mw:patternvar-rank x))
(k x inserted (cons x referenced))
(mw:error
"Too few ellipses follow pattern variable in template"
(mw:patternvar-name x)))
(k T (cons T inserted) referenced))))
((null? T) (k '() inserted referenced))
((pair? T)
(cond ((and (not escaped?)
(symbol? (car T))
(eq? (mw:syntax-lookup env (car T))
mw:denote-of-:::)
(pair? (cdr T))
(null? (cddr T)))
(loop (cadr T) inserted referenced rank #t k))
((and (not escaped?)
(pair? (cdr T))
(symbol? (cadr T))
(eq? (mw:syntax-lookup env (cadr T))
mw:denote-of-...))
(loop1 T inserted referenced rank escaped? k))
(else
(loop (car T)
inserted
referenced
rank
escaped?
(lambda (T1 inserted referenced)
(loop (cdr T)
inserted
referenced
rank
escaped?
(lambda (T2 inserted referenced)
(k (cons T1 T2) inserted referenced))))))))
((vector? T)
(loop (vector->list T)
inserted
referenced
rank
escaped?
(lambda (T inserted referenced)
(k (vector T) inserted referenced))))
(else (k T inserted referenced))))
(define (loop1 T inserted referenced rank escaped? k)
(loop (car T)
inserted
'()
(+ rank 1)
escaped?
(lambda (T1 inserted referenced1)
(loop (cddr T)
inserted
(append referenced1 referenced)
rank
escaped?
(lambda (T2 inserted referenced)
(k (cons (mw:make-ellipsis-template
T1
(comlist:remove-if-not
(lambda (var) (> (mw:patternvar-rank var)
rank))
referenced1))
T2)
inserted
referenced))))))
(loop T
'()
'()
0
#f
(lambda (T inserted referenced)
(list T inserted))))
; The pattern matcher.
;
; Given an input, a pattern, and two syntactic environments,
; returns a pattern variable environment (represented as an alist)
; if the input matches the pattern, otherwise returns #f.
(define mw:empty-pattern-variable-environment
(list (mw:make-patternvar (string->symbol "") 0)))
(define (mw:match F P env-def env-use)
(define (match F P answer rank)
(cond ((null? P)
(and (null? F) answer))
((pair? P)
(and (pair? F)
(let ((answer (match (car F) (car P) answer rank)))
(and answer (match (cdr F) (cdr P) answer rank)))))
((symbol? P)
(and (symbol? F)
(mw:same-denotation? (mw:syntax-lookup env-def P)
(mw:syntax-lookup env-use F))
answer))
((mw:patternvar? P)
(cons (cons P F) answer))
((mw:ellipsis-pattern? P)
(match1 F P answer (+ rank 1)))
((vector? P)
(and (vector? F)
(match (vector->list F) (vector-ref P 0) answer rank)))
(else (and (equal? F P) answer))))
(define (match1 F P answer rank)
(cond ((not (list? F)) #f)
((null? F)
(append (map (lambda (var) (cons var '()))
(mw:ellipsis-pattern-vars P))
answer))
(else
(let* ((P1 (mw:ellipsis-pattern P))
(answers (map (lambda (F) (match F P1 answer rank))
F)))
(if (comlist:every identity answers)
(append (map (lambda (var)
(cons var
(map (lambda (answer)
(cdr (assq var answer)))
answers)))
(mw:ellipsis-pattern-vars P))
answer)
#f)))))
(match F P mw:empty-pattern-variable-environment 0))
(define (mw:rewrite T alist)
(define (rewrite T alist rank)
(cond ((null? T) '())
((pair? T)
((if (mw:ellipsis-pattern? (car T))
append
cons)
(rewrite (car T) alist rank)
(rewrite (cdr T) alist rank)))
((symbol? T) (cdr (assq T alist)))
((mw:patternvar? T) (cdr (assq T alist)))
((mw:ellipsis-template? T)
(rewrite1 T alist (+ rank 1)))
((vector? T)
(list->vector (rewrite (vector-ref T 0) alist rank)))
(else T)))
(define (rewrite1 T alist rank)
(let* ((T1 (mw:ellipsis-template T))
(vars (mw:ellipsis-template-vars T))
(rows (map (lambda (var) (cdr (assq var alist)))
vars)))
(map (lambda (alist) (rewrite T1 alist rank))
(make-columns vars rows alist))))
(define (make-columns vars rows alist)
(define (loop rows)
(if (null? (car rows))
'()
(cons (append (map (lambda (var row)
(cons var (car row)))
vars
rows)
alist)
(loop (map cdr rows)))))
(if (or (null? (cdr rows))
(apply = (map length rows)))
(loop rows)
(mw:error "Use of macro is not consistent with definition"
vars
rows)))
(rewrite T alist 0))
; Given a use of a macro, the syntactic environment of the use,
; and a continuation that expects a transcribed expression and
; a new environment in which to continue expansion,
; does the right thing.
(define (mw:transcribe exp env-use k)
(let* ((m (mw:syntax-lookup env-use (car exp)))
(rules (macwork:rules m))
(env-def (macwork:env m))
(F (cdr exp)))
(define (loop rules)
(if (null? rules)
(mw:error "Use of macro does not match definition" exp)
(let* ((rule (car rules))
(pattern (car rule))
(alist (mw:match F pattern env-def env-use)))
(if alist
(let* ((template (cadr rule))
(inserted (caddr rule))
(alist2 (mw:rename-vars inserted))
(newexp (mw:rewrite template (append alist2 alist))))
(k newexp
(mw:syntax-alias env-use alist2 env-def)))
(loop (cdr rules))))))
(loop rules)))

385
module/slib/nclients.scm
View file

@ -1,385 +0,0 @@
;;; "nclients.scm" Interface to net-client programs.
; Copyright 1997, 1998 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;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 'string-search)
(require 'line-i/o)
(require 'system)
(require 'printf)
(require 'scanf)
;;@args proc
;;@args proc k
;;Calls @1 with @var{k} arguments, strings returned by successive
;;calls to @code{tmpnam}. If @1 returns, then any files named by the
;;arguments to @1 are deleted automatically and the value(s) yielded
;;by the @1 is(are) returned. @var{k} may be ommited, in which case
;;it defaults to @code{1}.
(define (call-with-tmpnam proc . k)
(do ((cnt (if (null? k) 0 (+ -1 (car k))) (+ -1 cnt))
(paths '() (cons (tmpnam) paths)))
((negative? cnt)
(let ((ans (apply proc paths)))
(for-each (lambda (path) (if (file-exists? path) (delete-file path)))
paths)
ans))))
;;@args
;;@0 returns a string of the form @samp{username@r{@@}hostname}. If
;;this e-mail address cannot be obtained, #f is returned.
(define user-email-address
(let ((user (or (getenv "USER") (getenv "USERNAME")))
(hostname (getenv "HOSTNAME"))) ;with domain
(lambda ()
(if (not (and user hostname))
(call-with-tmpnam
(lambda (tmp)
(define command->string
(lambda (command)
(and (zero? (system (string-append command " >" tmp)))
(file-exists? tmp)
(let ((res #f))
(call-with-input-file tmp
(lambda (port)
(and (eqv? 1 (fscanf port "%s" res)) res)))))))
(case (software-type)
;;((AMIGA) )
;;((MACOS THINKC) )
((MS-DOS WINDOWS OS/2 ATARIST)
(let ((compname (getenv "COMPUTERNAME")) ;without domain
(workgroup #f)
(netdir (or (getenv "windir")
(getenv "winbootdir")
(and (getenv "SYSTEMROOT")
(string-append (getenv "SYSTEMROOT")
"\\system32"))
"C:\\windows")))
(define (net . cmd)
(zero? (system (apply string-append
(or netdir "")
(if netdir "\\" "")
"NET " cmd))))
(and (not (and user hostname))
(zero? (system (string-append
(or netdir "")
(if netdir "\\" "")
"IPCONFIG /ALL > " tmp " ")))
(file-exists? tmp)
;;(print tmp '=) (display-file tmp)
(call-with-input-file tmp
(lambda (port)
(find-string-from-port? "Host Name" port)
(fscanf port " %*[. ]: %s" hostname)
(delete-file tmp))))
(and (not (and user hostname))
(net "START /LIST >" tmp)
(file-exists? tmp)
(not (eof-object? (call-with-input-file tmp read-char)))
(cond
((call-with-input-file tmp
(lambda (port)
(find-string-from-port? "o network servic" port)))
(and (net "CONFIG /YES >" tmp)
(net "STOP /YES")))
(else (net "CONFIG /YES >" tmp)))
(call-with-input-file tmp
(lambda (port)
(do ((line (read-line port) (read-line port)))
((eof-object? line))
(sscanf line " Workstation root directory %s"
netdir)
(sscanf line " Computer name \\\\%s" compname)
(sscanf line " Workstation Domain %s" workgroup)
(sscanf line " Workgroup %s" workgroup)
(sscanf line " User name %s" user)))))
(and netdir (not (and user hostname))
(set! netdir (string-append netdir "\\system.ini"))
(file-exists? netdir)
(call-with-input-file netdir
(lambda (port)
(and (find-string-from-port? "[DNS]" port)
(read-line port) ;past newline
(do ((line (read-line port) (read-line port)))
((not (and (string? line)
(string-index line #\=))))
(sscanf line "HostName=%s" compname)
(sscanf line "DomainName=%s" workgroup)))))
(not user)
(call-with-input-file netdir
(lambda (port)
(and (find-string-from-port? "[Network]" port)
(read-line port) ;past newline
(do ((line (read-line port) (read-line port)))
((not (and (string? line)
(string-index line #\=))))
(sscanf line "UserName=%s" user))))))
(if (and compname (not hostname))
(set! hostname
(string-append
compname "." (or workgroup "localnet"))))))
;;((NOSVE) )
;;((VMS) )
((UNIX COHERENT)
(if (not user)
(set! user (command->string "whoami")))
(if (not hostname)
(set! hostname (command->string "hostname")))))
(if (not user) (set! user "John_Doe"))
(if (not hostname) (set! hostname "localhost")))))
(string-append user "@" hostname))))
;;@args
;;@0 returns a string containing the absolute file name representing
;;the current working directory. If this string cannot be obtained,
;;#f is returned.
;;
;;If @0 cannot be supported by the platform, the value of @0 is
;;#f.
(define current-directory
(case (software-type)
;;((AMIGA) )
;;((MACOS THINKC) )
((MS-DOS WINDOWS ATARIST OS/2)
(lambda ()
(call-with-tmpnam
(lambda (tmp)
(and (zero? (system (string-append "cd >" tmp)))
(file-exists? tmp)
(call-with-input-file tmp
(lambda (port)
(let ((lst (scanf-read-list "%[^:]%[:] %s" port)))
(and (pair? lst)
(eqv? 3 (length lst))
(apply string-append lst))))))))))
;;((NOSVE) )
((UNIX COHERENT)
(lambda ()
(call-with-tmpnam
(lambda (tmp)
(and (zero? (system (string-append "pwd >" tmp)))
(file-exists? tmp)
(let ((path (call-with-input-file tmp read-line)))
(and (string? path) path)))))))
;;((VMS) )
(else #f)))
;;@body
;;Creates a sub-directory @1 of the current-directory. If successful,
;;@0 returns #t; otherwise #f.
(define (make-directory name)
(zero? (system (string-append "mkdir " name))))
;;@body
;;Returns #t if changing directory to @1 makes the current working
;;directory the same as it is before changing directory; otherwise
;;returns #f.
(define (null-directory? file-name)
(member file-name '("" "." "./" ".\\")))
;;@body
;;Returns #t if @1 is a fully specified pathname (does not depend on
;;the current working directory); otherwise returns #f.
(define (absolute-path? file-name)
(and (string? file-name)
(positive? (string-length file-name))
(memv (string-ref file-name 0) '(#\\ #\/))))
;;@body Returns #t if the string @1 contains characters used for
;;specifying glob patterns, namely @samp{*}, @samp{?}, or @samp{[}.
(define (glob-pattern? str)
(let loop ((idx (+ -1 (string-length str))))
(if (negative? idx)
#f
(case (string-ref str idx)
((#\* #\[ #\?) #t)
(else (loop (+ -1 idx)))))))
;;@body
;;Returns a list of the decoded FTP @1; or #f if indecipherable. FTP
;;@dfn{Uniform Resource Locator}, @dfn{ange-ftp}, and @dfn{getit}
;;formats are handled. The returned list has four elements which are
;;strings or #f:
;;
;;@enumerate 0
;;@item
;;username
;;@item
;;password
;;@item
;;remote-site
;;@item
;;remote-directory
;;@end enumerate
(define (parse-ftp-address uri)
(define length? (lambda (len lst) (and (eqv? len (length lst)) lst)))
(cond
((not uri) #f)
((length? 1 (scanf-read-list " ftp://%s %s" uri))
=> (lambda (host)
(let ((login #f) (path #f) (dross #f))
(sscanf (car host) "%[^/]/%[^@]%s" login path dross)
(and login
(append (cond
((length? 2 (scanf-read-list "%[^@]@%[^@]%s" login))
=> (lambda (userpass@hostport)
(append
(cond ((length? 2 (scanf-read-list
"%[^:]:%[^@/]%s"
(car userpass@hostport))))
(else (list (car userpass@hostport) #f)))
(cdr userpass@hostport))))
(else (list "anonymous" #f login)))
(list path))))))
(else
(let ((user@site #f) (colon #f) (path #f) (dross #f))
(case (sscanf uri " %[^:]%[:]%[^@] %s" user@site colon path dross)
((2 3)
(let ((user #f) (site #f))
(cond ((or (eqv? 2 (sscanf user@site "/%[^@/]@%[^@]%s"
user site dross))
(eqv? 2 (sscanf user@site "%[^@/]@%[^@]%s"
user site dross)))
(list user #f site path))
((eqv? 1 (sscanf user@site "@%[^@]%s" site dross))
(list #f #f site path))
(else (list #f #f user@site path)))))
(else
(let ((site (scanf-read-list " %[^@/] %s" uri)))
(and (length? 1 site) (list #f #f (car site) #f)))))))))
;;@body
;;@3 must be a non-empty string or #f. @1 must be a non-empty list
;;of pathnames or Glob patterns (@pxref{Filenames}) matching files to
;;transfer.
;;
;;@0 puts the files specified by @1 into the @5 directory of FTP @4
;;using name @2 with (optional) @3.
;;
;;If @3 is #f and @2 is not @samp{ftp} or @samp{anonymous}, then @2 is
;;ignored; FTP takes the username and password from the @file{.netrc}
;;or equivalent file.
(define (ftp-upload paths user password remote-site remote-dir)
(call-with-tmpnam
(lambda (script logfile)
(define local-path (current-directory))
(define passwd (or password (user-email-address)))
(dynamic-wind
(lambda () #f)
(lambda ()
(call-with-current-continuation
(lambda (exit)
(define (run-ftp-script paths)
(call-with-output-file script
(lambda (port)
(define lcd "")
(cond ((or (member user '(ftp anonymous "ftp" "anonymous"))
password)
(fprintf port "user %s %s\n" user passwd)))
(fprintf port "binary\n") ; Turn binary ON for all transfers
;;(fprintf port "prompt\n") ; Turn prompt OFF for possible mget
(if (not (null-directory? remote-dir))
(fprintf port "cd %s\n" remote-dir))
(for-each
(lambda (path-name)
(let* ((r/i (string-reverse-index path-name #\/))
(dir (if r/i (substring path-name 0 (+ 1 r/i)) ""))
(file-name (if r/i
(substring path-name (+ 1 r/i)
(string-length path-name))
path-name)))
(cond ((and r/i (glob-pattern? dir))
(slib:warn
"Wildcard not allowed in directory component "
path-name)
(exit #f))
((and (not (glob-pattern? file-name))
(not (file-exists? path-name)))
(slib:warn " file doesn't exist:" path-name)
(exit #f))
((equal? lcd dir))
((absolute-path? dir)
(fprintf port "lcd %s\n" dir))
((eqv? 0 (substring? lcd dir))
(fprintf port "lcd %s\n"
(substring dir (string-length lcd)
(string-length dir))))
(else
(fprintf port "lcd %s\n" local-path)
(if (not (null-directory? dir))
(fprintf port "lcd %s\n" dir))))
(set! lcd dir)
(cond ((glob-pattern? file-name)
(fprintf port "mput %s\n" file-name))
(else
(fprintf port "put %s\n" file-name)))))
paths)))
;;(display-file script)
(cond
((zero? (system
(string-append
"ftp "
(if (or (member user '(ftp anonymous "ftp" "anonymous"))
password)
"-inv" "-iv")
" " remote-site
" <" script
" >" logfile)))
(file-exists? logfile)
(call-with-input-file logfile
(lambda (port)
(do ((line (read-line port) (read-line port)))
((or (eof-object? line)
(substring-ci? "Unknown host" line)
(substring-ci? "Not connected" line)
(and (memv (string-ref line 0) '(#\4 #\5))
(not (substring-ci? "bytes" line))))
(cond ((eof-object? line) #t)
(else (slib:warn line) #f)))
;;(write-line line)
))))
(else (slib:warn 'ftp 'failed) #f)))
(cond ((or local-path (every? absolute-file? paths))
(run-ftp-script paths))
(else (for-each (lambda (path) (run-ftp-script (list path)))
paths))))))
(lambda ()
(if (file-exists? script) (delete-file script))
(if (file-exists? logfile) (delete-file logfile)))))
2))
;;@body
;;Returns a URI-string for @1 on the local host.
(define (path->uri path)
(if (absolute-path? path)
(sprintf #f "file:%s" path)
(sprintf #f "file:%s/%s" (current-directory) path)))
;;@body
;;If a @samp{netscape} browser is running, @0 causes the browser to
;;display the page specified by string @1 and returns #t.
;;
;;If the browser is not running, @0 runs @samp{netscape} with the
;;argument @1. If the browser starts as a background job, @0 returns
;;#t immediately; if the browser starts as a foreground job, then @0
;;returns #t when the browser exits; otherwise it returns #f.
(define (browse-url-netscape url)
(or (eqv? 0 (system (sprintf #f "netscape-remote -remote 'openURL(%s)'" url)))
(eqv? 0 (system (sprintf #f "netscape -remote 'openURL(%s)'" url)))
(eqv? 0 (system (sprintf #f "netscape '%s'&" url)))
(eqv? 0 (system (sprintf #f "netscape '%s'" url)))))

103
module/slib/nclients.txi
View file

@ -1,103 +0,0 @@
@defun call-with-tmpnam proc
@defunx call-with-tmpnam proc k
Calls @var{proc} with @var{k} arguments, strings returned by successive
calls to @code{tmpnam}. If @var{proc} returns, then any files named by the
arguments to @var{proc} are deleted automatically and the value(s) yielded
by the @var{proc} is(are) returned. @var{k} may be ommited, in which case
it defaults to @code{1}.
@end defun
@defun user-email-address
@code{user-email-address} returns a string of the form @samp{username@r{@@}hostname}. If
this e-mail address cannot be obtained, #f is returned.
@end defun
@defun current-directory
@code{current-directory} returns a string containing the absolute file name representing
the current working directory. If this string cannot be obtained,
#f is returned.
If @code{current-directory} cannot be supported by the platform, the value of @code{current-directory} is
#f.
@end defun
@defun make-directory name
Creates a sub-directory @var{name} of the current-directory. If successful,
@code{make-directory} returns #t; otherwise #f.
@end defun
@defun null-directory? file-name
Returns #t if changing directory to @var{file-name} makes the current working
directory the same as it is before changing directory; otherwise
returns #f.
@end defun
@defun absolute-path? file-name
Returns #t if @var{file-name} is a fully specified pathname (does not depend on
the current working directory); otherwise returns #f.
@end defun
@defun glob-pattern? str
Returns #t if the string @var{str} contains characters used for
specifying glob patterns, namely @samp{*}, @samp{?}, or @samp{[}.
@end defun
@defun parse-ftp-address uri
Returns a list of the decoded FTP @var{uri}; or #f if indecipherable. FTP
@dfn{Uniform Resource Locator}, @dfn{ange-ftp}, and @dfn{getit}
@cindex Uniform Resource Locator
@cindex ange-ftp
@cindex getit
formats are handled. The returned list has four elements which are
strings or #f:
@enumerate 0
@item
username
@item
password
@item
remote-site
@item
remote-directory
@end enumerate
@end defun
@defun ftp-upload paths user password remote-site remote-dir
@var{password} must be a non-empty string or #f. @var{paths} must be a non-empty list
of pathnames or Glob patterns (@pxref{Filenames}) matching files to
transfer.
@code{ftp-upload} puts the files specified by @var{paths} into the @var{remote-dir} directory of FTP @var{remote-site}
using name @var{user} with (optional) @var{password}.
If @var{password} is #f and @var{user} is not @samp{ftp} or @samp{anonymous}, then @var{user} is
ignored; FTP takes the username and password from the @file{.netrc}
or equivalent file.
@end defun
@defun path->uri path
Returns a URI-string for @var{path} on the local host.
@end defun
@defun browse-url-netscape url
If a @samp{netscape} browser is running, @code{browse-url-netscape} causes the browser to
display the page specified by string @var{url} and returns #t.
If the browser is not running, @code{browse-url-netscape} runs @samp{netscape} with the
argument @var{url}. If the browser starts as a background job, @code{browse-url-netscape} returns
#t immediately; if the browser starts as a foreground job, then @code{browse-url-netscape}
returns #t when the browser exits; otherwise it returns #f.
@end defun

63
module/slib/obj2str.scm
View file

@ -1,63 +0,0 @@
;;; "obj2str.scm", write objects to a string.
;Copyright (C) 1993, 1994 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;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 '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))
(else
(call-with-output-string
(lambda (port) (write obj port))))))
; File: "obj2str.scm" (c) 1991, Marc Feeley
;(require 'generic-write)
; (object->string obj) returns the textual representation of 'obj' as a
; string.
;
; Note: (write obj) = (display (object->string obj))
;(define (object->string obj)
; (let ((result '()))
; (generic-write obj #f #f (lambda (str) (set! result (cons str result)) #t))
; (reverse-string-append result)))
; (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))
(generic-write obj #f #f
(lambda (str)
(let ((len (string-length str)))
(cond ((> len left)
(set! result (cons (substring str 0 left) result))
(set! left 0)
#f)
(else
(set! result (cons str result))
(set! left (- left len))
#t)))))
(reverse-string-append result)))

9
module/slib/obj2str.txi
View file

@ -1,9 +0,0 @@
@defun object->string obj
Returns the textual representation of @var{obj} as a string.
@end defun
@defun object->limited-string obj limit
Returns the textual representation of @var{obj} as a string of length
at most @var{limit}.
@end defun

238
module/slib/objdoc.txi
View file

@ -1,238 +0,0 @@
@code{(require 'object)}
@ftindex object
This is the Macroless Object System written by Wade Humeniuk
(whumeniu@@datap.ca). Conceptual Tributes: @ref{Yasos}, MacScheme's
%object, CLOS, Lack of R4RS macros.
@subsection Concepts
@table @asis
@item OBJECT
An object is an ordered association-list (by @code{eq?}) of methods
(procedures). Methods can be added (@code{make-method!}), deleted
(@code{unmake-method!}) and retrieved (@code{get-method}). Objects may
inherit methods from other objects. The object binds to the environment
it was created in, allowing closures to be used to hide private
procedures and data.
@item GENERIC-METHOD
A generic-method associates (in terms of @code{eq?}) object's method.
This allows scheme function style to be used for objects. The calling
scheme for using a generic method is @code{(generic-method object param1
param2 ...)}.
@item METHOD
A method is a procedure that exists in the object. To use a method
get-method must be called to look-up the method. Generic methods
implement the get-method functionality. Methods may be added to an
object associated with any scheme obj in terms of eq?
@item GENERIC-PREDICATE
A generic method that returns a boolean value for any scheme obj.
@item PREDICATE
A object's method asscociated with a generic-predicate. Returns
@code{#t}.
@end table
@subsection Procedures
@defun make-object ancestor @dots{}
Returns an object. Current object implementation is a tagged vector.
@var{ancestor}s are optional and must be objects in terms of object?.
@var{ancestor}s methods are included in the object. Multiple
@var{ancestor}s might associate the same generic-method with a method.
In this case the method of the @var{ancestor} first appearing in the
list is the one returned by @code{get-method}.
@end defun
@defun object? obj
Returns boolean value whether @var{obj} was created by make-object.
@end defun
@defun make-generic-method exception-procedure
Returns a procedure which be associated with an object's methods. If
@var{exception-procedure} is specified then it is used to process
non-objects.
@end defun
@defun make-generic-predicate
Returns a boolean procedure for any scheme object.
@end defun
@defun make-method! object generic-method method
Associates @var{method} to the @var{generic-method} in the object. The
@var{method} overrides any previous association with the
@var{generic-method} within the object. Using @code{unmake-method!}
will restore the object's previous association with the
@var{generic-method}. @var{method} must be a procedure.
@end defun
@defun make-predicate! object generic-preciate
Makes a predicate method associated with the @var{generic-predicate}.
@end defun
@defun unmake-method! object generic-method
Removes an object's association with a @var{generic-method} .
@end defun
@defun get-method object generic-method
Returns the object's method associated (if any) with the
@var{generic-method}. If no associated method exists an error is
flagged.
@end defun
@subsection Examples
@example
(require 'object)
@ftindex object
(define instantiate (make-generic-method))
(define (make-instance-object . ancestors)
(define self (apply make-object
(map (lambda (obj) (instantiate obj)) ancestors)))
(make-method! self instantiate (lambda (self) self))
self)
(define who (make-generic-method))
(define imigrate! (make-generic-method))
(define emigrate! (make-generic-method))
(define describe (make-generic-method))
(define name (make-generic-method))
(define address (make-generic-method))
(define members (make-generic-method))
(define society
(let ()
(define self (make-instance-object))
(define population '())
(make-method! self imigrate!
(lambda (new-person)
(if (not (eq? new-person self))
(set! population (cons new-person population)))))
(make-method! self emigrate!
(lambda (person)
(if (not (eq? person self))
(set! population
(comlist:remove-if (lambda (member)
(eq? member person))
population)))))
(make-method! self describe
(lambda (self)
(map (lambda (person) (describe person)) population)))
(make-method! self who
(lambda (self) (map (lambda (person) (name person))
population)))
(make-method! self members (lambda (self) population))
self))
(define (make-person %name %address)
(define self (make-instance-object society))
(make-method! self name (lambda (self) %name))
(make-method! self address (lambda (self) %address))
(make-method! self who (lambda (self) (name self)))
(make-method! self instantiate
(lambda (self)
(make-person (string-append (name self) "-son-of")
%address)))
(make-method! self describe
(lambda (self) (list (name self) (address self))))
(imigrate! self)
self)
@end example
@subsubsection Inverter Documentation
Inheritance:
@lisp
<inverter>::(<number> <description>)
@end lisp
Generic-methods
@lisp
<inverter>::value @result{} <number>::value
<inverter>::set-value! @result{} <number>::set-value!
<inverter>::describe @result{} <description>::describe
<inverter>::help
<inverter>::invert
<inverter>::inverter?
@end lisp
@subsubsection Number Documention
Inheritance
@lisp
<number>::()
@end lisp
Slots
@lisp
<number>::<x>
@end lisp
Generic Methods
@lisp
<number>::value
<number>::set-value!
@end lisp
@subsubsection Inverter code
@example
(require 'object)
@ftindex object
(define value (make-generic-method (lambda (val) val)))
(define set-value! (make-generic-method))
(define invert (make-generic-method
(lambda (val)
(if (number? val)
(/ 1 val)
(error "Method not supported:" val)))))
(define noop (make-generic-method))
(define inverter? (make-generic-predicate))
(define describe (make-generic-method))
(define help (make-generic-method))
(define (make-number x)
(define self (make-object))
(make-method! self value (lambda (this) x))
(make-method! self set-value!
(lambda (this new-value) (set! x new-value)))
self)
(define (make-description str)
(define self (make-object))
(make-method! self describe (lambda (this) str))
(make-method! self help (lambda (this) "Help not available"))
self)
(define (make-inverter)
(let* ((self (make-object
(make-number 1)
(make-description "A number which can be inverted")))
(<value> (get-method self value)))
(make-method! self invert (lambda (self) (/ 1 (<value> self))))
(make-predicate! self inverter?)
(unmake-method! self help)
(make-method! self help
(lambda (self)
(display "Inverter Methods:") (newline)
(display " (value inverter) ==> n") (newline)))
self))
;;;; Try it out
(define invert! (make-generic-method))
(define x (make-inverter))
(make-method! x invert! (lambda (x) (set-value! x (/ 1 (value x)))))
(value x) @result{} 1
(set-value! x 33) @result{} undefined
(invert! x) @result{} undefined
(value x) @result{} 1/33
(unmake-method! x invert!) @result{} undefined
(invert! x) @error{} ERROR: Method not supported: x
@end example

97
module/slib/object.scm
View file

@ -1,97 +0,0 @@
;;; "object.scm" Macroless Object System
;;;From: whumeniu@datap.ca (Wade Humeniuk)
;;;Date: February 15, 1994
;; Object Construction:
;; 0 1 2 3 4
;; #(object-tag get-method make-method! unmake-method! get-all-methods)
(define object:tag "object")
;;; This might be better done using COMLIST:DELETE-IF.
(define (object:removeq obj alist)
(if (null? alist)
alist
(if (eq? (caar alist) obj)
(cdr alist)
(cons (car alist) (object:removeq obj (cdr alist))))))
(define (get-all-methods obj)
(if (object? obj)
((vector-ref obj 4))
(slib:error "Cannot get methods on non-object: " obj)))
(define (object? obj)
(and (vector? obj)
(eq? object:tag (vector-ref obj 0))))
(define (make-method! obj generic-method method)
(if (object? obj)
(if (procedure? method)
(begin
((vector-ref obj 2) generic-method method)
method)
(slib:error "Method must be a procedure: " method))
(slib:error "Cannot make method on non-object: " obj)))
(define (get-method obj generic-method)
(if (object? obj)
((vector-ref obj 1) generic-method)
(slib:error "Cannot get method on non-object: " obj)))
(define (unmake-method! obj generic-method)
(if (object? obj)
((vector-ref obj 3) generic-method)
(slib:error "Cannot unmake method on non-object: " obj)))
(define (make-predicate! obj generic-predicate)
(if (object? obj)
((vector-ref obj 2) generic-predicate (lambda (self) #t))
(slib:error "Cannot make predicate on non-object: " obj)))
(define (make-generic-method . exception-procedure)
(define generic-method
(lambda (obj . operands)
(if (object? obj)
(let ((object-method ((vector-ref obj 1) generic-method)))
(if object-method
(apply object-method (cons obj operands))
(slib:error "Method not supported: " obj)))
(apply exception-procedure (cons obj operands)))))
(if (not (null? exception-procedure))
(if (procedure? (car exception-procedure))
(set! exception-procedure (car exception-procedure))
(slib:error "Exception Handler Not Procedure:"))
(set! exception-procedure
(lambda (obj . params)
(slib:error "Operation not supported: " obj))))
generic-method)
(define (make-generic-predicate)
(define generic-predicate
(lambda (obj)
(if (object? obj)
(if ((vector-ref obj 1) generic-predicate)
#t
#f)
#f)))
generic-predicate)
(define (make-object . ancestors)
(define method-list
(apply append (map (lambda (obj) (get-all-methods obj)) ancestors)))
(define (make-method! generic-method method)
(set! method-list (cons (cons generic-method method) method-list))
method)
(define (unmake-method! generic-method)
(set! method-list (object:removeq generic-method method-list))
#t)
(define (all-methods) method-list)
(define (get-method generic-method)
(let ((method-def (assq generic-method method-list)))
(if method-def (cdr method-def) #f)))
(vector object:tag get-method make-method! unmake-method! all-methods))

141
module/slib/paramlst.scm
View file

@ -1,141 +0,0 @@
;;; "paramlst.scm" passing parameters by name.
; Copyright 1995, 1996, 1997, 2001 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;;; Format of arity-spec: (name predicate conversion)
(require 'common-list-functions)
(define arity->arity-spec
(let ((table
`((nary
,(lambda (a) #t)
,identity)
(nary1
,(lambda (a) (not (null? a)))
,identity)
(single
,(lambda (a) (and (pair? a) (null? (cdr a))))
,car)
(optional
,(lambda (a) (or (null? a) (and (pair? a) (null? (cdr a)))))
,identity)
(boolean
,(lambda (a)
(or (null? a)
(and (pair? a) (null? (cdr a)) (boolean? (car a)))))
,(lambda (a) (if (null? a) #f (car a)))))))
(lambda (arity)
(assq arity table))))
(define (fill-empty-parameters defaulters parameter-list)
(map (lambda (defaulter parameter)
(cond ((null? (cdr parameter))
(cons (car parameter)
(if defaulter (defaulter parameter-list) '())))
(else parameter)))
defaulters parameter-list))
(define (check-parameters checks parameter-list)
(and (every (lambda (check parameter)
(every
(lambda (p)
(let ((good? (not (and check (not (check p))))))
(if (not good?) (slib:warn (car parameter) 'parameter? p))
good?))
(cdr parameter)))
checks parameter-list)
parameter-list))
(define (check-arities arity-specs parameter-list)
(every (lambda (arity-spec param)
(cond ((not arity-spec) (slib:warn 'missing 'arity arity-specs) #f)
(((cadr arity-spec) (cdr param)) #t)
((null? (cdr param)) (slib:warn param 'missing) #f)
(else (slib:warn param 'not (car arity-spec)) #f)))
arity-specs parameter-list))
(define (parameter-list->arglist positions arities parameter-list)
(and (= (length arities) (length positions) (length parameter-list))
(let ((arity-specs (map arity->arity-spec arities))
(ans (make-vector (length positions) #f)))
(and (check-arities arity-specs parameter-list)
(for-each
(lambda (pos arity-spec param)
(vector-set! ans (+ -1 pos)
((caddr arity-spec) (cdr param))))
positions arity-specs parameter-list)
(vector->list ans)))))
(define (make-parameter-list parameter-names)
(map list parameter-names))
(define (parameter-list-ref parameter-list i)
(let ((ans (assoc i parameter-list)))
(and ans (cdr ans))))
(define (parameter-list-expand expanders parms)
(do ((lens (map length parms) (map length parms))
(olens '() lens))
((equal? lens olens))
(for-each (lambda (expander parm)
(cond
(expander
(for-each
(lambda (news)
(cond ((adjoin-parameters! parms news))
(else (slib:error
"expanded feature unknown: " news))))
(apply append
(map (lambda (p)
(cond ((expander p))
((not '()) '())
(else (slib:error
"couldn't expand feature: " p))))
(cdr parm)))))))
expanders
parms)))
(define (adjoin-parameters! parameter-list . parameters)
(let ((apairs (map (lambda (param)
(cond ((pair? param)
(assoc (car param) parameter-list))
(else (assoc param parameter-list))))
parameters)))
(and (every identity apairs) ;same as APPLY AND?
(for-each
(lambda (apair param)
(cond ((pair? param)
(for-each (lambda (o)
(if (not (member o (cdr apair)))
(set-cdr! apair (cons o (cdr apair)))))
(cdr param)))
(else (if (not (memv #t (cdr apair)))
(set-cdr! apair (cons #t (cdr apair)))))))
apairs parameters)
parameter-list)))
(define (remove-parameter pname parameter-list)
(define found? #f)
(remove-if (lambda (elt)
(cond ((not (and (pair? elt) (eqv? pname (car elt)))) #f)
(found?
(slib:error
'remove-parameter 'multiple pname 'in parameter-list))
(else (set! found? #t) #t)))
parameter-list))

47
module/slib/plottest.scm
View file

@ -1,47 +0,0 @@
;"plottest.scm" test charplot.scm
;Copyright (C) 1992 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;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 'charplot)
(require 'random)
(define strophoid
(let ((l '()))
(do ((x -1.0 (+ x 0.05)))
((> x 4.0))
(let* ((a (/ (- 2 x) (+ 2 x))))
(if (>= a 0.0)
(let* ((y (* x (sqrt a))))
(set! l (cons (cons x y) l))
(set! l (cons (cons x (- y)) l))))))
l))
(plot! strophoid "x" "y") (newline)
(define unif
(let* ((l 6)
(v (make-vector l)))
(do ((i (- l 1) (- i 1)))
((negative? i))
(vector-set! v i (cons i 0)))
(do ((i 24 (- i 1))
(r (random l) (random l)))
((zero? i) (vector->list v))
(set-cdr! (vector-ref v r) (+ 1 (cdr (vector-ref v r)))))))
(plot! unif "n" "occur")

213
module/slib/pnm.scm
View file

@ -1,213 +0,0 @@
;;; "pnm.scm" Read PNM image files.
; Copyright 2000 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'scanf)
(require 'printf)
(require 'array)
(require 'array-for-each)
(require 'byte)
(require 'line-i/o)
(define (pnm:read+integer port)
(define uint #f)
(do ((chr (peek-char port) (peek-char port)))
((not (and (char? chr) (or (char-whitespace? chr) (eqv? #\# chr)))))
(if (eqv? #\# chr)
(read-line port)
(read-char port)))
(if (eof-object? (peek-char port))
(peek-char port)
(and (eqv? 1 (fscanf port " %u" uint)) uint)))
(define (pnm:type-dimensions port)
(if (input-port? port)
(let* ((c1 (read-char port))
(c2 (read-char port)))
(cond
((and (eqv? #\P c1)
(char? c2)
(char-numeric? c2)
(char-whitespace? (peek-char port)))
(let* ((format (string->symbol (string #\p c2)))
(width (pnm:read+integer port))
(height (pnm:read+integer port))
(ret
(case format
((p1) (list 'pbm width height 1))
((p4) (list 'pbm-raw width height 1))
((p2) (list 'pgm width height (pnm:read+integer port)))
((p5) (list 'pgm-raw width height (pnm:read+integer port)))
((p3) (list 'ppm width height (pnm:read+integer port)))
((p6) (list 'ppm-raw width height (pnm:read+integer port)))
(else #f))))
(and (char-whitespace? (read-char port)) ret)))
(else #f)))
(call-with-input-file port pnm:type-dimensions)))
(define (pnm:read-binary! array port)
(array-map! array (lambda () (read-byte port))))
(define (pnm:image-file->array path . array)
(set! array (and (not (null? array)) (car array)))
(call-with-input-file path
(lambda (port)
(apply (lambda (type width height max-pixel)
(define (read-binary)
(pnm:read-binary! array port)
(if (eof-object? (peek-char port)) array
(slib:error type 'not 'at 'file 'end)))
(define (read-text)
(array-map! array (lambda () (pnm:read+integer port)))
(if (eof-object? (pnm:read+integer port)) array
(slib:error type 'not 'at 'file 'end)))
(define (read-pbm)
(array-map! array (lambda () (eqv? 1 (pnm:read+integer port))))
(if (eof-object? (pnm:read+integer port)) array
(slib:error type 'not 'at 'file 'end)))
(case type
((pbm)
(or array
(set! array (make-array #t height width)))
(read-pbm))
((pgm)
(or array
(set! array (make-array max-pixel height width)))
(read-text))
((ppm)
(or array
(set! array (make-array max-pixel height width 3)))
(read-text))
((pbm-raw)
(or array
(set! array (make-array #t height (quotient width 8))))
(read-binary))
((pgm-raw)
(or array
(set! array (make-array max-pixel height width)))
(read-binary))
((ppm-raw)
(or array
(set! array (make-array max-pixel height width 3)))
(read-binary))))
(pnm:type-dimensions port)))))
(define (pnm:image-file->uniform-array path . array)
(fluid-let ((make-array make-uniform-array)
(pnm:read-binary!
(lambda (ra port)
(if (array? ra #t)
(error 'pnm:image-file->array
"pbm-raw support unimplemented")
(let ((bytes (apply make-uniform-array #\a
(array-dimensions ra))))
(uniform-array-read! bytes port)
(array-map! ra char->integer bytes))))))
(apply pnm:image-file->array path array)))
;; ARRAY is required to be zero-based.
(define (pnm:array-write type array maxval port)
(define (write-header type height width maxval)
(let ((magic
(case type
((pbm) "P1")
((pgm) "P2")
((ppm) "P3")
((pbm-raw) "P4")
((pgm-raw) "P5")
((ppm-raw) "P6")
(else (error 'pnm:array-write "bad type" type)))))
(fprintf port "%s\n%d %d" magic width height)
(if maxval (fprintf port "\n%d" maxval))))
(define (write-pixels type array maxval)
(let* ((shp (array-dimensions array))
(height (car shp))
(width (cadr shp)))
(case type
((pbm-raw)
(newline port)
(if (array? array #t)
(uniform-array-write array port)
(error 'pnm:array-write "expected bit-array" array)))
((pgm-raw ppm-raw)
(newline port)
;;; (let ((bytes (apply make-uniform-array #\a shp)))
;;; (array-map! bytes integer->char array)
;;; (uniform-array-write bytes port))
(uniform-array-write array port))
((pbm)
(do ((i 0 (+ i 1)))
((>= i height))
(do ((j 0 (+ j 1)))
((>= j width))
(display (if (zero? (remainder j 35)) #\newline #\space) port)
(display (if (array-ref array i j) #\1 #\0) port)))
(newline port))
((pgm)
(do ((i 0 (+ i 1)))
((>= i height))
(do ((j 0 (+ j 1)))
((>= j width))
(display (if (zero? (remainder j 17)) #\newline #\space) port)
(display (array-ref array i j) port)))
(newline port))
((ppm)
(do ((i 0 (+ i 1)))
((>= i height))
(do ((j 0 (+ j 1)))
((>= j width))
(display (if (zero? (remainder j 5)) #\newline " ") port)
(display (array-ref array i j 0) port)
(display #\space port)
(display (array-ref array i j 1) port)
(display #\space port)
(display (array-ref array i j 2) port)))
(newline port)))))
(if (output-port? port)
(let ((rnk (array-rank array))
(shp (array-dimensions array)))
(case type
((pbm pbm-raw)
(or (and (eqv? 2 rnk)
(integer? (car shp))
(integer? (cadr shp)))
(error 'pnm:array-write "bad shape" type array))
(or (eqv? 1 maxval)
(error 'pnm:array-write "maxval supplied not 1" type))
(write-header type (car shp) (cadr shp) #f)
(write-pixels type array 1))
((pgm pgm-raw)
(or (and (eqv? 2 rnk)
(integer? (car shp))
(integer? (cadr shp)))
(error 'pnm:array-write "bad shape" type array))
(write-header type (car shp) (cadr shp) maxval)
(write-pixels type array maxval))
((ppm ppm-raw)
(or (and (eqv? 3 rnk)
(integer? (car shp))
(integer? (cadr shp))
(eqv? 3 (caddr shp)))
(error 'pnm:array-write "bad shape" type array))
(write-header type (car shp) (cadr shp) maxval)
(write-pixels type array maxval))
(else (error 'pnm:array-write type 'unrecognized 'type))))
(call-with-output-file port
(lambda (port)
(pnm:array-write type array maxval port)))))

15
module/slib/pp.scm
View file

@ -1,15 +0,0 @@
;"pp.scm" Pretty-Print
(require 'generic-write)
(define (pp:pretty-print obj . opt)
(let ((port (if (pair? opt) (car opt) (current-output-port))))
(generic-write obj #f (output-port-width port)
(lambda (s) (display s port) #t))))
(define (pretty-print->string obj . width)
(define result '())
(generic-write obj #f (if (null? width) (output-port-width) (car width))
(lambda (str) (set! result (cons str result)) #t))
(reverse-string-append result))
(define pretty-print pp:pretty-print)

70
module/slib/ppfile.scm
View file

@ -1,70 +0,0 @@
;;;; "ppfile.scm". Pretty print a Scheme file.
;Copyright (C) 1993, 1994 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;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 'pretty-print)
(define (pprint-filter-file inport filter . optarg)
((lambda (fun)
(if (input-port? inport)
(fun inport)
(call-with-input-file inport fun)))
(lambda (port)
((lambda (fun)
(let ((outport
(if (null? optarg) (current-output-port) (car optarg))))
(if (output-port? outport)
(fun outport)
(call-with-output-file outport fun))))
(lambda (export)
(let ((old-load-pathname *load-pathname*))
(set! *load-pathname* inport)
(letrec ((lp (lambda (c)
(cond ((eof-object? c))
((char-whitespace? c)
(display (read-char port) export)
(lp (peek-char port)))
((char=? #\; c)
(cmt c))
(else (sx)))))
(cmt (lambda (c)
(cond ((eof-object? c))
((char=? #\newline c)
(display (read-char port) export)
(lp (peek-char port)))
(else
(display (read-char port) export)
(cmt (peek-char port))))))
(sx (lambda ()
(let ((o (read port)))
(cond ((eof-object? o))
(else
(pretty-print (filter o) export)
;; pretty-print seems to have extra newline
(let ((c (peek-char port)))
(cond ((eqv? #\newline c)
(read-char port)
(set! c (peek-char port))))
(lp c))))))))
(lp (peek-char port)))
(set! *load-pathname* old-load-pathname)))))))
(define (pprint-file ifile . optarg)
(pprint-filter-file ifile
(lambda (x) x)
(if (null? optarg) (current-output-port) (car optarg))))

448
module/slib/prec.scm
View file

@ -1,448 +0,0 @@
; "prec.scm", dynamically extensible parser/tokenizer -*-scheme-*-
; Copyright 1989, 1990, 1991, 1992, 1993, 1995, 1997 Aubrey Jaffer.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
; This file implements:
; * a Pratt style parser.
; * a tokenizer which congeals tokens according to assigned classes of
; constituent characters.
;
; This module is a significant improvement because grammar can be
; changed dynamically from rulesets which don't need compilation.
; Theoretically, all possibilities of bad input are handled and return
; as much structure as was parsed when the error occured; The symbol
; `?' is substituted for missing input.
; References for the parser are:
; Pratt, V. R.
; Top Down Operator Precendence.
; SIGACT/SIGPLAN
; Symposium on Principles of Programming Languages,
; Boston, 1973, 41-51
; WORKING PAPER 121
; CGOL - an Alternative External Representation For LISP users
; Vaughan R. Pratt
; MIT Artificial Intelligence Lab.
; March 1976
; Mathlab Group,
; MACSYMA Reference Manual, Version Ten,
; Laboratory for Computer Science, MIT, 1983
(require 'fluid-let)
(require 'string-search)
(require 'string-port)
(require 'delay)
(define *syn-defs* #f)
(define *syn-rules* #f) ;Dynamically bound
(define *prec:port* #f) ;Dynamically bound
;; keeps track of input column so we can generate useful error displays.
(define tok:column 0)
(define (tok:peek-char) (peek-char *prec:port*))
(define (tok:read-char)
(let ((c (read-char *prec:port*)))
(if (or (eqv? c #\newline) (eof-object? c))
(set! tok:column 0)
(set! tok:column (+ 1 tok:column)))
c))
(define (tok:bump-column pos . ports)
((lambda (thunk)
(cond ((null? ports) (thunk))
(else (fluid-let ((*prec:port* (car ports))) (thunk)))))
(lambda ()
(cond ((eqv? #\newline (tok:peek-char))
(tok:read-char))) ;to do newline
(set! tok:column (+ tok:column pos)))))
(define (prec:warn . msgs)
(do ((j (+ -1 tok:column) (+ -8 j)))
((> 8 j)
(do ((i j (+ -1 i)))
((>= 0 i))
(display #\ )))
(display slib:tab))
(display "^ ")
(newline)
(for-each (lambda (x) (write x) (display #\ )) msgs)
(newline))
;; Structure of lexical records.
(define tok:make-rec cons)
(define tok:cc car)
(define tok:sfp cdr)
(define (tok:lookup alist char)
(if (eof-object? char)
#f
(let ((pair (assv char alist)))
(and pair (cdr pair)))))
(define (tok:char-group group chars chars-proc)
(map (lambda (token)
;;; (let ((oldlexrec (tok:lookup *syn-defs* token)))
;;; (cond ((or (not oldlexrec) (eqv? (tok:cc oldlexrec) group)))
;;; (else (math:warn 'cc-of token 'redefined-to- group))))
(cons token (tok:make-rec group chars-proc)))
(cond ((string? chars) (string->list chars))
((char? chars) (list chars))
(else chars))))
(define (tokenize)
(let* ((char (tok:read-char))
(rec (tok:lookup *syn-rules* char))
(proc (and rec (tok:cc rec)))
(clist (list char)))
(cond
((not proc) char)
((procedure? proc)
(do ((cl clist (begin (set-cdr! cl (list (tok:read-char))) (cdr cl))))
((proc (tok:peek-char))
((or (tok:sfp rec) list->string) clist))))
((eqv? 0 proc) (tokenize))
(else
(do ((cl clist (begin (set-cdr! cl (list (tok:read-char))) (cdr cl))))
((not (let* ((prec (tok:lookup *syn-rules* (tok:peek-char)))
(cclass (and prec (tok:cc prec))))
(or (eqv? cclass proc)
(eqv? cclass (+ -1 proc)))))
((tok:sfp rec) clist)))))))
;;; PREC:NUD is the null denotation (function and arguments to call when no
;;; unclaimed tokens).
;;; PREC:LED is the left denotation (function and arguments to call when
;;; unclaimed token is on left).
;;; PREC:LBP is the left binding power of this LED. It is the first
;;; argument position of PREC:LED
(define (prec:nudf alist self)
(let ((pair (assoc (cons 'nud self) alist)))
(and pair (cdr pair))))
(define (prec:ledf alist self)
(let ((pair (assoc (cons 'led self) alist)))
(and pair (cdr pair))))
(define (prec:lbp alist self)
(let ((pair (assoc (cons 'led self) alist)))
(and pair (cadr pair))))
(define (prec:call-or-list proc . args)
(prec:apply-or-cons proc args))
(define (prec:apply-or-cons proc args)
(if (procedure? proc) (apply proc args) (cons (or proc '?) args)))
;;; PREC:SYMBOLFY and PREC:DE-SYMBOLFY are not exact inverses.
(define (prec:symbolfy obj)
(cond ((symbol? obj) obj)
((string? obj) (string->symbol obj))
((char? obj) (string->symbol (string obj)))
(else obj)))
(define (prec:de-symbolfy obj)
(cond ((symbol? obj) (symbol->string obj))
(else obj)))
;;;Calls to set up tables.
(define (prec:define-grammar . synlsts)
(set! *syn-defs* (append (apply append synlsts) *syn-defs*)))
(define (prec:make-led toks . args)
(map (lambda (tok)
(cons (cons 'led (prec:de-symbolfy tok))
args))
(if (pair? toks) toks (list toks))))
(define (prec:make-nud toks . args)
(map (lambda (tok)
(cons (cons 'nud (prec:de-symbolfy tok))
args))
(if (pair? toks) toks (list toks))))
;;; Produce dynamically augmented grammars.
(define (prec:process-binds binds rules)
(if (and #f (not (null? binds)) (eq? #t (car binds)))
(cdr binds)
(append binds rules)))
;;(define (prec:replace-rules) some-sort-of-magic-cookie)
;;; Here are the procedures to define high-level grammar, along with
;;; utility functions called during parsing. The utility functions
;;; (prec:parse-*) could be incorportated into the defining commands,
;;; but tracing these functions is useful for debugging.
(define (prec:delim tk)
(prec:make-led tk 0 #f))
(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)
(prec:make-nud tk prec:parse-prefix sop bp (apply append binds)))
(define (prec:parse-prefix self sop bp binds)
(fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*)))
(prec:call-or-list (or sop (prec:symbolfy self)) (prec:parse1 bp))))
(define (prec:infix tk sop lbp bp . binds)
(prec:make-led tk lbp prec:parse-infix sop bp (apply append binds)))
(define (prec:parse-infix left self lbp sop bp binds)
(fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*)))
(prec:call-or-list (or sop (prec:symbolfy self)) left (prec:parse1 bp))))
(define (prec:nary tk sop bp)
(prec:make-led tk bp prec:parse-nary sop bp))
(define (prec:parse-nary left self lbp sop bp)
(prec:apply-or-cons (or sop (prec:symbolfy self))
(cons left (prec:parse-list self bp))))
(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)
(prec:make-nud tk prec:parse-rest sop bp (apply append binds)))
(define (prec:parse-rest self sop bp binds)
(fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*)))
(prec:apply-or-cons (or sop (prec:symbolfy self)) (prec:parse-list #f bp))))
(define (prec:commentfix tk stp match . binds)
(append
(prec:make-nud tk prec:parse-nudcomment stp match (apply append binds))
(prec:make-led tk 220 prec:parse-ledcomment stp match (apply append binds))))
(define (prec:parse-nudcomment self stp match binds)
(fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*)))
(tok:read-through-comment stp match)
(prec:advance)
(cond ((prec:delim? (force prec:token)) #f)
(else (prec:parse1 prec:bp)))))
(define (prec:parse-ledcomment left lbp self stp match binds)
(fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*)))
(tok:read-through-comment stp match)
(prec:advance)
left))
(define (tok:read-through-comment stp match)
(set! match (if (char? match)
(string match)
(prec:de-symbolfy match)))
(cond ((procedure? stp)
(let* ((len #f)
(str (call-with-output-string
(lambda (sp)
(set! len (find-string-from-port?
match *prec:port*
(lambda (c) (display c sp) #f)))))))
(stp (and len (substring str 0 (- len (string-length match)))))))
(else (find-string-from-port? match *prec:port*))))
(define (prec:matchfix tk sop sep match . binds)
(define sep-lbp 0)
(prec:make-nud tk prec:parse-matchfix
sop sep-lbp sep match
(apply append (prec:delim match) binds)))
(define (prec:parse-matchfix self sop sep-lbp sep match binds)
(fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*)))
(cond (sop (prec:apply-or-cons
sop (prec:parse-delimited sep sep-lbp match)))
((equal? (force prec:token) match)
(prec:warn 'expression-missing)
(prec:advance)
'?)
(else (let ((ans (prec:parse1 0))) ;just parenthesized expression
(cond ((equal? (force prec:token) match)
(prec:advance))
((prec:delim? (force prec:token))
(prec:warn 'mismatched-delimiter (force prec:token)
'not match)
(prec:advance))
(else (prec:warn 'delimiter-expected--ignoring-rest
(force prec:token) 'expected match
'or-delimiter)
(do () ((prec:delim? (force prec:token)))
(prec:parse1 0))))
ans)))))
(define (prec:inmatchfix tk sop sep match lbp . binds)
(define sep-lbp 0)
(prec:make-led tk lbp prec:parse-inmatchfix
sop sep-lbp sep match
(apply append (prec:delim match) binds)))
(define (prec:parse-inmatchfix left self lbp sop sep-lbp sep match binds)
(fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*)))
(prec:apply-or-cons
sop (cons left (prec:parse-delimited sep sep-lbp match)))))
;;;; Here is the code which actually parses.
(define prec:bp #f) ;dynamically bound
(define prec:token #f)
(define (prec:advance)
(set! prec:token (delay (tokenize))))
(define (prec:advance-return-last)
(let ((last (and prec:token (force prec:token))))
(prec:advance)
last))
(define (prec:nudcall self)
(let ((pob (prec:nudf *syn-rules* self)))
(cond
(pob (let ((proc (car pob)))
(cond ((procedure? proc) (apply proc self (cdr pob)))
(proc (cons proc (cdr pob)))
(else '?))))
((char? self) (prec:warn 'extra-separator)
(prec:advance)
(prec:nudcall (force prec:token)))
((string? self) (string->symbol self))
(else self))))
(define (prec:ledcall left self)
(let* ((pob (prec:ledf *syn-rules* self)))
(apply (cadr pob) left self (cdr pob))))
;;; PREC:PARSE1 is the heart.
(define (prec:parse1 bp)
(fluid-let ((prec:bp bp))
(do ((left (prec:nudcall (prec:advance-return-last))
(prec:ledcall left (prec:advance-return-last))))
((or (>= bp 200) ;to avoid unneccesary lookahead
(>= bp (or (prec:lbp *syn-rules* (force prec:token)) 0))
(not left))
left))))
(define (prec:delim? token)
(or (eof-object? token) (<= (or (prec:lbp *syn-rules* token) 220) 0)))
(define (prec:parse-list sep bp)
(cond ((prec:delim? (force prec:token))
(prec:warn 'expression-missing)
'(?))
(else
(let ((f (prec:parse1 bp)))
(cons f (cond ((equal? (force prec:token) sep)
(prec:advance)
(cond ((equal? (force prec:token) sep)
(prec:warn 'expression-missing)
(prec:advance)
(cons '? (prec:parse-list sep bp)))
((prec:delim? (force prec:token))
(prec:warn 'expression-missing)
'(?))
(else (prec:parse-list sep bp))))
((prec:delim? (force prec:token)) '())
((not sep) (prec:parse-list sep bp))
((prec:delim? sep) (prec:warn 'separator-missing)
(prec:parse-list sep bp))
(else '())))))))
(define (prec:parse-delimited sep bp delim)
(cond ((equal? (force prec:token) sep)
(prec:warn 'expression-missing)
(prec:advance)
(cons '? (prec:parse-delimited sep delim)))
((prec:delim? (force prec:token))
(if (not (equal? (force prec:token) delim))
(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 (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)
ans))))
(define (prec:parse grammar delim . port)
(set! delim (prec:de-symbolfy delim))
(fluid-let ((*syn-rules* (append (prec:delim delim) grammar))
(*prec:port* (if (null? port) (current-input-port) (car port))))
(prec:advance) ; setup prec:token with first token
(cond ((eof-object? (force prec:token)) (force prec:token))
((equal? (force prec:token) delim) #f)
(else
(let ((ans (prec:parse1 0)))
(cond ((eof-object? (force prec:token)))
((equal? (force prec:token) delim))
(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))))
ans)))))
(define tok:decimal-digits "0123456789")
(define tok:upper-case "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
(define tok:lower-case "abcdefghijklmnopqrstuvwxyz")
(define tok:whitespaces
(do ((i (+ -1 (min 256 char-code-limit)) (+ -1 i))
(ws "" (if (char-whitespace? (integer->char i))
(string-append ws (string (integer->char i)))
ws)))
((negative? i) ws)))
;;;;The parse tables.
;;; Definitions accumulate in top-level variable *SYN-DEFS*.
(set! *syn-defs* '()) ;Make sure *SYN-DEFS* is empty.
;;; Ignore Whitespace characters.
(prec:define-grammar (tok:char-group 0 tok:whitespaces #f))
;;; On MS-DOS systems, <ctrl>-Z (26) needs to be ignored in order to
;;; avoid problems at end of files.
(case (software-type)
((MSDOS)
(if (not (char-whitespace? (integer->char 26)))
(prec:define-grammar (tok:char-group 0 (integer->char 26) #f))
)))
;;; Save these convenient definitions.
(define *syn-ignore-whitespace* *syn-defs*)
(set! *syn-defs* '())
(define (prec:trace)
(require 'trace)
(trace prec:parse prec:parse1
prec:parse-delimited prec:parse-list
prec:call-or-list prec:apply-or-cons
;;tokenize prec:advance-return-last prec:advance
prec:nudcall prec:ledcall
prec:parse-nudcomment prec:parse-ledcomment
prec:parse-delimited prec:parse-list
prec:parse-nary prec:parse-rest
prec:parse-matchfix prec:parse-inmatchfix
prec:parse-prefix prec:parse-infix prec:parse-postfix
;;prec:delim?
;;prec:ledf prec:nudf prec:lbp
)
(set! *qp-width* 333))
;;(begin (trace-all "prec.scm") (set! *qp-width* 333))
;;(pretty-print (grammar-read-tab (get-grammar 'standard)))
;;(prec:trace)

584
module/slib/printf.scm
View file

@ -1,584 +0,0 @@
;;;; "printf.scm" Implementation of standard C functions for Scheme
;;; Copyright (C) 1991-1993, 1996 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 'string-case)
;; 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.
;; If STR denotes a non-real number, 3 additional elements for the
;; complex part are appended.
(define (stdio:parse-float str)
(let ((n (string-length str))
(iend 0))
(letrec ((prefix
(lambda (i rest)
(if (and (< i (- n 1))
(char=? #\# (string-ref str i)))
(case (string-ref str (+ i 1))
((#\d #\i #\e) (prefix (+ i 2) rest))
((#\.) (rest i))
(else (parse-error)))
(rest i))))
(sign
(lambda (i rest)
(if (< i n)
(let ((c (string-ref str i)))
(case c
((#\- #\+) (cons c (rest (+ i 1))))
(else (cons #\+ (rest i))))))))
(digits
(lambda (i rest)
(do ((j i (+ j 1)))
((or (>= j n)
(not (or (char-numeric? (string-ref str j))
(char=? #\# (string-ref str j)))))
(cons
(if (= i j) "0" (substring str i j))
(rest j))))))
(point
(lambda (i rest)
(if (and (< i n)
(char=? #\. (string-ref str i)))
(rest (+ i 1))
(rest i))))
(exp
(lambda (i)
(if (< i n)
(case (string-ref str i)
((#\e #\s #\f #\d #\l #\E #\S #\F #\D #\L)
(let ((s (sign (+ i 1) (lambda (i) (digits i end!)))))
(list
(if (char=? #\- (car s))
(- (string->number (cadr s)))
(string->number (cadr s))))))
(else (end! i)
'(0)))
(begin (end! i)
'(0)))))
(end!
(lambda (i)
(set! iend i)
'()))
(real
(lambda (i)
(let ((parsed
(prefix
i
(lambda (i)
(sign
i
(lambda (i)
(digits
i
(lambda (i)
(point
i
(lambda (i)
(digits i exp)))))))))))
(and
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 (< i n)
(if (char=? #\0 (string-ref digs i))
(loop (+ i 1) (- exp 1))
(list sgn (substring digs (- i 1) n) exp))
;;Zero
(list sgn "0" 1)))))
parsed)))))
(parse-error
(lambda () #f)))
(let ((realpart (real 0)))
(cond ((= iend n) realpart)
((memv (string-ref str iend) '(#\+ #\-))
(let ((complexpart (real iend)))
(and (= iend (- n 1))
(char-ci=? #\i (string-ref str iend))
(append realpart complexpart))))
((eqv? (string-ref str iend) #\@)
;; Polar form: No point in parsing the angle ourselves,
;; since some transcendental approximation is unavoidable.
(let ((num (string->number str)))
(and num
(let ((realpart
(stdio:parse-float
(number->string (real-part num))))
(imagpart
(if (real? num)
'()
(stdio:parse-float
(number->string (imag-part num))))))
(and realpart imagpart
(append realpart imagpart))))))
(else #f))))))
;; 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)
(let ((padlen (max 0 (- (or strip-0s ndigs) n))))
(if (zero? padlen)
str
(string-append str
(make-string padlen
(if (char-numeric?
(string-ref str n))
#\0 #\#))))))
(else
(let ((res (substring str 0 (+ ndigs 1)))
(dig (lambda (i)
(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)
(fl (string-length format-string))
(fc (string-ref format-string 0)))
(define (advance)
(set! pos (+ 1 pos))
(cond ((>= pos fl) (set! fc #f))
(else (set! fc (string-ref format-string pos)))))
(define (must-advance)
(set! pos (+ 1 pos))
(cond ((>= pos fl) (incomplete))
(else (set! fc (string-ref format-string pos)))))
(define (end-of-format?)
(>= pos fl))
(define (incomplete)
(slib:error 'printf "conversion specification incomplete"
format-string))
(define (wna)
(slib:error 'printf "wrong number of arguments"
(length args)
format-string))
(let loop ((args args))
(advance)
(cond
((end-of-format?)
;;(or (null? args) (wna)) ;Extra arguments are *not* a bug.
)
((eqv? #\\ fc);;Emulating C strings may not be a good idea.
(must-advance)
(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) ;-
(signed #f) ;+
(blank #f)
(alternate-form #f) ;#
(leading-0s #f) ;0
(width 0)
(precision -1)
(type-modifier #f)
(read-format-number
(lambda ()
(cond
((eqv? #\* fc) ; GNU extension
(must-advance)
(let ((ans (car args)))
(set! args (cdr args))
ans))
(else
(do ((c fc fc)
(accum 0 (+ (* accum 10)
(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")))
(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")))
((and strip-0s (string=? digs "") (list "0")))
(else
(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)))))
(define (g digs exp)
(let ((strip-0s (not alternate-form)))
(set! alternate-form #f)
(cond ((<= (- 1 precision) exp precision)
(set! precision (- precision exp))
(f digs exp strip-0s))
(else
(set! precision (- precision 1))
(e digs exp strip-0s)))))
(define (k digs exp sep)
(let* ((units '#("y" "z" "a" "f" "p" "n" "u" "m" ""
"k" "M" "G" "T" "P" "E" "Z" "Y"))
(base 8) ;index of ""
(uind (let ((i (if (negative? exp)
(quotient (- exp 3) 3)
(quotient (- exp 1) 3))))
(and
(< -1 (+ i base) (vector-length units))
i))))
(cond (uind
(set! exp (- exp (* 3 uind)))
(set! precision (max 0 (- precision exp)))
(append
(f digs exp #f)
(list sep
(vector-ref units (+ uind base)))))
(else
(g digs 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)))
(letrec ((format-real
(lambda (signed? sgn digs exp . rest)
(if (null? rest)
(cons
(if (char=? #\- sgn) "-"
(if signed? "+" (if blank " " "")))
(case fc
((#\e #\E) (e digs exp #f))
((#\f #\F) (f digs exp #f))
((#\g #\G) (g digs exp))
((#\k) (k digs exp ""))
((#\K) (k digs exp " "))))
(append (format-real signed? sgn digs exp)
(apply format-real #t rest)
'("i"))))))
(if parsed
(apply pad (apply format-real signed parsed))
(pad "???")))))
(do ()
((case fc
((#\-) (set! left-adjust #t) #f)
((#\+) (set! signed #t) #f)
((#\ ) (set! blank #t) #f)
((#\#) (set! alternate-form #t) #f)
((#\0) (set! leading-0s #t) #f)
(else #t)))
(must-advance))
(cond (left-adjust (set! leading-0s #f)))
(cond (signed (set! blank #f)))
(set! width (read-format-number))
(cond ((negative? width)
(set! left-adjust #t)
(set! width (- width))))
(cond ((eqv? #\. fc)
(must-advance)
(set! precision (read-format-number))))
(case fc ;Ignore these specifiers
((#\l #\L #\h)
(set! type-modifier fc)
(must-advance)))
;;At this point fc completely determines the format to use.
(if (null? args)
(if (memv (char-downcase fc)
'(#\c #\s #\a #\d #\i #\u #\o #\x #\b
#\f #\e #\g #\k))
(wna)))
(case fc
;; only - is allowed between % and c
((#\c #\C) ; C is enhancement
(and (out (string (car args))) (loop (cdr args))))
;; only - flag, no type-modifiers
((#\s #\S) ; S is enhancement
(let ((s (cond
((symbol? (car args)) (symbol->string (car args)))
((not (car args)) "(NULL)")
(else (car args)))))
(cond ((not (or (negative? precision)
(>= precision (string-length s))))
(set! s (substring s 0 precision))))
(and (out (cond
((<= width (string-length s)) s)
(left-adjust
(string-append
s (make-string (- width (string-length s)) #\ )))
(else
(string-append
(make-string (- width (string-length s))
(if leading-0s #\0 #\ )) s))))
(loop (cdr args)))))
;; SLIB extension
((#\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))
(set! pr 0)
(lambda (s)
(set! pr (+ pr (string-length s)))
(out s)))
(left-adjust
(lambda (s)
(define sl (- pr (string-length s)))
(set! pr (cond ((negative? sl)
(out (substring s 0 pr)) 0)
(else (out s) sl)))
(positive? sl)))
((negative? pr)
(set! pr width)
(lambda (s)
(set! pr (- pr (string-length s)))
(cond ((not os) (out s))
((negative? pr)
(out os)
(set! os #f)
(out s))
(else (set! os (string-append os s))))
#t))
(else
(lambda (s)
(define sl (- pr (string-length s)))
(cond ((negative? sl)
(set! os (string-append
os (substring s 0 pr))))
(else (set! os (string-append os s))))
(set! pr sl)
(positive? sl)))))
(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)) #\ )))))
((not os))
((<= 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)
(and (out (integer-convert (car args) 10)) (loop (cdr args))))
((#\o #\O)
(and (out (integer-convert (car args) 8)) (loop (cdr args))))
((#\x #\X)
(and (out ((if (char-upper-case? fc)
string-upcase string-downcase)
(integer-convert (car args) 16)))
(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 #\k #\K)
(and (out (float-convert (car args) fc)) (loop (cdr args))))
(else
(cond ((end-of-format?) (incomplete))
(else (and (out #\%) (out fc) (out #\?) (loop args))))))))
(else (and (out fc) (loop args)))))))))
(define (stdio:fprintf port format . args)
(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: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)
(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)
(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")))

136
module/slib/priorque.scm
View file

@ -1,136 +0,0 @@
;;;; "priorque.scm" priority queues for Scheme.
;;; Copyright (C) 1992, 1993, 1994, 1995, 1997 Aubrey Jaffer.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;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.
;;; Algorithm from:
;;; Introduction to Algorithms by T. Cormen, C. Leiserson, R. Rivest.
;;; 1989 MIT Press.
(require 'record)
;; Record type.
(define heap:rtd (make-record-type "heap" '(array size heap<?)))
;; Constructor.
(define heap:make-heap
(let ((cstr (record-constructor heap:rtd)))
(lambda (pred<?)
(cstr (make-vector 4) 0 pred<?))))
;; Reference an element.
(define heap:ref
(let ((ra (record-accessor heap:rtd 'array)))
(lambda (a i)
(vector-ref (ra a) (+ -1 i)))))
;; Set an element.
(define heap:set!
(let ((ra (record-accessor heap:rtd 'array)))
(lambda (a i v)
(vector-set! (ra a) (+ -1 i) v))))
;; Exchange two elements.
(define heap:exchange
(let ((aa (record-accessor heap:rtd 'array)))
(lambda (a i j)
(set! i (+ -1 i))
(set! j (+ -1 j))
(let* ((ra (aa a))
(tmp (vector-ref ra i)))
(vector-set! ra i (vector-ref ra j))
(vector-set! ra j tmp)))))
;; Get length.
(define heap:length (record-accessor heap:rtd 'size))
(define heap:heap<? (record-accessor heap:rtd 'heap<?))
(define heap:set-size!
(let ((aa (record-accessor heap:rtd 'array))
(am (record-modifier heap:rtd 'array))
(sm (record-modifier heap:rtd 'size)))
(lambda (a s)
(let ((ra (aa a)))
(if (> s (vector-length ra))
(let ((nra (make-vector (+ s (quotient s 2)))))
(do ((i (+ -1 (vector-length ra)) (+ -1 i)))
((negative? i) (am a nra))
(vector-set! nra i (vector-ref ra i)))))
(sm a s)))))
(define (heap:parent i) (quotient i 2))
(define (heap:left i) (* 2 i))
(define (heap:right i) (+ 1 (* 2 i)))
(define (heap:heapify a i)
(let* ((l (heap:left i))
(r (heap:right i))
(largest (if (and (<= l (heap:length a))
((heap:heap<? a) (heap:ref a i) (heap:ref a l)))
l
i)))
(cond ((and (<= r (heap:length a))
((heap:heap<? a) (heap:ref a largest) (heap:ref a r)))
(set! largest r)))
(cond ((not (= largest i))
(heap:exchange a i largest)
(heap:heapify a largest)))))
(define (heap:insert! a key)
(define i (+ 1 (heap:length a)))
(heap:set-size! a i)
(do ()
((not (and (> i 1)
((heap:heap<? a) (heap:ref a (heap:parent i)) key))))
(heap:set! a i (heap:ref a (heap:parent i)))
(set! i (heap:parent i)))
(heap:set! a i key))
(define (heap:extract-max! a)
(if (< (heap:length a) 1)
(slib:error "heap underflow" a))
(let ((max (heap:ref a 1)))
(heap:set! a 1 (heap:ref a (heap:length a)))
(heap:set-size! a (+ -1 (heap:length a)))
(heap:heapify a 1)
max))
;;
;; Externals.
;;
(define make-heap heap:make-heap)
(define heap-insert! heap:insert!)
(define heap-extract-max! heap:extract-max!)
(define heap-length heap:length)
(define (heap:test)
(require 'debug)
(let ((heap #f))
(set! heap (make-heap char>?))
(heap-insert! heap #\A)
(heap-insert! heap #\Z)
(heap-insert! heap #\G)
(heap-insert! heap #\B)
(heap-insert! heap #\G)
(heap-insert! heap #\Q)
(heap-insert! heap #\S)
(heap-insert! heap #\R)
(do ((i 7 (+ -1 i)))
((negative? i))
(write (heap-extract-max! heap)) (newline))))

68
module/slib/process.scm
View file

@ -1,68 +0,0 @@
;;;; "process.scm", Multi-Processing for Scheme
;;; Copyright (C) 1992, 1993 Aubrey Jaffer.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'full-continuation)
(require 'queue)
(define (add-process! thunk1)
(cond ((procedure? thunk1)
(defer-ints)
(enqueue! process:queue thunk1)
(allow-ints))
(else (slib:error "add-process!: wrong type argument " thunk1))))
(define (process:schedule!)
(defer-ints)
(cond ((queue-empty? process:queue) (allow-ints)
'still-running)
(else (call-with-current-continuation
(lambda (cont)
(enqueue! process:queue cont)
(let ((proc (dequeue! process:queue)))
(allow-ints)
(proc 'run))
(kill-process!))))))
(define (kill-process!)
(defer-ints)
(cond ((queue-empty? process:queue) (allow-ints)
(slib:exit))
(else (let ((proc (dequeue! process:queue)))
(allow-ints)
(proc 'run))
(kill-process!))))
(define ints-disabled #f)
(define alarm-deferred #f)
(define (defer-ints) (set! ints-disabled #t))
(define (allow-ints)
(set! ints-disabled #f)
(cond (alarm-deferred
(set! alarm-deferred #f)
(alarm-interrupt))))
;;; Make THE process queue.
(define process:queue (make-queue))
(define (alarm-interrupt)
(alarm 1)
(if ints-disabled (set! alarm-deferred #t)
(process:schedule!)))

29
module/slib/promise.scm
View file

@ -1,29 +0,0 @@
;;;"promise.scm" promise for force and delay
;;; From Revised^4 Report on the Algorithmic Language Scheme
;;; Editors: William Clinger and Jonathon Rees
;
; We intend this report to belong to the entire Scheme community, and so
; we grant permission to copy it in whole or in part without fee. In
; particular, we encourage implementors of Scheme to use this report as
; a starting point for manuals and other documentation, modifying it as
; necessary.
(define promise:force (lambda (object) (object)))
(define make-promise
(lambda (proc)
(let ((result-ready? #f)
(result #f))
(lambda ()
(if result-ready?
result
(let ((x (proc)))
(if result-ready?
result
(begin (set! result-ready? #t)
(set! result x)
result))))))))
;;; change occurences of (DELAY <expression>) to
;;; (MAKE-PROMISE (LAMBDA () <expression>))
;;; and (define force promise:force)

206
module/slib/pscheme.init
View file

@ -1,206 +0,0 @@
;;; "pscheme.init" SLIB init file for Pocket Scheme -*-scheme-*-
;;; Author: Ben Goetter <goetter@mazama.net>
;;; last revised for 1.1.0 on 16 October 2000
;;; Initial work for 0.2.3 by Robert Goldman (goldman@htc.honeywell.com)
;;; SLIB orig Author: Aubrey Jaffer (jaffer@ai.mit.edu)
;;;
;;; This code is in the public domain.
; best fit for Windows CE?
(define (software-type) 'MS-DOS)
(define (scheme-implementation-type) 'Pocket-Scheme)
(define (scheme-implementation-version)
(let ((v (version)))
(string-append
(number->string (car v)) "."
(number->string (cadr v)) "."
(number->string (caddr v)))))
(define (scheme-implementation-home-page) "http://www.mazama.net/scheme/pscheme.htm")
(define in-vicinity string-append)
(define (implementation-vicinity) "\\Program Files\\Pocket Scheme\\")
(define (library-vicinity) (in-vicinity (implementation-vicinity) "slib\\"))
(define (home-vicinity) "\\My Documents\\")
;(define (implementation-vicinity) "D:\\SRC\\PSCHEME\\BUILD\\TARGET\\X86\\NT\\DBG\\")
;(define (library-vicinity) "D:\\SRC\\SLIB\\")
;(define (home-vicinity) "D:\\SRC\\PSCHEME\\")
(define *features*
'(source
rev4-report
ieee-p1178
rev4-optional-procedures
multiarg/and-
multiarg-apply
with-file
char-ready?
defmacro
rationalize
delay
eval
dynamic-wind
full-continuation
; Undef this to get the SLIB TRACE macros
; trace
system
string-port
))
;;; (OUTPUT-PORT-WIDTH <port>)
;;; (OUTPUT-PORT-HEIGHT <port>)
;; $BUGBUG completely bogus values.
(define (output-port-width . arg) 79)
(define (output-port-height . arg) 12)
;;; (TMPNAM) makes a temporary file name.
(define tmpnam (let ((cntr 100))
(lambda () (set! cntr (+ 1 cntr))
(string-append "slib_" (number->string cntr)))))
;;; (FILE-EXISTS? <string>)
(define (file-exists? f)
(with-handlers (((lambda (x) #t) (lambda (x) #f)))
(close-input-port (open-input-file f))
#t))
;; pscheme: current-error-port, delete-file, force-output already defined
;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
;;; be returned by CHAR->INTEGER.
;(define char-code-limit
; (with-handlers (
; ((lambda (x) #t) (lambda (x) 256))
; )
; (integer->char 65535)
; 65536))
;;; Currently there are only three clients of this symbol.
;;; Following observations relate to PScheme 0.3.5, JACAL 1a9, SLIB 2c5.
;;; JACAL: crashes when set to 65536.
;;; make-crc: extremely inefficient when set to 65536, spending forever in init
;;; precedence-parse: ignores any setting in excess of 256
;;; So we patch it to 256.
(define char-code-limit 256)
;;; MOST-POSITIVE-FIXNUM is used in modular.scm
;;; This is the most positive immediate-value fixnum in PScheme.
(define most-positive-fixnum #x07FFFFFF)
;;; Return argument
(define (identity x) x)
;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
(define slib:eval eval)
;;; If your implementation provides R4RS macros:
;(define macro:eval slib:eval)
;(define macro:load load)
; Define defmacro in terms of our define-macro
(define-macro (defmacro name args . body)
`(define-macro (,name ,@args) ,@body))
; following defns removed in 0.6.3 while I rethink macro support
;(define defmacro? macro?)
;(define macroexpand expand-macro)
;(define macroexpand-1 expand-macro-1)
(define gentemp gensym)
(define base:eval slib:eval)
(define defmacro:eval slib:eval)
(define (slib:eval-load <pathname> evl)
(if (not (file-exists? <pathname>))
(set! <pathname> (string-append <pathname> (scheme-file-suffix))))
(call-with-input-file <pathname>
(lambda (port)
(let ((old-load-pathname *load-pathname*))
(set! *load-pathname* <pathname>)
(do ((o (read port) (read port)))
((eof-object? o))
(evl o))
(set! *load-pathname* old-load-pathname)))))
(define (defmacro:load <pathname>)
(slib:eval-load <pathname> defmacro:eval))
(define slib:warn
(lambda args
(let ((port (current-error-port)))
(display "Warn: " port)
(for-each (lambda (x) (display x port)) args))))
;;; Define an error procedure for the library
(define slib:error error)
;;; As announced by feature string-port
(define (call-with-output-string t)
(let* ((p (open-output-string))
(r (t p))
(s (get-output-string p)))
(close-output-port p)
s))
(define (call-with-input-string s t)
(let* ((p (open-input-string s))
(r (t p)))
(close-input-port p)
r))
;;; define these as appropriate for your system.
(define slib:tab (integer->char 9))
(define slib:form-feed (integer->char 12))
;;; Support for older versions of Scheme. Not enough code for its own file.
(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))
(define t #t)
(define nil #f)
;;; Define these if your implementation's syntax can support it and if
;;; they are not already defined.
(define (1+ n) (+ n 1))
(define (-1+ n) (+ n -1))
(define 1- -1+)
;;; Define SLIB:EXIT to be the implementation procedure to exit or
;;; return if exitting not supported.
(define slib:exit exit)
;;; Here for backward compatability
(define scheme-file-suffix
(let ((suffix (case (software-type)
((NOSVE) "_scm")
(else ".scm"))))
(lambda () suffix)))
;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
;;; suffix all the module files in SLIB have. See feature 'SOURCE.
(define (slib:load-source f)
(if (not (file-exists? f))
(set! f (string-append f (scheme-file-suffix))))
(load f))
;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
;;; by compiling "foo.scm" if this implementation can compile files.
;;; See feature 'COMPILED.
(define slib:load-compiled load)
;;; At this point SLIB:LOAD must be able to load SLIB files.
(define slib:load slib:load-source)
;;; Pscheme and SLIB both define REQUIRE, so dispatch on argument type.
;;; The SLIB REQUIRE does accept strings, though this facility seems never to be used.
(define pscheme:require require)
(slib:load (in-vicinity (library-vicinity) "require"))
(define slib:require require)
(define (require x)
(if (string? x) (pscheme:require x) (slib:require x)))

Some files were not shown because too many files have changed in this diff Show more