scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

r0-t-stable merged into HEAD 

- scheme/sort/* added by hand (for some reason it wasn't merged in)
 - currently, some READ-PARAGRAPH tests don't pass: apparently,
   due to some problems with the regexp library.
This commit is contained in:
jaortega 2008-01-26 17:27:14 +00:00
parent 69d6a1cb6b
commit c818c6316c
142 changed files with 8725 additions and 3065 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
.gitignore vendored
View File

@ -27,10 +27,13 @@ _$*
core
# CVS default ignores end
Makefile
configure
config.log
autom4te.cache
cig
cig/
config.cache
config.log
config.status
configure
go
scsh.image
scshvm
go

8
COPYING
View File

@ -1,7 +1,7 @@
Copyright (c) 1993-2002 Richard Kelsey and Jonathan Rees
Copyright (c) 1994-2002 by Olin Shivers and Brian D. Carlstrom.
Copyright (c) 1999-2002 by Martin Gasbichler.
Copyright (c) 2001-2002 by Michael Sperber.
Copyright (c) 1993-2003 Richard Kelsey and Jonathan Rees
Copyright (c) 1994-2003 by Olin Shivers and Brian D. Carlstrom.
Copyright (c) 1999-2003 by Martin Gasbichler.
Copyright (c) 2001-2003 by Michael Sperber.
All rights reserved.

2
CVS_README
View File

@ -25,7 +25,7 @@ To build Scsh, proceed as follows:
1.) You must have a working version of Scheme 48, version 0.53. Nothing
older, nothing newer. Just 0.53. If you don't have, get it from
http://www.s48.org/0.53/scheme48-0.53.tgz and install Scheme
48. Change to value of the variable BUILD_RUNNABLE in Makefile.in
48. Change the value of the variable BUILD_RUNNABLE in Makefile.in
so that it will point to the Scheme 48 executable.
2.) "cd" into the directory which contains the source code (normally

84
Makefile.in
View File

@ -14,7 +14,7 @@ INSTALL = @INSTALL@
INSTALL_PROGRAM = @INSTALL_PROGRAM@
INSTALL_DATA = @INSTALL_DATA@
LDFLAGS = -g @LDFLAGS@
LDFLAGS = @LDFLAGS@
LIBOBJS = @LIBOBJS@
RM = rm -f
@ -30,6 +30,9 @@ incdir = @includedir@
manext = 1
mandir = @mandir@/man$(manext)
lib_dirs_list = @lib_dirs_list@
host = @host@
### End of `configure' section###
### @machine@ will be substituted below ###
@ -49,10 +52,10 @@ htmldir = $(libdir)/scsh/doc/scsh-manual/html
.c.o:
$(CC) -g -c $(DEFS) -I ./c -I$(srcdir)/c $(CPPFLAGS) $(CFLAGS) -o $@ $<
# BUILD_RUNNABLE has to be Scheme 48 0.53. This is used for builds directly
# BUILD_RUNNABLE has to be Scheme 48 0.53. This is used for builds directly
# out of the CVS repository.
# We cannot use Scsh here since -i is not understood.
BUILD_RUNNABLE = /afs/wsi/i386_fbsd32/bin/scheme48
BUILD_RUNNABLE = /Users/jao/Library/Scheme/s48/bin/scheme48
RUNNABLE = scsh
MANPAGE = $(RUNNABLE).$(manext)
LIB = $(libdir)/$(RUNNABLE)
@ -114,8 +117,8 @@ LIBSCSHVM = scsh/lib$(VM).a
LIBSCSH = scsh/libscsh.a
SCSHVMHACKS = scsh/proc2.o
#
#
#
#
SCSHOBJS = \
scsh/cstuff.o \
scsh/dirstuff1.o \
@ -148,7 +151,7 @@ SRFI_OBJS = c/srfi/srfi-27.o
SRFI_INITIALIZERS = s48_init_srfi_27
S48OBJS = c/scheme48vm.o c/scheme48heap.o c/extension.o c/external.o
S48OBJS = c/scheme48vm.o c/scheme48heap.o c/extension.o c/external.o
OBJS = scsh/process_args.o c/init.o $(S48OBJS) $(SCSHOBJS) \
$(SCSHVMHACKS) $(SRFI_OBJS)
@ -164,7 +167,7 @@ CONFIG_FILES = scheme/interfaces.scm scheme/low-packages.scm \
# The following is the first rule and therefore the "make" command's
# default target.
enough: $(VM) $(IMAGE) go scsh $(LIBSCSH) $(LIBSCSHVM)
enough: $(VM) $(IMAGE) go scsh $(LIBSCSH) $(LIBSCSHVM)
# --------------------
# External code to include in the VM
@ -210,9 +213,9 @@ ADDITIONAL_INITIALIZER = s48_init_additional_inits
touch .notify
-echo SCSH 0.`cat $(srcdir)/scsh/minor-version-number` \
Scheme48 0.`cat $(srcdir)/minor-version-number` infestation. \
| mail scheme-48-notifications@zurich.ai.mit.edu
| mail scheme-48-notifications@zurich.ai.mit.edu
-echo Another scsh 0.`cat $(srcdir)/scsh/minor-version-number` \
infestation. | mail scsh-notifications@zurich.ai.mit.edu
infestation. | mail scsh-notifications@zurich.ai.mit.edu
# These .h files mediate between the code exported from foo1.c
@ -237,7 +240,7 @@ include $(srcdir)/scsh/@machine@/Makefile.inc
$(VM): c/main.o $(OBJS) $(UNIX_OBJS) $(LIBOBJS) $(EXTERNAL_OBJECTS)
rm -f /tmp/s48_external_$$$$.c && \
$(srcdir)/build/build-external-modules /tmp/s48_external_$$$$.c \
$(srcdir)/build/build-external-modules /tmp/s48_external_$$$$.c \
$(EXTERNAL_INITIALIZERS) && \
$(CC) $(LDFLAGS) $(CFLAGS) -o $@ c/main.o $(OBJS) $(UNIX_OBJS) \
/tmp/s48_external_$$$$.c \
@ -256,14 +259,14 @@ $(LIBSCSHVM): c/smain.o $(OBJS)
$(LIBSCSH): $(OBJS) $(UNIX_OBJS) $(LIBOBJS) $(EXTERNAL_OBJECTS)
$(RM) $@ \
rm -f /tmp/s48_external_$$$$.c && \
$(srcdir)/build/build-external-modules /tmp/s48_external_$$$$.c \
$(srcdir)/build/build-external-modules /tmp/s48_external_$$$$.c \
$(EXTERNAL_INITIALIZERS) && \
$(CC) -c $(CFLAGS) -o /tmp/s48_external_$$$$.o \
/tmp/s48_external_$$$$.c && \
$(AR) $@ $(OBJS) $(UNIX_OBJS) $(LIBOBJS) $(EXTERNAL_OBJECTS) \
/tmp/s48_external_$$$$.o && \
$(RANLIB) $@ && \
rm -f /tmp/s48_external_$$$$.c /tmp/s48_external_$$$$.o
rm -f /tmp/s48_external_$$$$.c /tmp/s48_external_$$$$.o
c/main.o: c/main.c
$(CC) -c $(CFLAGS) -o $@ \
@ -300,9 +303,8 @@ c/fake/strerror.o: c/fake/strerror.h
$(IMAGE): $(VM) scheme/env/init-defpackage.scm scheme/more-interfaces.scm \
scheme/link-packages.scm scheme/more-packages.scm \
$(usual-files) build/initial.debug build/build-usual-image
$(srcdir)/build/build-usual-image $(srcdir) \
"`(cd $(srcdir) && echo $$PWD)`/scheme" '$(IMAGE)' './$(VM)' \
'$(INITIAL)'
$(srcdir)/build/build-usual-image $(srcdir) "$(srcdir)/scheme" '$(IMAGE)' './$(VM)' \
'$(srcdir)/$(INITIAL)'
### Fake targets: all clean install man dist
@ -325,7 +327,7 @@ inst-man:
fi
inst-inc:
$(INSTALL_DATA) $(srcdir)/c/scheme48.h $(DESTDIR)$(incdir)
$(INSTALL_DATA) $(srcdir)/c/scheme48.h $(DESTDIR)$(incdir)
$(INSTALL_DATA) $(srcdir)/c/write-barrier.h $(DESTDIR)$(incdir)
inst-misc:
@ -336,7 +338,7 @@ inst-misc:
done && \
for f in $(srcdir)/scheme/rts/*num.scm $(srcdir)/scheme/rts/jar-defrecord.scm; do \
$(INSTALL_DATA) $$f $(DESTDIR)$(LIB)/rts || exit 1; \
done
done
inst-doc:
for f in $(srcdir)/doc/*.txt $(srcdir)/doc/*.ps; do \
@ -401,7 +403,7 @@ dirs:
done && \
for dir in \
rts env big opt misc link srfi scsh doc/scsh-manual \
doc/s48-manual/html doc/scsh-paper/html ; do \
doc/s48-manual/html doc/scsh-paper/html cig; do \
{ mkdir -p $(DESTDIR)$(LIB)/$$dir && [ -w $(DESTDIR)$(LIB)/$$dir ]; } || { \
echo "$(DESTDIR)$(LIB)/$$dir not a writable directory" >&2; \
exit 1; \
@ -421,8 +423,10 @@ clean: clean-scsh
distclean: clean
$(RM) Makefile config.log config.status c/sysdep.h config.cache \
exportlist.aix
$(RM) a.exe $(VM).base $(VM).def $(VM).exp
scsh/endian.scm \
exportlist.aix scsh-config
rmdir scsh/machine
$(RM) a.exe $(VM).base $(VM).def $(VM).exp
-find . -name '*~' -o -name '#*' -o -name core -exec rm {} \;
maintainer-clean: distclean
@ -497,7 +501,7 @@ DISTFILES = README COPYING INSTALL RELEASE configure config.sub config.guess \
distname = $(RUNNABLE)-0.`cat $(srcdir)/build/minor-version-number`
dist: build/initial.image
dist: build/initial.image distclean
(cd doc/src && latex manual.tex && latex manual.tex && \
dvips manual -o manual.ps && hyperlatex manual.tex) && \
(cd doc/scsh-manual && makeindex man && make man.ps && \
@ -599,7 +603,7 @@ link/linker-in-lucid: build/lucid-script.lisp $(linker-files) \
# no debugging environment to speak of.
$(INITIAL): $(LINKER_IMAGE) $(CONFIG_FILES) build/initial.scm $(initial-files) \
scsh/here.scm # gross and Olin hates it -bri
scsh/here.scm # gross and Olin hates it -bri
($(START_LINKER); \
echo '(load-configuration "scheme/interfaces.scm")'; \
echo '(load-configuration "scheme/packages.scm")'; \
@ -677,7 +681,7 @@ c/scheme48.h: c/scheme48.h.in scheme/vm/arch.scm scheme/vm/data.scm \
echo ',batch'; \
echo ',load-package big-scheme'; \
echo ',open big-scheme'; \
echo ',load scheme/link/generate-c-header.scm'; \
echo ',load $(srcdir)/scheme/link/generate-c-header.scm'; \
echo "(make-c-header-file \"$@\" \
\"$(srcdir)/c/scheme48.h.in\" \
\"$(srcdir)/scheme/vm/arch.scm\" \
@ -725,6 +729,7 @@ SCHEME = \
scsh/command-line.scm \
scsh/continuation.scm \
scsh/crypt.scm \
scsh/configure.scm \
scsh/defrec.scm \
scsh/directory.scm \
scsh/dot-locking.scm \
@ -745,6 +750,7 @@ SCHEME = \
scsh/glob.scm \
scsh/here.scm \
scsh/import-os-error-syscall.scm \
scsh/lib-dirs.scm \
scsh/libscsh.scm \
scsh/low-interrupt.scm \
scsh/@machine@/bufpol.scm \
@ -825,12 +831,16 @@ loads = $(srcdir)/scsh/let-opt.scm $(srcdir)/scsh/scsh-interfaces.scm \
opens = floatnums scsh ccp-lib scsh-top-package scsh-here-string-hax \
srfi-1 srfi-13 srfi-14 # srfi-14 is also exported by scsh
# Doing ,load-package scheme-with-scsh here gives us much better start-up times
scsh/scsh.image: $(VM) $(SCHEME) $(IMAGE)
(echo ",translate =scheme48/ `(cd $(srcdir) && echo $$PWD)`/scheme/"; \
echo ",translate $(srcdir)/scsh/machine/ $(srcdir)/scsh/@machine@/"; \
echo ",translate $(srcdir)/scsh/endian.scm `pwd`/scsh/endian.scm"; \
echo ",translate $(srcdir)/scsh/configure.scm `pwd`/scsh/configure.scm"; \
echo ",batch on"; \
echo ",config ,load $(loads)"; \
echo ",open $(opens)"; \
echo ",load-package scheme-with-scsh"; \
echo "(dump-scsh \"$@\")"; \
) \
| ./$(VM) -i $(IMAGE) -h 10000000
@ -844,9 +854,12 @@ scsh/stripped-scsh.image: $(VM) $(SCHEME) $(IMAGE)
(echo ",flush maps source";\
echo ",translate =scheme48/ `(cd $(srcdir) && echo $$PWD)`/scheme/"; \
echo ",translate $(srcdir)/scsh/machine/ $(srcdir)/scsh/@machine@/"; \
echo ",translate $(srcdir)/scsh/endian.scm `pwd`/scsh/endian.scm"; \
echo ",translate $(srcdir)/scsh/configure.scm `pwd`/scsh/configure.scm"; \
echo ",batch on"; \
echo ",config ,load $(loads)"; \
echo ",open $(opens)"; \
echo ",load-package scheme-with-scsh"; \
echo ",flush"; \
echo "(dump-scsh \"$@\")";) \
| ./$(VM) -i $(IMAGE) -h 10000000
@ -863,22 +876,39 @@ install-scsh: scsh install-scsh-image install-stripped-scsh-image
install-scsh-image: $(VM) scsh/scsh.image
( echo ',translate =scheme48 $(LIB)'; \
echo ",translate $(srcdir)/scsh/machine/ $(srcdir)/scsh/@machine@/"; \
echo ',in lib-dirs (set-default-lib-dirs! (quote $(lib_dirs_list)))'; \
echo '(dump-scsh "$(DESTDIR)$(LIB)/scsh.image")'; \
echo ',exit'; \
) | ./$(VM) -i scsh/scsh.image
) | ./$(VM) -i scsh/scsh.image
install-stripped-scsh-image: $(VM) scsh/stripped-scsh.image
( echo ',translate =scheme48 $(LIB)'; \
echo ",translate $(srcdir)/scsh/machine/ $(srcdir)/scsh/@machine@/"; \
echo ',in lib-dirs (set-default-lib-dirs! (quote $(lib_dirs_list)))'; \
echo '(dump-scsh "$(DESTDIR)$(LIB)/stripped-scsh.image")'; \
echo ',exit'; \
) | ./$(VM) -i scsh/stripped-scsh.image
clean-scsh:
$(RM) scsh/*.o scsh/rx/*.o scsh/*/*.o
$(RM) scsh/*.image
$(RM) scsh/*.o scsh/rx/*.o scsh/*/*.o
$(RM) scsh/*.image
$(RM) scsh/configure.scm
$(RM) $(LIBSCSHVM) $(LIBSCSH) scsh/scsh$(EXEEXT)
$(RM) scsh-config
# rm -rf * && mkdir -p scsh/rx c/unix c/srfi && ~/sw/scsh-HEAD/configure --srcdir=/afs/wsi//home/gasbichl/sw/scsh-HEAD/ && make
# rm -rf * && mkdir -p scsh/rx c/unix c/srfi && ~/sw/scsh-HEAD/configure --srcdir=/afs/wsi//home/gasbichl/sw/scsh-HEAD/ && make=======
scsh/configure.scm: $(srcdir)/scsh/configure.scm.in
sed -e 's|@scsh_host@|$(host)|g' \
-e 's|@scsh_prefix@|$(prefix)|g' \
-e 's|@scsh_exec_prefix@|$(exec_prefix)|g' \
-e 's|@scsh_bindir@|$(bindir)|g' \
-e 's|@scsh_libdir@|$(libdir)|g' \
-e 's|@scsh_includedir@|$(incdir)|g' \
-e 's|@scsh_mandir@|$(mandir)|g' \
-e 's|@scsh_lib_dirs_list@|$(lib_dirs_list)|g' \
-e 's|@scsh_LIBS@|$(LIBS)|g' \
-e 's|@scsh_DEFS@|$(DEFS)|g' \
-e 's|@scsh_CFLAGS@|$(CFLAGS)|g' \
-e 's|@scsh_CPPFLAGS@|$(CPPFLAGS)|g' \
-e 's|@scsh_LDFLAGS@|$(LDFLAGS)|g' $(srcdir)/scsh/configure.scm.in > $@

4
README
View File

@ -3,7 +3,7 @@
Copyright (c) 1994 Brian D. Carlstrom
See file COPYING for copying information.
Please report bugs to scsh-bugs@zurich.ai.mit.edu, and include
Please report bugs to scsh-users@scsh.net, and include
the version number in your message.
Installation instructions in file INSTALL.
@ -12,7 +12,7 @@ A scsh manual is in directory doc/scsh-manual/.
A scsh paper is in directory doc/scsh-paper/.
A scsh quick reference is in file doc/cheat.txt.
Send mail to scsh-request@zurich.ai.mit.edu to be put on a
Send mail to scsh-users-request@scsh.net to be put on a
mailing list for announcements, discussion, bug reports, and bug
fixes.

180
RELEASE
View File

@ -1,12 +1,10 @@
Scsh 0.6.4 Release notes -*- outline -*-
Scsh 0.6.7 Release notes -*- outline -*-
We are pleased to release scsh version 0.6.4. The new version is
mainly a bug-fix release, the only new features are command-line
switches for loading exec scripts and support for some more SRFIs.
We are pleased to release scsh version 0.6.7.
The text below gives a general description of scsh, instructions for obtaining
it, pointers to discussion forums, and a description of the new features in
release 0.6.3. (Emacs should display this document is in outline mode. Say
release 0.6.7. (Emacs should display this document is in outline mode. Say
c-h m for instructions on how to move through it by sections (e.g., c-c c-n,
c-c c-p).)
@ -20,9 +18,9 @@ Obtaining and installing scsh
Getting in touch
The World-Wide What?
New in this release
Switches to load exec scripts
Bug fixes
API changes
New in 0.6.6
New in 0.6.5
New in 0.6.4
New in 0.6.3
New in 0.6.2
New in 0.6.1
@ -105,9 +103,9 @@ Unix platforms. We currently have scsh implementations for:
OpenBSD
Solaris
SunOS
Ultrix
Win32
Darwin/Mac OS X
GNU Hurd
Scsh code should run without change across these systems.
Porting to new platforms is usually not difficult.
@ -140,23 +138,26 @@ about it.
* Getting in touch
==================
There are two main ways to join in scsh-related discussion: the mailing-list
scsh@zurich.ai.mit.edu
and the netnews group
comp.lang.scheme.scsh
These two forums should be equivalent, being bi-directionally gatewayed
at MIT, but due to technical problems it's better to read them both.
Bugs can be reported to
scsh-bugs@zurich.ai.mit.edu
Currently, there is a mailing-list which is mirrored to a newsgroup.
To (un)subscribe to the mailing-list, send a message to
scsh-users-request@scsh.net. To submit a message to the
mailing-list, send it to scsh-users@scsh.net.
The mailing-list is also readable as a standard newsgroup, thanks to
gmane, a mail-to-news gateway. More information is available at the
following URL:
http://gmane.org/info.php?group=gmane.lisp.scheme.scsh
There used to be a newsgroup dedicated to scsh, called
comp.lang.scheme.scsh but it is now deprecated.
Bugs can be reported to the same list
scsh-users@scsh.net
or via the Scsh project's bugs section on SourceForge:
http://sourceforge.net/projects/scsh/
If you do not netnews hierarchy, or wish to join the mailing
list for other reasons, send mail to
scsh-request@zurich.ai.mit.edu
* The World-Wide What?
======================
We even have one of those dot-com cyberweb things:
@ -167,10 +168,145 @@ We manage the project using SourceForge:
* New in this release
=====================
** Support for interix
** Ignoring of synchronous signals
The procedures IGNORE-SIGNAL and HANDLE-SIGNAL-DEFAULT have been
added.
** Support for gcc 4.0
** 0.6 for module path
The standard module path now contains
${prefix}/lib/scsh/modules/0.6 in addition to
$prefix/lib/scsh/modules for compatibility with install-lib
** New implementation of open-pty
Instead of search for /dev/pty??, scsh now tries a wide variety of
ways to aquire a new pty and the corresponding tty.
** Bug fixes
argv[0] is now the first element of command-line
Fixes found by new test suite
Regexp for empty string
Argument checking for COPY-BYTES!
GC_PROTECTs for send_substring
format_date support for #f timezone
Added predicates for user-info and group-info
Reaping of stopped processes: Do not mark stopped processes as dead
md5-digest-for-port
| regexps return char-sets
standard-let in srfi-5
(%)read-delimited! checks for mutable buffer
leap second for srfi-19
The default image for the scshvm is now the installed scsh.image.
* New in 0.6.6
===============
** Removed or replaced non-free code
Some files in the previous versions of scsh did not conform to
scsh's BSD-style license. We therefore removed the directory
scheme/infix and asked the copyright holders of the rest of the
code to put their code under a compatible license. The code of the
sort package has been replaced by a new version (see below).
** New code for sorting
The old package SORT from Scheme 48 has been replaced by a
sophisticated library written by Olin Shivers for the withdrawn
SRFI 32.
** Separate documentation of the library directories search facility
The manual now contains a separate section that describes the
library directories search facility. The description of the
respective switches has been adapted accordingly.
** New module CONFIGURE
The new module CONFIGURE permits access to some of the values
obtained during the run of the configure script.
** Argument processing more robust
Any number of whitespaces may now occur between the arguments to
the VM.
** Ultrix is no longer supported
The Ultrix platform is lacking support for POSIX regular
expressions and is therefore no longer supported.
** Bug fixes
Fix WITH-LOCk
Ensure that the exit value is 1 if scsh exits due to an error
Load the package scheme-with-scsh before dumping images to get
better start-up times
Fix two bugs in GLOB related to quotation
The optmizer AUTO-INTEGRATE can now inline procedures with
macro-generated arguments
The optmizer FLAT-ENVIRONMENTS now works if invoked after AUTO-INTEGRATE
Fixed a bug in the parser of "-" sre forms
Removed accidentally committed expansion of paths in SCSH_LIB_DIR
Fix the various SELECT-like procedures for 0 timeouts
Let PATH-LIST->FILE-NAME return "/" for '("").
Fix bug in S48_RECORD_TYPE: third parameter to s48_stob_ref was missing.
Fixed check for -rdynamic
FIELD-READER returns (values EOF '()) on an empty port
Fixed STRING-CONTAINS and STRING-CONCATENATE-REVERSE/SHARED from SRFI-13
* New in 0.6.5
==============
** New platform: GNU Hurd
Andreas Vögele ported scsh to GNU Hurd.
** ./configure option to set default scsh library directories
The ./configure script now accepts the option --with-lib-dirs-list
to specify a list of default scsh library directories. In
previous versions of scsh this list was hardwired to
/usr/local/lib/scsh/modules.
** Support for DESTDIR for easier packaging
The install target of the Makefile now respects the environment
variable DESTDIR to allow package maintainers to use a staging
directory.
** New SRFI
This release adds support for SRFI 42.
** Switch to load exec scripts from library path
The new switch -lel searches the library path for a file and loads
the file into the exec package.
** Removed scheme/infix/
The directory scheme/infix/ had a non-free copyright licence and
has been removed.
** Bug fixes
- SEEK currently works on unbuffered ports only. Check this in the
implementation and oopsify it in the manual.
- Adjust documentation of some low-level regexp procedures
- Removed message argument form errno-error
- After fork/pipe, make the ports returned by the pipe the
current-in/output-ports
- Get the names of MAKE-STRING-PORT-FILTER and
MAKE-CHAR-PORT-FILTER right in the doc
- Fixed memory leak in scheme_cwd
- Fixed memory leak in format_date
- Avoid calling SOCKET-OPTION twice in case of an error
- Fix for (rx (|)) by Peter Wang
- Fix for (posix-string->regexp "$") by Peter Wang
** API changes
None known.
* New in 0.6.4
==============
** Switches to load exec scripts
The new switch -le loads a file into the exec package, the new
switch -de loads the "-s" script into the exec package.
** New SRFIs
This release adds support for SRFI 25, 26, 27, 28 and 30.
** Bug fixes
- Other select bug
- Timeout for select is in seconds, not milliseconds

7
Thanks
View File

@ -24,4 +24,9 @@ Post-0.5.2-release bug reports:
Alan Bawden
Bengt Kleberg
RT Happe
Dorai Sitaram
Dorai Sitaram
Peter Wang
Stephen Ma
stktrc
Jan Alleman
Taylor Campbell

6
autogen.sh
View File

@ -1,11 +1,11 @@
#! /bin/sh
#! /bin/sh
autoheader &&
autoconf &&
./configure &&
touch scsh/*.c &&
touch build/filenames.scm &&
rm -f scheme48.image cig/cig.image scsh/scsh.image &&
rm -f scheme48.image scsh/scsh.image &&
rm -f build/linker.image build/initial.image &&
rm -f c/scheme48.h &&
make build/filenames.make &&
@ -13,4 +13,4 @@ make i-know-what-i-am-doing &&
make c/scheme48.h&&
make linker &&
make build/initial.image &&
make distclean
make distclean

4
build/build-usual-image
View File

@ -13,7 +13,9 @@ USER=${USER-`logname 2>/dev/null || echo '*GOK*'`}
,load $srcdir/scheme/env/init-defpackage.scm
((*structure-ref filenames 'set-translation!)
"=scheme48/" "$srcdir/scheme/")
,load =scheme48/more-interfaces.scm =scheme48/link-packages.scm
,load =scheme48/more-interfaces.scm
,load =scheme48/sort/interfaces.scm
,load =scheme48/link-packages.scm
,load =scheme48/more-packages.scm
(ensure-loaded command-processor)
(ensure-loaded usual-commands)

BIN
build/initial.image
View File

Binary file not shown.

2
build/minor-version-number
View File

@ -1 +1 @@
6.4
6.7

7
c/init.c
View File

@ -15,8 +15,6 @@ char *s48_object_file; /* specified via a command line argument */
char *s48_reloc_file; /* dynamic loading will set this */
char *prog_name;
void *heap, *stack;
int s48_main (long heap_size, long stack_size,
@ -30,12 +28,12 @@ int s48_main (long heap_size, long stack_size,
}
int
internal_s48_main(long heap_size, long stack_size, char * _prog_name,
internal_s48_main(long heap_size, long stack_size,
char* object_file, char *image_name, int argc, char** argv)
{
long return_value;
long required_heap_size;
int warn_undefined_imported_bindings_p = 1;
int warn_undefined_imported_bindings_p = 0;
#if defined(STATIC_AREAS)
extern long static_entry;
@ -45,7 +43,6 @@ internal_s48_main(long heap_size, long stack_size, char * _prog_name,
extern long i_count, *i_areas[], i_sizes[];
#endif
prog_name = _prog_name;
s48_object_file = object_file;
s48_reloc_file = NULL;

21
c/main.c
View File

@ -24,7 +24,7 @@
/* DEFAULT_IMAGE_NAME should be defined using the -D switch to cc. */
#if !defined(DEFAULT_IMAGE_NAME)
#define DEFAULT_IMAGE_NAME "scheme48.image"
#define DEFAULT_IMAGE_NAME "scsh.image"
#endif
#endif /* STATIC_AREAS */
@ -37,9 +37,9 @@ void process_args(char **argv,
char **object_file,
char **image_name);
extern int
internal_s48_main(long heap_size, long stack_size,
char* prog_name, char* object_file, char* image_name,
extern int
internal_s48_main(long heap_size, long stack_size,
char* object_file, char* image_name,
int argc, char** argv);
int
@ -62,12 +62,13 @@ main(argc, argv)
#endif
long vm_argc = 0;
char *me = *argv; /* Save program name. */
prog_name = *argv++;
prog_name = *argv++;/* Save program name. */
process_args(argv,
&heap_size, &stack_size,
&object_file, &image_name);
process_args(argv,
&heap_size, &stack_size,
&object_file, &image_name);
argv--;
argv[0] = prog_name;
for(argc=0, argp=argv; *argp; argc++, argp++); /* Recompute argc. */
return internal_s48_main(heap_size, stack_size, prog_name, object_file, image_name, argc, argv);
return internal_s48_main(heap_size, stack_size, object_file, image_name, argc, argv);
}

2
c/scheme48.h
View File

@ -457,7 +457,7 @@ extern void s48_check_record_type(s48_value record, s48_value type_binding);
#define S48_RECORD_SET(x, i, v) (s48_stob_set((x), S48_STOBTYPE_RECORD, (i) + 1, (v)))
#define S48_UNSAFE_RECORD_REF(x, i) (S48_STOB_REF((x), (i) + 1))
#define S48_UNSAFE_RECORD_SET(x, i, v) S48_STOB_SET((x), (i) + 1, (v))
#define S48_RECORD_TYPE(x) (s48_stob_ref((x), S48_STOBTYPE_RECORD))
#define S48_RECORD_TYPE(x) (s48_stob_ref((x), S48_STOBTYPE_RECORD, 0))
#define S48_UNSAFE_RECORD_TYPE(x) (STOB_REF((x), 0))
#define S48_BYTE_VECTOR_LENGTH(x) (s48_stob_byte_length((x), S48_STOBTYPE_BYTE_VECTOR))
#define S48_BYTE_VECTOR_REF(x, i) (s48_stob_byte_ref((x), S48_STOBTYPE_BYTE_VECTOR, (i)))

1
c/scheme48heap.c
View File

@ -1,5 +1,6 @@
#include <stdio.h>
#include "prescheme.h"
#include <string.h>
#include "scheme48vm.h"
static long copy_weak_pointer(long, char *, char **);

1
c/scheme48vm-prelude.h
View File

@ -1,5 +1,6 @@
#include <stdlib.h>
#include <stdio.h>
#include <string.h> /* memcpy, strlen */
#include "c-mods.h"
#include "write-barrier.h"

8
c/scheme48vm.c
View File

@ -7217,8 +7217,8 @@ long s48_restart(long proc_361X, long nargs_362X)
arg0K0 = 4;
goto L17320;}
L31929: {
if ((3 == (3 & arg5_743X))) {
if ((17 == (31 & ((((*((long *) ((((char *) (-3 + arg5_743X))) + -4))))>>2))))) {
if ((3 == (3 & arg3_741X))) {
if ((17 == (31 & ((((*((long *) ((((char *) (-3 + arg3_741X))) + -4))))>>2))))) {
goto L31942;}
else {
goto L31937;}}
@ -8334,8 +8334,8 @@ long s48_restart(long proc_361X, long nargs_362X)
else {
goto L31959;}}}}}
L31937: {
if ((3 == (3 & arg5_743X))) {
if ((18 == (31 & ((((*((long *) ((((char *) (-3 + arg5_743X))) + -4))))>>2))))) {
if ((3 == (3 & arg3_741X))) {
if ((18 == (31 & ((((*((long *) ((((char *) (-3 + arg3_741X))) + -4))))>>2))))) {
goto L31942;}
else {
goto L31996;}}

2
c/unix/event.c
View File

@ -1,6 +1,7 @@
/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
See file COPYING. */
#include "sysdep.h"
#include <signal.h> /* for sigaction() (POSIX.1) */
#include <stdlib.h>
#include <unistd.h>
@ -9,7 +10,6 @@
#include <sys/time.h>
#include <sys/times.h>
#include <errno.h> /* for errno, (POSIX?/ANSI) */
#include "sysdep.h"
#include "c-mods.h"
#include "scheme48vm.h"
#include "event.h"

2
c/unix/fd-io.c
View File

@ -1,6 +1,7 @@
/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
See file COPYING. */
#include "sysdep.h"
#include <unistd.h>
#include <stdio.h>
#include <sys/types.h>
@ -8,7 +9,6 @@
#include <fcntl.h>
#include <sys/time.h>
#include <errno.h> /* for errno, (POSIX?/ANSI) */
#include "sysdep.h"
#include "c-mods.h"
#include "scheme48vm.h"
#include "event.h"

38
c/unix/io.c
View File

@ -146,26 +146,6 @@ ps_write_char(char ch, FILE *port)
return 0; }
}
long
ps_write_integer(long n, FILE *port)
{
int status;
static long write_integer(unsigned long n, FILE *port);
if (n == 0) {
WRITE_CHAR('0', port, status);
return status; }
else if (n > 0)
return write_integer(n, port);
else {
WRITE_CHAR('-', port, status);
if (status == 0)
return write_integer(- n, port);
else
return status; }
}
static long
write_integer(unsigned long n, FILE *port)
{
@ -182,6 +162,24 @@ write_integer(unsigned long n, FILE *port)
return status;
}
long
ps_write_integer(long n, FILE *port)
{
int status;
if (n == 0) {
WRITE_CHAR('0', port, status);
return status; }
else if (n > 0)
return write_integer(n, port);
else {
WRITE_CHAR('-', port, status);
if (status == 0)
return write_integer(- n, port);
else
return status; }
}
long
ps_write_string(char *string, FILE *port)
{

1123
config.guess vendored
View File

File diff suppressed because it is too large Load Diff

481
config.sub vendored
View File

@ -1,9 +1,9 @@
#! /bin/sh
# Configuration validation subroutine script.
# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
# Free Software Foundation, Inc.
# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
# 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
timestamp='2001-03-09'
timestamp='2005-07-08'
# This file is (in principle) common to ALL GNU software.
# The presence of a machine in this file suggests that SOME GNU software
@ -21,15 +21,17 @@ timestamp='2001-03-09'
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, USA.
# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA
# 02110-1301, USA.
#
# As a special exception to the GNU General Public License, if you
# distribute this file as part of a program that contains a
# configuration script generated by Autoconf, you may include it under
# the same distribution terms that you use for the rest of that program.
# Please send patches to <config-patches@gnu.org>.
# Please send patches to <config-patches@gnu.org>. Submit a context
# diff and a properly formatted ChangeLog entry.
#
# Configuration subroutine to validate and canonicalize a configuration type.
# Supply the specified configuration type as an argument.
@ -69,7 +71,7 @@ Report bugs and patches to <config-patches@gnu.org>."
version="\
GNU config.sub ($timestamp)
Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005
Free Software Foundation, Inc.
This is free software; see the source for copying conditions. There is NO
@ -82,11 +84,11 @@ Try \`$me --help' for more information."
while test $# -gt 0 ; do
case $1 in
--time-stamp | --time* | -t )
echo "$timestamp" ; exit 0 ;;
echo "$timestamp" ; exit ;;
--version | -v )
echo "$version" ; exit 0 ;;
echo "$version" ; exit ;;
--help | --h* | -h )
echo "$usage"; exit 0 ;;
echo "$usage"; exit ;;
-- ) # Stop option processing
shift; break ;;
- ) # Use stdin as input.
@ -98,7 +100,7 @@ while test $# -gt 0 ; do
*local*)
# First pass through any local machine types.
echo $1
exit 0;;
exit ;;
* )
break ;;
@ -117,7 +119,8 @@ esac
# Here we must recognize all the valid KERNEL-OS combinations.
maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'`
case $maybe_os in
nto-qnx* | linux-gnu* | storm-chaos* | os2-emx*)
nto-qnx* | linux-gnu* | linux-dietlibc | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | \
kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* | storm-chaos* | os2-emx* | rtmk-nova*)
os=-$maybe_os
basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`
;;
@ -143,7 +146,7 @@ case $os in
-convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\
-c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \
-harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \
-apple | -axis)
-apple | -axis | -knuth | -cray)
os=
basic_machine=$1
;;
@ -157,6 +160,14 @@ case $os in
os=-vxworks
basic_machine=$1
;;
-chorusos*)
os=-chorusos
basic_machine=$1
;;
-chorusrdb)
os=-chorusrdb
basic_machine=$1
;;
-hiux*)
os=-hiuxwe2
;;
@ -215,24 +226,57 @@ esac
case $basic_machine in
# Recognize the basic CPU types without company name.
# Some are omitted here because they have special meanings below.
tahoe | i860 | ia64 | m32r | m68k | m68000 | m88k | ns32k | arc \
| arm | arme[lb] | arm[bl]e | armv[2345] | armv[345][lb] | strongarm | xscale \
| pyramid | mn10200 | mn10300 | tron | a29k \
| 580 | i960 | h8300 \
| x86 | ppcbe | mipsbe | mipsle | shbe | shle \
| hppa | hppa1.0 | hppa1.1 | hppa2.0 | hppa2.0w | hppa2.0n \
| hppa64 \
| alpha | alphaev[4-8] | alphaev56 | alphapca5[67] \
| alphaev6[78] \
| we32k | ns16k | clipper | i370 | sh | sh[34] \
| powerpc | powerpcle \
| 1750a | dsp16xx | pdp10 | pdp11 \
| mips16 | mips64 | mipsel | mips64el \
| mips64orion | mips64orionel | mipstx39 | mipstx39el \
| mips64vr4300 | mips64vr4300el | mips64vr4100 | mips64vr4100el \
| mips64vr5000 | miprs64vr5000el | mcore | s390 | s390x \
| sparc | sparclet | sparclite | sparc64 | sparcv9 | v850 | c4x \
| thumb | d10v | d30v | fr30 | avr | openrisc)
1750a | 580 \
| a29k \
| alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \
| alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \
| am33_2.0 \
| arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr \
| bfin \
| c4x | clipper \
| d10v | d30v | dlx | dsp16xx \
| fr30 | frv \
| h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \
| i370 | i860 | i960 | ia64 \
| ip2k | iq2000 \
| m32r | m32rle | m68000 | m68k | m88k | maxq | mcore \
| mips | mipsbe | mipseb | mipsel | mipsle \
| mips16 \
| mips64 | mips64el \
| mips64vr | mips64vrel \
| mips64orion | mips64orionel \
| mips64vr4100 | mips64vr4100el \
| mips64vr4300 | mips64vr4300el \
| mips64vr5000 | mips64vr5000el \
| mips64vr5900 | mips64vr5900el \
| mipsisa32 | mipsisa32el \
| mipsisa32r2 | mipsisa32r2el \
| mipsisa64 | mipsisa64el \
| mipsisa64r2 | mipsisa64r2el \
| mipsisa64sb1 | mipsisa64sb1el \
| mipsisa64sr71k | mipsisa64sr71kel \
| mipstx39 | mipstx39el \
| mn10200 | mn10300 \
| ms1 \
| msp430 \
| ns16k | ns32k \
| or32 \
| pdp10 | pdp11 | pj | pjl \
| powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \
| pyramid \
| sh | sh[1234] | sh[24]a | sh[23]e | sh[34]eb | shbe | shle | sh[1234]le | sh3ele \
| sh64 | sh64le \
| sparc | sparc64 | sparc64b | sparc86x | sparclet | sparclite \
| sparcv8 | sparcv9 | sparcv9b \
| strongarm \
| tahoe | thumb | tic4x | tic80 | tron \
| v850 | v850e \
| we32k \
| x86 | xscale | xscalee[bl] | xstormy16 | xtensa \
| z8k)
basic_machine=$basic_machine-unknown
;;
m32c)
basic_machine=$basic_machine-unknown
;;
m6811 | m68hc11 | m6812 | m68hc12)
@ -240,13 +284,13 @@ case $basic_machine in
basic_machine=$basic_machine-unknown
os=-none
;;
m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | z8k | v70 | h8500 | w65 | pj | pjl)
m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k)
;;
# We use `pc' rather than `unknown'
# because (1) that's what they normally are, and
# (2) the word "unknown" tends to confuse beginning users.
i[234567]86 | x86_64)
i*86 | x86_64)
basic_machine=$basic_machine-pc
;;
# Object if more than one company name word.
@ -255,30 +299,67 @@ case $basic_machine in
exit 1
;;
# Recognize the basic CPU types with company name.
# FIXME: clean up the formatting here.
vax-* | tahoe-* | i[234567]86-* | i860-* | ia64-* | m32r-* | m68k-* | m68000-* \
| m88k-* | sparc-* | ns32k-* | fx80-* | arc-* | c[123]* \
| arm-* | armbe-* | armle-* | armv*-* | strongarm-* | xscale-* \
| mips-* | pyramid-* | tron-* | a29k-* | romp-* | rs6000-* \
| power-* | none-* | 580-* | cray2-* | h8300-* | h8500-* | i960-* \
| xmp-* | ymp-* \
| x86-* | ppcbe-* | mipsbe-* | mipsle-* | shbe-* | shle-* \
| hppa-* | hppa1.0-* | hppa1.1-* | hppa2.0-* | hppa2.0w-* \
| hppa2.0n-* | hppa64-* \
| alpha-* | alphaev[4-8]-* | alphaev56-* | alphapca5[67]-* \
| alphaev6[78]-* \
| we32k-* | cydra-* | ns16k-* | pn-* | np1-* | xps100-* \
| clipper-* | orion-* \
| sparclite-* | pdp10-* | pdp11-* | sh-* | powerpc-* | powerpcle-* \
| sparc64-* | sparcv9-* | sparc86x-* | mips16-* | mips64-* | mipsel-* \
| mips64el-* | mips64orion-* | mips64orionel-* \
| mips64vr4100-* | mips64vr4100el-* | mips64vr4300-* | mips64vr4300el-* \
| mipstx39-* | mipstx39el-* | mcore-* \
| f30[01]-* | f700-* | s390-* | s390x-* | sv1-* | t3e-* \
| [cjt]90-* \
| m88110-* | m680[01234]0-* | m683?2-* | m68360-* | z8k-* | d10v-* \
| thumb-* | v850-* | d30v-* | tic30-* | c30-* | fr30-* \
| bs2000-* | tic54x-* | c54x-* | x86_64-*)
580-* \
| a29k-* \
| alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \
| alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \
| alphapca5[67]-* | alpha64pca5[67]-* | arc-* \
| arm-* | armbe-* | armle-* | armeb-* | armv*-* \
| avr-* \
| bfin-* | bs2000-* \
| c[123]* | c30-* | [cjt]90-* | c4x-* | c54x-* | c55x-* | c6x-* \
| clipper-* | craynv-* | cydra-* \
| d10v-* | d30v-* | dlx-* \
| elxsi-* \
| f30[01]-* | f700-* | fr30-* | frv-* | fx80-* \
| h8300-* | h8500-* \
| hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \
| i*86-* | i860-* | i960-* | ia64-* \
| ip2k-* | iq2000-* \
| m32r-* | m32rle-* \
| m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \
| m88110-* | m88k-* | maxq-* | mcore-* \
| mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \
| mips16-* \
| mips64-* | mips64el-* \
| mips64vr-* | mips64vrel-* \
| mips64orion-* | mips64orionel-* \
| mips64vr4100-* | mips64vr4100el-* \
| mips64vr4300-* | mips64vr4300el-* \
| mips64vr5000-* | mips64vr5000el-* \
| mips64vr5900-* | mips64vr5900el-* \
| mipsisa32-* | mipsisa32el-* \
| mipsisa32r2-* | mipsisa32r2el-* \
| mipsisa64-* | mipsisa64el-* \
| mipsisa64r2-* | mipsisa64r2el-* \
| mipsisa64sb1-* | mipsisa64sb1el-* \
| mipsisa64sr71k-* | mipsisa64sr71kel-* \
| mipstx39-* | mipstx39el-* \
| mmix-* \
| ms1-* \
| msp430-* \
| none-* | np1-* | ns16k-* | ns32k-* \
| orion-* \
| pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \
| powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \
| pyramid-* \
| romp-* | rs6000-* \
| sh-* | sh[1234]-* | sh[24]a-* | sh[23]e-* | sh[34]eb-* | shbe-* \
| shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \
| sparc-* | sparc64-* | sparc64b-* | sparc86x-* | sparclet-* \
| sparclite-* \
| sparcv8-* | sparcv9-* | sparcv9b-* | strongarm-* | sv1-* | sx?-* \
| tahoe-* | thumb-* \
| tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \
| tron-* \
| v850-* | v850e-* | vax-* \
| we32k-* \
| x86-* | x86_64-* | xps100-* | xscale-* | xscalee[bl]-* \
| xstormy16-* | xtensa-* \
| ymp-* \
| z8k-*)
;;
m32c-*)
;;
# Recognize the various machine names and aliases which stand
# for a CPU type and a company and sometimes even an OS.
@ -296,6 +377,9 @@ case $basic_machine in
basic_machine=a29k-amd
os=-udi
;;
abacus)
basic_machine=abacus-unknown
;;
adobe68k)
basic_machine=m68010-adobe
os=-scout
@ -310,6 +394,12 @@ case $basic_machine in
basic_machine=a29k-none
os=-bsd
;;
amd64)
basic_machine=x86_64-pc
;;
amd64-*)
basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
amdahl)
basic_machine=580-amdahl
os=-sysv
@ -341,6 +431,10 @@ case $basic_machine in
basic_machine=ns32k-sequent
os=-dynix
;;
c90)
basic_machine=c90-cray
os=-unicos
;;
convex-c1)
basic_machine=c1-convex
os=-bsd
@ -361,30 +455,45 @@ case $basic_machine in
basic_machine=c38-convex
os=-bsd
;;
cray | ymp)
basic_machine=ymp-cray
cray | j90)
basic_machine=j90-cray
os=-unicos
;;
cray2)
basic_machine=cray2-cray
os=-unicos
craynv)
basic_machine=craynv-cray
os=-unicosmp
;;
[cjt]90)
basic_machine=${basic_machine}-cray
os=-unicos
cr16c)
basic_machine=cr16c-unknown
os=-elf
;;
crds | unos)
basic_machine=m68k-crds
;;
crisv32 | crisv32-* | etraxfs*)
basic_machine=crisv32-axis
;;
cris | cris-* | etrax*)
basic_machine=cris-axis
;;
crx)
basic_machine=crx-unknown
os=-elf
;;
da30 | da30-*)
basic_machine=m68k-da30
;;
decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn)
basic_machine=mips-dec
;;
decsystem10* | dec10*)
basic_machine=pdp10-dec
os=-tops10
;;
decsystem20* | dec20*)
basic_machine=pdp10-dec
os=-tops20
;;
delta | 3300 | motorola-3300 | motorola-delta \
| 3300-motorola | delta-motorola)
basic_machine=m68k-motorola
@ -393,6 +502,10 @@ case $basic_machine in
basic_machine=m88k-motorola
os=-sysv3
;;
djgpp)
basic_machine=i586-pc
os=-msdosdjgpp
;;
dpx20 | dpx20-*)
basic_machine=rs6000-bull
os=-bosx
@ -505,19 +618,19 @@ case $basic_machine in
basic_machine=i370-ibm
;;
# I'm not sure what "Sysv32" means. Should this be sysv3.2?
i[34567]86v32)
i*86v32)
basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
os=-sysv32
;;
i[34567]86v4*)
i*86v4*)
basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
os=-sysv4
;;
i[34567]86v)
i*86v)
basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
os=-sysv
;;
i[34567]86sol2)
i*86sol2)
basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
os=-solaris2
;;
@ -565,28 +678,20 @@ case $basic_machine in
basic_machine=m68k-atari
os=-mint
;;
mipsel*-linux*)
basic_machine=mipsel-unknown
os=-linux-gnu
;;
mips*-linux*)
basic_machine=mips-unknown
os=-linux-gnu
;;
mips3*-*)
basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`
;;
mips3*)
basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown
;;
mmix*)
basic_machine=mmix-knuth
os=-mmixware
;;
monitor)
basic_machine=m68k-rom68k
os=-coff
;;
morphos)
basic_machine=powerpc-unknown
os=-morphos
;;
msdos)
basic_machine=i386-pc
os=-msdos
@ -666,6 +771,13 @@ case $basic_machine in
basic_machine=hppa1.1-oki
os=-proelf
;;
openrisc | openrisc-*)
basic_machine=or32-unknown
;;
os400)
basic_machine=powerpc-ibm
os=-os400
;;
OSE68000 | ose68000)
basic_machine=m68000-ericsson
os=-ose
@ -688,42 +800,58 @@ case $basic_machine in
pbb)
basic_machine=m68k-tti
;;
pc532 | pc532-*)
pc532 | pc532-*)
basic_machine=ns32k-pc532
;;
pentium | p5 | k5 | k6 | nexgen)
pentium | p5 | k5 | k6 | nexgen | viac3)
basic_machine=i586-pc
;;
pentiumpro | p6 | 6x86 | athlon)
pentiumpro | p6 | 6x86 | athlon | athlon_*)
basic_machine=i686-pc
;;
pentiumii | pentium2)
pentiumii | pentium2 | pentiumiii | pentium3)
basic_machine=i686-pc
;;
pentium-* | p5-* | k5-* | k6-* | nexgen-*)
pentium4)
basic_machine=i786-pc
;;
pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*)
basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
pentiumpro-* | p6-* | 6x86-* | athlon-*)
basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
pentiumii-* | pentium2-*)
pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*)
basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
pentium4-*)
basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
pn)
basic_machine=pn-gould
;;
power) basic_machine=power-ibm
;;
ppc) basic_machine=powerpc-unknown
;;
;;
ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
ppcle | powerpclittle | ppc-le | powerpc-little)
basic_machine=powerpcle-unknown
;;
;;
ppcle-* | powerpclittle-*)
basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
ppc64) basic_machine=powerpc64-unknown
;;
ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
ppc64le | powerpc64little | ppc64-le | powerpc64-little)
basic_machine=powerpc64le-unknown
;;
ppc64le-* | powerpc64little-*)
basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
ps2)
basic_machine=i386-ibm
;;
@ -741,10 +869,26 @@ case $basic_machine in
rtpc | rtpc-*)
basic_machine=romp-ibm
;;
s390 | s390-*)
basic_machine=s390-ibm
;;
s390x | s390x-*)
basic_machine=s390x-ibm
;;
sa29200)
basic_machine=a29k-amd
os=-udi
;;
sb1)
basic_machine=mipsisa64sb1-unknown
;;
sb1el)
basic_machine=mipsisa64sb1el-unknown
;;
sei)
basic_machine=mips-sei
os=-seiux
;;
sequent)
basic_machine=i386-sequent
;;
@ -752,7 +896,10 @@ case $basic_machine in
basic_machine=sh-hitachi
os=-hms
;;
sparclite-wrs)
sh64)
basic_machine=sh64-unknown
;;
sparclite-wrs | simso-wrs)
basic_machine=sparclite-wrs
os=-vxworks
;;
@ -819,22 +966,42 @@ case $basic_machine in
os=-dynix
;;
t3e)
basic_machine=t3e-cray
basic_machine=alphaev5-cray
os=-unicos
;;
t90)
basic_machine=t90-cray
os=-unicos
;;
tic54x | c54x*)
basic_machine=tic54x-unknown
os=-coff
;;
tic55x | c55x*)
basic_machine=tic55x-unknown
os=-coff
;;
tic6x | c6x*)
basic_machine=tic6x-unknown
os=-coff
;;
tx39)
basic_machine=mipstx39-unknown
;;
tx39el)
basic_machine=mipstx39el-unknown
;;
toad1)
basic_machine=pdp10-xkl
os=-tops20
;;
tower | tower-32)
basic_machine=m68k-ncr
;;
tpf)
basic_machine=s390x-ibm
os=-tpf
;;
udi29k)
basic_machine=a29k-amd
os=-udi
@ -856,8 +1023,8 @@ case $basic_machine in
os=-vms
;;
vpp*|vx|vx-*)
basic_machine=f301-fujitsu
;;
basic_machine=f301-fujitsu
;;
vxworks960)
basic_machine=i960-wrs
os=-vxworks
@ -878,13 +1045,17 @@ case $basic_machine in
basic_machine=hppa1.1-winbond
os=-proelf
;;
xmp)
basic_machine=xmp-cray
os=-unicos
xbox)
basic_machine=i686-pc
os=-mingw32
;;
xps | xps100)
xps | xps100)
basic_machine=xps100-honeywell
;;
ymp)
basic_machine=ymp-cray
os=-unicos
;;
z8k-*-coff)
basic_machine=z8k-unknown
os=-sim
@ -905,16 +1076,12 @@ case $basic_machine in
op60c)
basic_machine=hppa1.1-oki
;;
mips)
if [ x$os = x-linux-gnu ]; then
basic_machine=mips-unknown
else
basic_machine=mips-mips
fi
;;
romp)
basic_machine=romp-ibm
;;
mmix)
basic_machine=mmix-knuth
;;
rs6000)
basic_machine=rs6000-ibm
;;
@ -931,13 +1098,13 @@ case $basic_machine in
we32k)
basic_machine=we32k-att
;;
sh3 | sh4)
sh[1234] | sh[24]a | sh[34]eb | sh[1234]le | sh[23]ele)
basic_machine=sh-unknown
;;
sparc | sparcv9)
sparc | sparcv8 | sparcv9 | sparcv9b)
basic_machine=sparc-sun
;;
cydra)
cydra)
basic_machine=cydra-cydrome
;;
orion)
@ -952,9 +1119,8 @@ case $basic_machine in
pmac | pmac-mpw)
basic_machine=powerpc-apple
;;
c4x*)
basic_machine=c4x-none
os=-coff
*-unknown)
# Make sure to match an already-canonicalized machine name.
;;
*)
echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
@ -1008,36 +1174,47 @@ case $os in
| -aos* \
| -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \
| -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \
| -hiux* | -386bsd* | -netbsd* | -openbsd* | -freebsd* | -riscix* \
| -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \
| -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* | -openbsd* \
| -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \
| -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \
| -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \
| -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \
| -chorusos* | -chorusrdb* \
| -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \
| -mingw32* | -linux-gnu* | -uxpv* | -beos* | -mpeix* | -udk* \
| -interix* | -uwin* | -rhapsody* | -darwin* | -opened* \
| -mingw32* | -linux-gnu* | -linux-uclibc* | -uxpv* | -beos* | -mpeix* | -udk* \
| -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \
| -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \
| -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* | -os2*)
| -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \
| -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \
| -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \
| -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \
| -skyos* | -haiku*)
# Remember, each alternative MUST END IN *, to match a version number.
;;
-qnx*)
case $basic_machine in
x86-* | i[34567]86-*)
x86-* | i*86-*)
;;
*)
os=-nto$os
;;
esac
;;
-nto-qnx*)
;;
-nto*)
os=-nto-qnx
os=`echo $os | sed -e 's|nto|nto-qnx|'`
;;
-sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \
| -windows* | -osx | -abug | -netware* | -os9* | -beos* \
| -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \
| -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*)
;;
-mac*)
os=`echo $os | sed -e 's|mac|macos|'`
;;
-linux-dietlibc)
os=-linux-dietlibc
;;
-linux*)
os=`echo $os | sed -e 's|linux|linux-gnu|'`
;;
@ -1050,6 +1227,9 @@ case $os in
-opened*)
os=-openedition
;;
-os400*)
os=-os400
;;
-wince*)
os=-wince
;;
@ -1068,14 +1248,23 @@ case $os in
-acis*)
os=-aos
;;
-atheos*)
os=-atheos
;;
-syllable*)
os=-syllable
;;
-386bsd)
os=-bsd
;;
-ctix* | -uts*)
os=-sysv
;;
-nova*)
os=-rtmk-nova
;;
-ns2 )
os=-nextstep2
os=-nextstep2
;;
-nsk*)
os=-nsk
@ -1087,6 +1276,9 @@ case $os in
-sinix*)
os=-sysv4
;;
-tpf*)
os=-tpf
;;
-triton*)
os=-sysv3
;;
@ -1114,8 +1306,17 @@ case $os in
-xenix)
os=-xenix
;;
-*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*)
os=-mint
-*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*)
os=-mint
;;
-aros*)
os=-aros
;;
-kaos*)
os=-kaos
;;
-zvmoe)
os=-zvmoe
;;
-none)
;;
@ -1148,10 +1349,14 @@ case $basic_machine in
arm*-semi)
os=-aout
;;
c4x-* | tic4x-*)
os=-coff
;;
# This must come before the *-dec entry.
pdp10-*)
os=-tops20
;;
pdp11-*)
pdp11-*)
os=-none
;;
*-dec | vax-*)
@ -1178,6 +1383,9 @@ case $basic_machine in
mips*-*)
os=-elf
;;
or32-*)
os=-coff
;;
*-tti) # must be before sparc entry or we get the wrong os.
os=-sysv3
;;
@ -1187,9 +1395,15 @@ case $basic_machine in
*-be)
os=-beos
;;
*-haiku)
os=-haiku
;;
*-ibm)
os=-aix
;;
*-knuth)
os=-mmixware
;;
*-wec)
os=-proelf
;;
@ -1241,19 +1455,19 @@ case $basic_machine in
*-next)
os=-nextstep3
;;
*-gould)
*-gould)
os=-sysv
;;
*-highlevel)
*-highlevel)
os=-bsd
;;
*-encore)
os=-bsd
;;
*-sgi)
*-sgi)
os=-irix
;;
*-siemens)
*-siemens)
os=-sysv4
;;
*-masscomp)
@ -1322,10 +1536,16 @@ case $basic_machine in
-mvs* | -opened*)
vendor=ibm
;;
-os400*)
vendor=ibm
;;
-ptx*)
vendor=sequent
;;
-vxsim* | -vxworks*)
-tpf*)
vendor=ibm
;;
-vxsim* | -vxworks* | -windiss*)
vendor=wrs
;;
-aux*)
@ -1340,13 +1560,16 @@ case $basic_machine in
-*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*)
vendor=atari
;;
-vos*)
vendor=stratus
;;
esac
basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"`
;;
esac
echo $basic_machine$os
exit 0
exit
# Local variables:
# eval: (add-hook 'write-file-hooks 'time-stamp)

161
configure.in
View File

@ -33,10 +33,39 @@ dnl Note, on some Sun's, you can link with -rdynamic but the resulting
dnl a.out always core dumps.
define(S48_RDYNAMIC, [dnl
AC_MSG_CHECKING([link with -rdynamic])
AC_TRY_COMPILE([],
[#if defined(__linux__) && defined(__ELF__)
this must not compile
#endif],
AC_RUN_IFELSE(AC_LANG_PROGRAM([
#include <stdio.h>
#include <dlfcn.h>
int export_test = 0;],
[
#ifndef RTLD_LAZY
#define RTLD_LAZY 0
#endif
#ifndef RTLD_GLOBAL
#define RTLD_GLOBAL 0
#endif
void *dlhandle;
void *intp;
char *err;
dlhandle = dlopen(NULL, RTLD_LAZY | RTLD_GLOBAL);
if ((err = dlerror()) != NULL) {
return 1;
}
(void *)intp = dlsym(dlhandle, "export_test");
if ((err = dlerror()) != NULL) {
return 1;
}
return 0;
]),
[AC_MSG_RESULT(no)],
[AC_MSG_RESULT(yes)
LDFLAGS="$LDFLAGS -rdynamic"])
@ -59,7 +88,7 @@ dnl -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
AC_DEFUN(SCSH_TZNAME,[
AC_MSG_CHECKING(for tzname)
AC_CACHE_VAL(scsh_cv_tzname,[
AC_TRY_COMPILE([#include <time.h>],
AC_TRY_COMPILE([#include <time.h>],
[return (int) tzname;],
scsh_cv_tzname=yes,
scsh_cv_tzname=no)])
@ -80,14 +109,11 @@ AC_DEFUN(SCSH_ELF, [
scsh_cv_elf=no
fi])
AC_MSG_RESULT($scsh_cv_elf)
if test $scsh_cv_elf = yes; then
LDFLAGS=-rdynamic
fi
rm -f conftest.c a.out
])
dnl -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
AC_DEFUN(SCSH_SIG_NRS, [
AC_MSG_RESULT([defining signal constants])
AC_MSG_RESULT([defining signal constants])
mkdir -p scsh
${CC} -o scsh_aux $srcdir/scsh/scsh_aux.c
AC_DEFINE_UNQUOTED(SIGNR_1, `./scsh_aux 1`, [scsh interrupt for signal 1])
@ -121,7 +147,7 @@ AC_DEFUN(SCSH_SIG_NRS, [
AC_DEFINE_UNQUOTED(SIGNR_29, `./scsh_aux 29`, [scsh interrupt for signal 29])
AC_DEFINE_UNQUOTED(SIGNR_30, `./scsh_aux 30`, [scsh interrupt for signal 30])
AC_DEFINE_UNQUOTED(SIGNR_31, `./scsh_aux 31`, [scsh interrupt for signal 31])
rm -f scsh_aux scsh_aux.exe
rm -f scsh_aux scsh_aux.exe
])
dnl -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
AC_DEFUN(SCSH_LINUX_STATIC_DEBUG, [
@ -146,7 +172,7 @@ AC_DEFUN(SCSH_CONST_SYS_ERRLIST,[
AC_MSG_CHECKING(for const sys_errlist)
AC_CACHE_VAL(scsh_cv_const_sys_errlist,[
AC_TRY_COMPILE([#include <errno.h>
#include <unistd.h>],
#include <unistd.h>],
[const extern char *sys_errlist[];],
scsh_cv_const_sys_errlist=yes,
scsh_cv_const_sys_errlist=no)])
@ -172,13 +198,22 @@ AC_DEFUN(SCSH_SOCKLEN_T,[
AC_DEFINE(socklen_t,int)])])
])
dnl -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
define(SCSH_CREATE_BUILD_DIRS, [dnl
mkdir -p cig
mkdir -p scsh/machine
mkdir -p scsh/rx
mkdir -p c/srfi
mkdir -p c/unix
])dnl
dnl -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
AC_INIT(c/scheme48vm.c)
AC_CONFIG_HEADER(c/sysdep.h)
SCSH_CREATE_BUILD_DIRS
AC_CANONICAL_HOST
S48_PROG_CC
SCSH_SIG_NRS
AC_ISC_POSIX
SCSH_LINUX_STATIC_DEBUG
SCSH_LINUX_STATIC_DEBUG
dnl set the cross-compile flag before we try anything.
AC_TRY_RUN([int main() { return 0;}], [], [], [true])
AC_PROG_INSTALL
@ -203,13 +238,10 @@ AC_INIT(c/scheme48vm.c)
LDFLAGS="-O -Wl,-Bexport"
AC_DEFINE(HAVE_HARRIS, 1, [Define to 1 on m88k-harris-cxux])
;;
## DEC Ultrix
mips-dec-ultrix* )
machine=ultrix
if test ${CC} = cc; then
LDFLAGS=-N
fi
AC_MSG_ERROR("Ultrix is not supported.")
;;
## HP 9000 series 700 and 800, running HP/UX
@ -223,7 +255,7 @@ AC_INIT(c/scheme48vm.c)
AC_DEFINE(hpux, 1, [Define to 1 on HP/UX])
AC_DEFINE(_XOPEN_SOURCE_EXTENDED, 1, [Define to 1 to compile on HP/UX])
;;
## IBM AIX
rs6000-ibm-aix*|powerpc-ibm-aix* )
machine=aix
@ -257,7 +289,7 @@ AC_INIT(c/scheme48vm.c)
CC="$CC -posix"
AC_DEFINE(HAVE_SIGACTION)
;;
## SGI IRIX
mips-sgi-irix* )
machine=irix
@ -269,20 +301,20 @@ AC_INIT(c/scheme48vm.c)
sparc*-sun-sunos* )
machine=sunos
;;
## Solaris - Sparc and i386
*-*-solaris* )
machine=solaris
AC_DEFINE(HAVE_NLIST)
;;
## NT - cygwin32
*-*-cygwin* )
AC_DEFINE(CYGWIN, 1, [Define to 1 on cygwin])
machine=cygwin32
EXEEXT=".exe"
;;
## The GNU Hurd
*-*-gnu* )
machine=gnu
@ -315,28 +347,30 @@ esac
AC_RETSIGTYPE
AC_CHECK_HEADERS(libgen.h sys/timeb.h posix/time.h sys/select.h nlist.h)
AC_CHECK_HEADERS(sys/un.h)
AC_CHECK_HEADERS(crypt.h)
AC_CHECK_HEADERS(crypt.h)
AC_CHECK_FUNCS(gettimeofday ftime nlist select setitimer sigaction vasprintf)
SCSH_SOCKLEN_T
AC_CHECK_FUNC(dlopen, [AC_DEFINE(HAVE_DLOPEN,
1, [Define to 1 if the interface to the dynamic linker exists])],
SCSH_SOCKLEN_T
AC_CHECK_FUNC(dlopen, [AC_DEFINE(HAVE_DLOPEN,
1, [Define to 1 if the interface to the dynamic linker exists])
have_dlopen="yes"],
[AC_CHECK_FUNC(nlist, [AC_LIBOBJ([c/fake/libdl1])],
[AC_LIBOBJ([c/fake/libdl2])])])
[AC_LIBOBJ([c/fake/libdl2])])
have_dlopen="no"])
AC_CHECK_FUNCS(socket chroot)
AC_CHECK_FUNC(strerror, AC_DEFINE(HAVE_STRERROR,
AC_CHECK_FUNC(strerror, AC_DEFINE(HAVE_STRERROR,
1, [Define to 1 if you have the strerror function]),
[AC_LIBOBJ([c/fake/strerror])])
AC_CHECK_FUNC(seteuid, [AC_DEFINE(HAVE_SETEUID,
AC_CHECK_FUNC(seteuid, [AC_DEFINE(HAVE_SETEUID,
1, [Define to 1 if you have the seteuid function])],
[AC_CHECK_FUNC(setreuid, [AC_DEFINE(HAVE_SETREUID,
[AC_CHECK_FUNC(setreuid, [AC_DEFINE(HAVE_SETREUID,
1, [Define to 1 if you have the setreuid function])],
[AC_MSG_ERROR("Neither setegid nor setregid defined. Cannot continue.")])])
AC_CHECK_FUNC(setegid, [AC_DEFINE(HAVE_SETEGID,
AC_CHECK_FUNC(setegid, [AC_DEFINE(HAVE_SETEGID,
1, [Define to 1 if you have the setegid function])],
[AC_CHECK_FUNC(setregid, [AC_DEFINE(HAVE_SETREGID,
1, [Define to 1 if you have the setregid function])],
[AC_CHECK_FUNC(setregid, [AC_DEFINE(HAVE_SETREGID,
1, [Define to 1 if you have the setregid function])],
[AC_MSG_ERROR("Neither setegid nor setregid defined. Cannot continue.")])])
@ -356,17 +390,68 @@ fail
AC_MSG_RESULT([yes]),
AC_MSG_RESULT([no]))
S48_USCORE
S48_RDYNAMIC
if test $have_dlopen = yes; then
S48_RDYNAMIC
fi
AC_STRUCT_TIMEZONE
AC_CHECK_MEMBER(struct tm.tm_gmtoff,
AC_DEFINE(HAVE_GMTOFF, 1, [Define to 1 if struct tm has member tm_gmtoff]))
SCSH_CONST_SYS_ERRLIST
dnl ----------------------------------------------------------------
dnl Check for pty support
dnl ----------------------------------------------------------------
dnl There is no "standard" pty allocation method. Every system is different.
dnl getpt() is the preferred pty allocation method on glibc systems.
dnl _getpty() is the preferred pty allocation method on SGI systems.
dnl grantpt(), unlockpt(), ptsname() are defined by Unix98.
AC_CHECK_FUNCS(getpt _getpty grantpt unlockpt ptsname killpg tcgetpgrp)
dnl openpty() is the preferred pty allocation method on BSD and Tru64 systems.
dnl openpty() might be declared in:
dnl - pty.h (Tru64 or Linux)
dnl - libutil.h (FreeBSD)
dnl - util.h (NetBSD)
AC_CHECK_FUNC(openpty, have_openpty=yes, [
AC_CHECK_LIB(util, openpty, have_openpty=yes need_libutil=yes)])
if test "$have_openpty" = "yes"; then
AC_DEFINE(HAVE_OPENPTY, 1, [Define to 1 if you have the 'openpty' function])
AC_CHECK_HEADERS(libutil.h util.h, break)
if test "$need_libutil" = "yes"; then
LIBS="${LIBS} -lutil"
fi
fi
dnl Check for system-specific pty header files
dnl Often the TIOCSIG* symbols are hiding there.
case "$opsys" in
dnl HPUX pty.h #defines TRUE and FALSE, so just use ptyio.h there.
hpux*) AC_CHECK_HEADERS(sys/ptyio.h) ;;
*) AC_CHECK_HEADERS(pty.h)
test "$ac_cv_header_pty_h" = "no" && AC_CHECK_HEADERS(sys/pty.h)
;;
esac
dnl Check for System V STREAM support functions.
AC_CHECK_HEADERS(stropts.h)
AC_CHECK_FUNCS(isastream)
SCSH_CONST_SYS_ERRLIST
CFLAGS1=${CFLAGS}
lib_dirs_list='("${prefix}/lib/scsh/modules" "${prefix}/lib/scsh/modules/0.6")'
AC_ARG_WITH(lib-dirs-list,
AC_HELP_STRING([--with-lib-dirs-list],
[list of default scsh library directories (default ("$prefix/lib/scsh/modules" "${prefix}/lib/scsh/modules/0.6"))]),
lib_dirs_list="$withval")
AC_SUBST(lib_dirs_list)
AC_SUBST(CFLAGS)
AC_SUBST(LDFLAGS)
AC_SUBST(AIX_P)
AC_SUBST(AR)
@ -380,7 +465,7 @@ fail
AC_SUBST(LIBS)
AC_SUBST(TMPDIR)
AC_SUBST(machine)
AC_CONFIG_FILES(Makefile scsh-config)
AC_CONFIG_COMMANDS([scsh-config+x],[chmod +x scsh-config])
AC_OUTPUT

4
doc/scsh-manual/front.tex
View File

@ -1,9 +1,9 @@
%&latex -*- latex -*-
\title{Scsh Reference Manual}
\subtitle{For scsh release 0.6.4}
\subtitle{For scsh release 0.6.7}
\author{Olin Shivers, Brian D.~Carlstrom, Martin Gasbichler, and Mike Sperber}
\date{April 2003}
\date{May 2006}
\maketitle
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

8
doc/scsh-manual/man.tex
View File

@ -13,7 +13,7 @@
\input{pdfcond}
\ifpdf
\usepackage[pdftex,hyperindex,
pdftitle={scsh manual, release 0.6.4},
pdftitle={scsh manual, release 0.6.7},
pdfauthor={Olin Shivers, Brian D.~Carlstrom, Martin Gasbichler,
and Mike Sperber}
colorlinks=true,linkcolor=blue,pagecolor=blue,urlcolor=blue,
@ -22,11 +22,7 @@
\usepackage{tocbibind}
\else
\usepackage[dvipdfm,hyperindex,hypertex,
pdftitle={scsh manual, release 0.6.4},
pdfauthor={Olin Shivers, Brian D.~Carlstrom, Martin Gasbichler,
and Mike Sperber}
colorlinks=true,linkcolor=blue,pagecolor=blue,urlcolor=blue,
pdfstartview=FitH,pdfview=FitH]{hyperref}
colorlinks=true,linkcolor=blue,pagecolor=blue,urlcolor=blue]{hyperref}
\fi
\endtexonly

59
doc/scsh-manual/miscprocs.tex
View File

@ -392,6 +392,65 @@ C library written by Colin Plum.
the digest.
\end{desc}
\section{Configuration variables}
\label{sec:configure}
This section describes procedures to access the configuration
parameters used to compile scsh and flags needed to build C extensions
for scsh.
\defun{host}{}{string}
\defunx{machine}{}{string}
\defunx{vendor}{}{string}
\defunx{os}{}{string}
\begin{desc}
These procedures return the description of the host, scsh was built
on, as determined by the script \texttt{config.guess}.
\end{desc}
%
\defun{prefix}{}{string}
\defunx{exec-prefix}{}{string}
\defunx{bin-dir}{}{string}
\defunx{lib-dir}{}{string}
\defunx{include-dir}{}{string}
\defunx{man-dir}{}{string}
\begin{desc}
These procedures return the various directories of
the scsh installation.
\end{desc}
%
\defun{lib-dirs-list}{}{symbol list}
\begin{desc}
Returns the default list of library directories. See
Section~\ref{sec:scsh-switches} for more information about the
library search facility.
\end{desc}
%
\defun{libs}{}{string}
\defunx{defs}{}{string}
\defunx{cflags}{}{string}
\defunx{cppflags}{}{string}
\defunx{ldflags}{}{string}
\begin{desc}
The values returned by these procedures correspond to the values
\texttt{make} used to compile scsh's C files.
\end{desc}
%
\defunx{compiler-flags}{}{string}
\begin{desc}
The procedure \var{compiler-flags} returns flags suitable for
running the C compiler when compiling a C file that uses scsh's
foreign function interface.
\end{desc}
\defun{linker-flags}{}{string}
\begin{desc}
Scsh also comes as a library that can be linked into other programs.
The procedure \var{linker-flags} returns the appropriate flags to
link the scsh library to another program.
\end{desc}
%%% Local Variables:
%%% mode: latex
%%% TeX-master: "man"

8
doc/scsh-manual/rdelim.tex
View File

@ -72,8 +72,8 @@ See section~\ref{sec:char-sets} for information on character set manipulation.
The \var{handle-delim} parameter determines how the terminating character
is handled. It is described above, and defaults to \ex{'trim}.
The \var{char-set} argument may be a charset, a string, a character, or a
character predicate; it is coerced to a charset.
The \var{char-set} argument may be a charset, a string, or a
character; it is coerced to a charset.
\end{desc}
\dfni{read-delimited!} {char-set buf [port handle-delim start end]}
@ -143,8 +143,8 @@ the procedure call.
\begin{defundesc} {skip-char-set} {skip-chars [port]} {\integer}
Skip characters occurring in the set \var{skip-chars};
return the number of characters skipped.
The \var{skip-chars} argument may be a charset, a string, a character, or a
character predicate; it is coerced to a charset.
The \var{skip-chars} argument may be a charset, a string, or a
character; it is coerced to a charset.
\end{defundesc}
%%% Local Variables:

176
doc/scsh-manual/running.tex
View File

@ -176,9 +176,111 @@ For programs which should run in versions of scsh prior to release
0.6.3, programmers should make sure to always put the \ex{scsh}
reference first.
\subsection{Library directories search facility}
\label{sec:lib-dirs}
Scsh's command line switches allow loading of code not present in the
script file or the heap image at startup. To relief the user from
specifying full path names and to improve flexibility, scsh offers the
library directories path list. This list contains directories in which
scsh searches automatically for a file name argument of the
\texttt{-ll} or \texttt{-le} switch.
This section describes the programmatic interface to the library
directories search facility. In addition, various command line
switches for scsh modify the library directories path list. Section
\ref{sec:scsh-switches} describes these switches and the switches to
actually load files.
Another way to change the library directories path list is the
environment variable \texttt{\$SCSH\_LIB\_DIRS}. If this variable is
set, scsh uses it to set library directories path list. The value of
this environment variable is treated as a sequence of s-expressions,
which are ``read'' from the string:
\begin{itemize}
\item A string is treated as a directory,
\item \sharpf{} is replaced with the default list of directories.
\end{itemize}
A \texttt{\$SCSH\_LIB\_DIRS} assignment of this form
\begin{small}
\begin{verbatim}
SCSH_LIB_DIRS='"." "/usr/contrib/lib/scsh/" #f "/home/shivers/lib/scsh"'
\end{verbatim}
\end{small}
would produce this list of strings for the
\textit{library-directories} list:
%
\begin{verbatim}
("." "/usr/contrib/lib/scsh/"
"/usr/local/lib/scsh/modules/"
"/home/shivers/lib/scsh")
\end{verbatim}
%
It is a startup error if reading the \texttt{\$SCSH\_LIB\_DIRS}
environment variable causes a read error, or produces a value that
isn't a list of strings or \sharpf.
\defvar{default-lib-dirs}{string list}
\begin{desc}
The default list of \textit{library directories}. The original value
of this variable is \verb+("$prefix/lib/scsh/modules/")+. %$ but
starting with version 0.6.5 the option \verb+--with-lib-dirs-list+ of
the \texttt{configure} script changes for a new installation.
\end{desc}
\defun{find-library-file}{file lib-dirs script-file}{\undefined}
\begin{desc}
Searches the list of library directories \var{lib-dirs} for
\var{file} and returns the full path. The variable \var{script-file}
is used to resolve references to the directory of the current
script.
When searching for a directory containing a given library module,
nonexistent or read-protected directories are silently ignored; it
is not an error to have them in the \textit{library-directories}
list.
Directory search can be recursive. A directory name that ends with a
slash is recursively searched.
\end{desc}
\defun{lib-dirs}{}{string list}
\begin{desc}
Returns the current library directories path list.
\end{desc}
\defun{lib-dirs-prepend-script-dir!}{}{\undefined}
\defunx{lib-dirs-append-script-dir!}{}{\undefined}
\begin{desc}
Add the directory of the current script file to the beginning or end
of the \textit{library-directories} path list, respectively.
\end{desc}
\defun{lib-dirs-append!}{dir}{\undefined}
\defunx{lib-dirs-prepend!}{dir}{\undefined}
\begin{desc}
Add directory \var{lib-dir} to the beginning or end of the
\textit{library-directories} path list, respectively.
\end{desc}
\defun{clear-lib-dirs!}{}{\undefined}
\begin{desc}
Set the \textit{library-directories} path list to the empty list.
\end{desc}
\defun{reset-lib-dirs!}{}{\undefined}
\begin{desc}
Set the \textit{library-directories} path list to system default,
i.e. to the value of \var{default-lib-dirs}.
\end{desc}
\subsection{Switches}
\label{sec:scsh-switches}
The scsh top-level takes command-line switches in the following format:
The scsh top-level takes command-line switches in the following
format:
%
\codex{scsh [\var{meta-arg}] [\vari{switch}i {\ldots}]
[\var{end-option} \vari{arg}1 {\ldots} \vari{arg}n]}
@ -214,6 +316,8 @@ where
& \ex{-ll} \var{module-file-name}
& As in -lm, but search the library path list.\\
& \ex{-lel} \var{exec-file-name}
& As in -le, but search the library path list.\\
& \ex{+lp} \var{dir}
& Add dir to front of library path list.\\
& \ex{lp+} \var{dir}
@ -406,70 +510,50 @@ The following switches and end options are defined:
{\scm} exec language.
\Item{-ll \var{module-file-name}}
Load library module into config package.
This is just like the \ex{-lm} switch, except that it searches the
library-directory path list for the file to load.
library-directory path list (see Section \ref{sec:lib-dirs})
for the file to load.
Specifically, it means: search through the
\textit{library-directories} list of directories looking for a
module file of the given name, and load it in.
The \textit{library-directories} list defaults to
\texttt{("/usr/local/lib/scsh/modules/")}. It will be
installation-dependent in a later version of scsh.
If the environment variable \texttt{\$SCSH\_LIB\_DIRS} is set, it is
used to determine the library search path. The value of this
environment variable is treated as a sequence of s-expressions, which
are ``read'' from the string:
\begin{itemize}
\item A string is treated as a directory,
\item \sharpf{} is replaced with the default list of directories.
\end{itemize}
module file of the given name, and load it in. Scsh uses the
procedure \var{find-library-file} from Section \ref{sec:lib-dirs}
to perform the search.
A \texttt{\$SCSH\_LIB\_DIRS} assignment of this form
\begin{small}
\begin{verbatim}
SCSH_LIB_DIRS='"." "/usr/contrib/lib/scsh/" #f "/home/shivers/lib/scsh"'
\end{verbatim}
\end{small}
would produce this list of strings for the
\textit{library-directories} list:
\begin{verbatim}
("." "/usr/contrib/lib/scsh/"
"/usr/local/lib/scsh/modules/"
"/home/shivers/lib/scsh")
\end{verbatim}
When searching for a directory containing a given library module,
nonexistent or read-protected directories are silently ignored; it
is not an error to have them in the \textit{library-directories}
list.
It is a startup error if reading the \texttt{\$SCSH\_LIB\_DIRS}
environment variable causes a read error, or produces a value that
isn't a list of strings or \sharpf.
Directory search can be recursive. A directory name that ends
with a slash is recursively searched.
\Item{-lel \var{exec-file-name}}
As above, but load the specified file into scsh's exec package.
This is just like the \ex{-le} switch, except that it searches the
library-directory path list for the file to load.
\Item{+lp \var{lib-dir},lp+ \var{lib-dir}}
Add directory \var{lib-dir} to the beginning or end of the
\textit{library-directories} path list, respectively.
\var{lib-dir} is a single directory. It is not split at colons or
otherwise processed.
otherwise processed. These switches correspond to the procedures
\ex{lib-dirs-prepend!} and \ex{lib-dirs-append!} from Section
\ref{sec:lib-dirs}.
\Item{+lpe, lpe+}
As above, except that \~ home-directory syntax and environment
variables are expanded out.
\Item{+lpsd,lpsd+}
Add script-file's directory to the beginning or end of the
\textit{library-directories} path list, respectively. These switches
correspond to the procedures
\ex{lib-dirs-prepend-script-dir!} and \ex{lib-dirs-append-script-dir!} from Section
\ref{sec:lib-dirs}.
\Item{-lp-clear, -lp-default}
Set the \textit{library-directories} path list to the empty list and
the system default, respectively.
the system default, respectively. These switches correspond to
the procedures \ex{clear-lib-dirs!} and \ex{reset-lib-dirs!} from Section
\ref{sec:lib-dirs}.
These two switches are useful if you would like to protect your
The two switches are useful if you would like to protect your
script from influence by the \texttt{\$SCSH\_LIB\_DIRS} variable.
In these cases, the \texttt{\$SCSH\_LIB\_DIRS} environment variable is never

13
doc/scsh-manual/sre.tex
View File

@ -290,7 +290,8 @@ set brackets are \ex{("} and \ex{")}.
\paragraph{Wild card}
Another simple SRE is the symbol \ex{any},
which matches any single character---including newline and \textsc{Ascii} nul.
which matches any single character---including newline, but excluding
ASCII NUL.
\paragraph{Sequences}
@ -313,7 +314,7 @@ A Common Lisp embedding of SREs, for example, would need to use
\ex{seq} instead of \ex{:}.}
\section{Choices}
\paragraph{Choices}
The SRE \ex{(| \var{sre} \ldots)} is a regexp that matches anything any of the
\var{sre} regexps match. So the regular expression
@ -1212,7 +1213,7 @@ readable format.
\end{desc}
\defun {posix-string->regexp}{string}{re}
\defunx{regexp->posix-string}{re}{string}
\defunx{regexp->posix-string}{re}{[string syntax-level paren-count submatches-vector]}
\begin{desc}
These two functions are the Posix notation parser and unparser.
That is, \ex{posix-string->regexp} maps a Posix-notation regular
@ -1249,14 +1250,14 @@ The \ex{\ldots:tsm} accessor returns the total number of submatches
contained in the regular expression.
\dfn {re-seq?}{x}{boolean}{Type predicate}
\dfnx{make-re-seq}{re \ldots}{re}{Basic constructor}
\dfnx{re-seq}{re \ldots}{re}{Smart constructor}
\dfnx{make-re-seq}{re-list}{re}{Basic constructor}
\dfnx{re-seq}{re-list}{re}{Smart constructor}
\dfnx{re-seq:elts}{re}{re-list}{Accessor}
\dfnx{re-seq:tsm}{re}{integer}{Accessor}
\dfn {re-choice?}{x}{boolean}{Type predicate}
\dfnx{make-re-choice}{re-list}{re}{Basic constructor}
\dfnx{re-choice}{re \ldots}{re}{Smart constructor}
\dfnx{re-choice}{re-list}{re}{Smart constructor}
\dfnx{re-choice:elts}{re}{re-list}{Accessor}
\dfnx{re-choice:tsm}{re}{integer}{Accessor}

53
doc/scsh-manual/syscalls.tex
View File

@ -572,6 +572,7 @@ this is dependent on the OS implementation.
The return value is the resulting position of the I/O cursor in the I/O stream.
\oops{The current implementation doesn't handle \var{offset} arguments
that are not immediate integers (\ie, representable in 30 bits).}
\oops{The current implementation doesn't handle buffered ports.}
\end{desc}
@ -1694,7 +1695,7 @@ delimiter.
allocated when the file is opened. This will work if the file
only needs to be opened once.
\item If the file needs to be opened twice or more, create it in a
protected directory, \eg, \verb|$HOME|.
protected directory, \eg, \verb|$HOME|.%$
\item Ensure that \ex{/var/tmp} has its sticky bit set. This
requires system administrator privileges.
\end{enumerate}
@ -1823,7 +1824,7 @@ The path-searching variants search the directories in the list
A path-search is not performed if the program name contains
a slash character---it is used directly. So a program with a name like
\ex{"bin/prog"} always executes the program \ex{bin/prog} in the current working
directory. See \verb|$path| and \verb|exec-path-list|, below.
directory. See \verb|$path| and \verb|exec-path-list|, below.%$
Note that there is no analog to the C function \ex{\urlh{http://www.FreeBSD.org/cgi/man.cgi?query=execv&apropos=0&sektion=0&manpath=FreeBSD+4.3-RELEASE&format=html}{execv()}}.
To get the effect just do
@ -1880,7 +1881,7 @@ it with \ex{\%exec}, the file's status might change.
The only atomic way to do the search is to loop over the candidate
file names, exec'ing each one and looping when the exec operation fails.
See \cd{$path} and \ex{exec-path-list}, below.
See \cd{$path} and \ex{exec-path-list}, below.%$
\end{desc}
\defun {exit} {[status]} \noreturn
@ -2564,11 +2565,9 @@ or integer process ids.
\begin{desc}
Schedules a timer interrupt in \var{secs} seconds.
\end{desc}
\begin{note}
As the thread system needs the timer interrupt for its own purpose,
\note{As the thread system needs the timer interrupt for its own purpose,
\ex{itimer} works by spawning a thread which calls the interrupt
handler for \ex{interrupt/alrm} after the specified time.
\end{note}
handler for \ex{interrupt/alrm} after the specified time.}
\defun{process-sleep}{secs} \undefined
\defunx{process-sleep-until}{time}\undefined
@ -2584,6 +2583,7 @@ or integer process ids.
\end{desc}
\subsubsection{Interrupt handlers}
\label{sec:int_handlers}
Scsh interrupt handlers are complicated by the fact that scsh is implemented on
top of the {\scm} virtual machine, which has its own interrupt system,
independent of the Unix signal system.
@ -2591,7 +2591,7 @@ This means that {\Unix} signals are delivered in two stages: first,
{\Unix} delivers the signal to the {\scm} virtual machine, then
the {\scm} virtual machine delivers the signal to the executing Scheme program
as a {\scm} interrupt.
This ensures that signal delivery happens between two vm instructions,
This ensures that signal delivery happens between two VM instructions,
keeping individual instructions atomic.
The {\scm} machine has its own set of interrupts, which includes the
@ -2670,17 +2670,11 @@ Unix signal & Type & OS Variant \\ \hline\hline
here.}
\label{table:uncatchable-signals}
\end{table}
Note that scsh does \emph{not} support signal handlers for
``synchronous'' {\Unix} signals, such as \ex{signal/ill} or
\ex{signal/pipe} (see table~\ref{table:uncatchable-signals}).
Synchronous occurrences of these signals are better handled by raising
a Scheme exception. We recommend you avoid using signal handlers
unless you absolutely have to; Section \ref{sec:event-interf-interr}
describes a better interface to signals.
\begin{defundesc}{signal->interrupt}{\integer}{\integer}
The programmer maps from {\Unix} signals to {\scm} interrupts with the
\ex{signal->interrupt} procedure.
If the signal does not have a defined {\scm} interrupt, an errror is signaled.
If the signal does not have a defined {\scm} interrupt, an error is signaled.
\end{defundesc}
@ -2722,6 +2716,7 @@ the \ex{interrupt-set} function).
\end{desc}
\begin{defundesc}{set-interrupt-handler}{interrupt handler}{old-handler}
Assigns a handler for a given interrupt,
and returns the interrupt's old handler.
@ -2741,6 +2736,10 @@ handler, see \ex{set-enabled-interrupts})
\note{If you set a handler for the \ex{interrupt/chld} interrupt,
you may break scsh's autoreaping process machinery. See the
discussion of autoreaping in section~\ref{sec:proc-objects}.}
\note{We recommend you avoid using interrupt handlers unless you absolutely
have to; Section \ref{sec:event-interf-interr} describes a better
interface to handling signals.}
\end{defundesc}
\begin{defundesc}{interrupt-handler}{interrupt}{handler}
@ -2750,6 +2749,28 @@ A handler is either \ex{\#f} (ignore), \ex{\#t} (default), or a
procedure taking an integer argument.
\end{defundesc}
Note that scsh does \emph{not} support interrupt handlers for
``synchronous'' {\Unix} signals, such as \ex{signal/ill} or
\ex{signal/pipe} (see table~\ref{table:uncatchable-signals}).
Synchronous occurrences of these signals are better handled by raising
a Scheme exception. There are, however, some rare situtations where it
is necessary to ignore the occurrence of a synchronous signal. For
this case, the following procedures exist:
\defun{ignore-signal}{\integer}{\undefined}
\defunx{handle-signal-default}{\integer}{\undefined}
\begin{desc}
The procedure \ex{ignore-signal} tells the process to ignore the
given signal. The procedure \ex{handle-signal-default} resets the
signal handler to the default handler.
These procedures manipulate the raw signal handler of the scsh
process and therfore undermine the signal handling facility of the
VM. They are intended to be used for igoring synchronous signals if
system calls cannot succeed otherwise. Do not use these procedures
for asynchronous signals!
\end{desc}
% %set-unix-signal-handler
% %unix-signal-handler

14
doc/scsh-manual/threads.tex
View File

@ -191,6 +191,15 @@ variable \texttt{state} by USR1 and USR2:
(set! state #t)
(lp next))))
\end{code}
\textbf{Warning:} The current version of scsh also defines
asynchronous handlers for interrupts (See Section
\ref{sec:int_handlers}). The default action of some of these handlers
is to terminate the process in which case you will most likely not see
an effect of the synchronous event interface described here. It is
therefore recommended to disable the corresponding interrupt handler
using \texttt{(set-interrupt-handler interrupt \#f)}.
\section{Interaction between threads and process state}
\label{sec:ps_interac}
@ -239,4 +248,7 @@ Therefore they remain global process state: If a thread changes one of
these values, all other threads see the new value. Consequently, scsh
does not provide \texttt{with-uid} and friends.
%%% Local Variables:
%%% mode: latex
%%% TeX-master: "man"
%%% End:

5
emacs/cmulisp.el
View File

@ -1,9 +1,6 @@
;;; -*-Emacs-Lisp-*- cmulisp.el
;;; Copyright Olin Shivers (1988).
;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
;;; notice appearing here to the effect that you may use this code any
;;; way you like, as long as you don't charge money for it, remove this
;;; notice, or hold me liable for its results.
;;; See file COPYING
;;; This replaces the standard inferior-lisp mode.
;;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88

5
emacs/cmuscheme.el
View File

@ -1,9 +1,6 @@
;;; cmuscheme.el -- Scheme process in a buffer. Adapted from tea.el.
;;; Copyright Olin Shivers (1988)
;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
;;; notice appearing here to the effect that you may use this code any
;;; way you like, as long as you don't charge money for it, remove this
;;; notice, or hold me liable for its results.
;;; See file COPYING
;;;
;;; This is a customisation of comint-mode (see comint.el)
;;;

5
emacs/cmushell.el
View File

@ -1,9 +1,6 @@
;;; -*-Emacs-Lisp-*- General command interpreter in a window stuff
;;; Copyright Olin Shivers (1988).
;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
;;; notice appearing here to the effect that you may use this code any
;;; way you like, as long as you don't charge money for it, remove this
;;; notice, or hold me liable for its results.
;;; See file COPYING
;;; The changelog is at the end of file.

5
emacs/comint.el
View File

@ -1,9 +1,6 @@
;;; -*-Emacs-Lisp-*- General command interpreter in a window stuff
;;; Copyright Olin Shivers (1988).
;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
;;; notice appearing here to the effect that you may use this code any
;;; way you like, as long as you don't charge money for it, remove this
;;; notice, or hold me liable for its results.
;;; See file COPYING
;;; The changelog is at the end of this file.

3
ps-compiler/compile-gc.scm
View File

@ -13,6 +13,7 @@
"../scheme/vm/gc-package-defs.scm")
's48-heap-init
"../scheme/vm/scheme48heap.c"
'(header "#include \"scheme48vm.h\"")
'(header "#include <string.h>")
'(header "#include \"scheme48vm.h\"")
;'(copy (heap walk-over-type-in-area))
'(integrate (real-copy-object s48-trace-locations!)))))

4
scheme/bcomp/comp-prim.scm
View File

@ -74,9 +74,9 @@
(exact?
,(proc (number-type) boolean-type))
(exact->inexact
,(proc (exact-type) inexact-type))
,(proc (number-type) inexact-type))
(inexact->exact
,(proc (inexact-type) exact-type))
,(proc (number-type) exact-type))
((exp log sin cos tan asin acos sqrt)
,(proc (number-type) number-type))
((atan)

151
scheme/big/sort.scm
View File

@ -1,151 +0,0 @@
;;; Copyright (c) 1985 Yale University
;;; Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
;;; This material was developed by the T Project at the Yale
;;; University Computer Science Department. Permission to copy this
;;; software, to redistribute it, and to use it for any purpose is
;;; granted, subject to the following restric- tions 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 the T Project at Yale any improvements or extensions that they make,
;;; so that these may be included in future releases; and (b) to inform
;;; the T Project of noteworthy uses of this software.
;;; 3. All materials developed as a consequence of the use of this software
;;; shall duly acknowledge such use, in accordance with the usual standards
;;; of acknowledging credit in academic research.
;;; 4. Yale has made no warrantee or representation that the operation of
;;; this software will be error-free, and Yale is under no obligation to
;;; provide any services, by way of maintenance, update, or otherwise.
;;; 5. In conjunction with products arising from the use of this material,
;;; there shall be no use of the name of the Yale University nor of any
;;; adaptation thereof in any advertising, promotional, or sales literature
;;; without prior written consent from Yale in each case.
;;;
;;; We gratefully acknowledge Bob Nix
;;; SORT:ONLINE-MERGE-SORT!
;;; =======================
;;; On-Line Merge sort, a fast and stable algorithm for sorting a list.
;;; This is a very neat algorithm! Consider the following code:
;;;
;;; (DEFINE (MERGE-SORT L)
;;; (IF (NULL? (CDR L))
;;; L
;;; (MERGE (MERGE-SORT (FIRST-HALF-OF L))
;;; (MERGE-SORT (SECOND-HALF-OF L)))))
;;;
;;; The nested calls to MERGE above form a binary tree, with MERGE's of
;;; singleton lists at the leaves, and a MERGE of two lists of size N/2 at
;;; the top. The algorithm below traverses this MERGE-tree in post-order,
;;; moving from the lower left hand corner to the right.
;;;
;;; This algorithm sorts N objects with about NlgN+2N comparisons and exactly
;;; lgN conses. The algorithm used is a version of mergesort that is
;;; amenable to Lisp's data accessing primitives. The first phase of the
;;; algorithm is an "addition" phase in which each element X is added to
;;; a list of lists of sorted runs B in much the same manner as a one is
;;; added to a binary number. If the first "digit" of B is 0, i.e. the first
;;; list in B is NIL, then the element to be added becomes the first digit
;;; of B. If that digit is non empty then you merge the digit with X and
;;; recurse on the rest of B -- setting the first digit of B to be zero.
;;; For example:
;;;
;;; Reversed LIST B
;;; Binary # Each sublist is sorted.
;;;
;;; 0000 ()
;;; 1000 ((x))
;;; 0100 (() (x x))
;;; 1100 ((x) (x x))
;;; 0010 (() () (x x x x))
;;; 1010 ((x) () (x x x x))
;;; 0110 (() (x x) (x x x x))
;;; 1110 ((x) (x x) (x x x x))
;;; 0001 (() () () (x x x x x x x x))
;;; 1001 ((x) () () (x x x x x x x x))
;;;
;;; The algorithm then merges the sublists of these lists into
;;; one list, and returns that list.
;;;
;;; To see the algorithm in action, trace LIST-MERGE!.
;;;
;;; Returns list L sorted using OBJ-< for comparisons.
(define (sort-list l obj-<)
(cond ((or (null? l)
(null? (cdr l)))
l)
(else
(online-merge-sort! (append l '()) ; copy-list
obj-<))))
;;; Returns list L sorted using OBJ-< for comparisons.
;;; L is destructively altered.
(define (sort-list! l obj-<)
(cond ((or (null? l)
(null? (cdr l)))
l)
(else
(online-merge-sort! l obj-<))))
;;; The real sort procedure. Elements of L are added to B, a list of sorted
;;; lists as defined above. When all elements of L have been added to B
;;; the sublists of B are merged together to get the desired sorted list.
(define (online-merge-sort! l obj-<)
(let ((b (cons '() '())))
(let loop ((l l))
(cond ((null? l)
(do ((c (cddr b) (cdr c))
(r (cadr b) (list-merge! (car c) r obj-<)))
((null? c)
r)))
(else
(let ((new-l (cdr l)))
(set-cdr! l '())
(add-to-sorted-lists l b obj-<)
(loop new-l)))))))
;;; X is a list that is merged into B, the list of sorted lists.
(define (add-to-sorted-lists x b obj-<)
(let loop ((x x) (b b))
(let ((l (cdr b)))
(cond ((null? l)
(set-cdr! b (cons x '())))
((null? (car l))
(set-car! l x))
(else
(let ((y (list-merge! x (car l) obj-<)))
(set-car! l '())
(loop y l)))))))
;;; Does a stable side-effecting merge of L1 and L2.
(define (list-merge! l1 l2 obj-<)
(cond ((null? l1) l2)
((null? l2) l1)
((obj-< (car l1) (car l2))
(real-list-merge! l2 (cdr l1) obj-< l1)
l1)
(else
(real-list-merge! l1 (cdr l2) obj-< l2)
l2)))
;;; Does the real work of LIST-MERGE!. L1 is assumed to be non-empty.
(define (real-list-merge! l1 l2 obj-< prev)
(let loop ((a l1) (b l2) (prev prev))
(cond ((null? b)
(set-cdr! prev a))
((obj-< (car a) (car b))
(set-cdr! prev a)
(loop b (cdr a) a))
(else
(set-cdr! prev b)
(loop a (cdr b) b)))))

29
scheme/infix/packages.scm
View File

@ -1,29 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Infix stuff
(define-structure tokenizer (export make-tokenizer-table
set-up-usual-tokenization!
set-char-tokenization!
tokenize)
(open scheme records signals defpackage ascii)
(access primitives)
(files tokenize))
(define-structure pratt (export toplevel-parse
parse
make-operator
make-lexer-table set-char-tokenization!
lexer-ttab define-keyword define-punctuation
prsmatch comma-operator delim-error erb-error
if-operator
then-operator else-operator parse-prefix
parse-nary parse-infix
parse-matchfix end-of-input-operator
port->stream)
(open scheme records signals tokenizer tables)
(files pratt))
(define-structure sgol (export sgol-read sgol-repl)
(open scheme signals pratt)
(files sgol))

308
scheme/infix/pratt.scm
View File

@ -1,308 +0,0 @@
; -*- Mode: Scheme; -*-
;
; A simple Pratt-Parser for SIOD: 2-FEB-90, George Carrette, GJC@PARADIGM.COM
; Siod may be obtained by anonymous FTP to world.std.com:pub/gjc.
;
; * COPYRIGHT (c) 1988-1994 BY *
; * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. *
; * ALL RIGHTS RESERVED *
;
;Permission to use, copy, modify, distribute and sell this software
;and its documentation for any purpose and without fee is hereby
;granted, provided that the above copyright notice appear in all copies
;and that both that copyright notice and this permission notice appear
;in supporting documentation, and that the name of Paradigm Associates
;Inc not be used in advertising or publicity pertaining to distribution
;of the software without specific, written prior permission.
;
;PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
;PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
;ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
;SOFTWARE.
;
; Based on a theory of parsing presented in:
;
; Pratt, Vaughan R., ``Top Down Operator Precedence,''
; ACM Symposium on Principles of Programming Languages
; Boston, MA; October, 1973.
;
; The following terms may be useful in deciphering this code:
; NUD -- NUll left Denotation (op has nothing to its left (prefix))
; LED -- LEft Denotation (op has something to left (postfix or infix))
; LBP -- Left Binding Power (the stickiness to the left)
; RBP -- Right Binding Power (the stickiness to the right)
;
; Mods for Scheme 48 by J Rees 6-14-90
; From: <gjc@mitech.com>
;
; Now a neat thing that CGOL had was a way of packaging and scoping
; different parsing contexts. The maclisp implementation was simple,
; instead of just NUD and LED and other properties there was a list
; of property indicators. And a lookup operation.
;
; One use of the local-context thing, in parsing the C language
; you can use a different binding-power for ":" depending on
; what kind of statement you are parsing, a general statement
; context where ":" means a label, a "switch" or the "if for value
; " construct of (a > b) > c : d;
(define (peek-token stream)
(stream 'peek #f))
(define (read-token stream)
(stream 'get #f))
(define (toplevel-parse stream)
(if (eq? end-of-input-operator (peek-token stream))
(read-token stream)
(parse -1 stream)))
; A token is either an operator or atomic (number, identifier, etc.)
(define operator-type
(make-record-type 'operator
'(name lbp rbp nud led)))
(define make-operator
(let ()
(define make
(record-constructor operator-type '(name lbp rbp nud led)))
(define (make-operator name lbp rbp nud led)
(make name
(or lbp default-lbp)
(or rbp default-rbp)
(or nud default-nud)
(or led default-led)))
make-operator))
(define operator? (record-predicate operator-type))
(define operator-name (record-accessor operator-type 'name))
(define operator-nud (record-accessor operator-type 'nud))
(define operator-led (record-accessor operator-type 'led))
(define operator-lbp (record-accessor operator-type 'lbp))
(define operator-rbp (record-accessor operator-type 'rbp))
(define (default-nud operator stream)
(if (eq? (operator-led operator) default-led)
operator
(error 'not-a-prefix-operator operator)))
(define (nudcall token stream)
(if (operator? token)
((operator-nud token) token stream)
token))
(define default-led #f)
;+++ To do: fix this to make juxtaposition work (f x+y)
(define (ledcall token left stream)
((or (and (operator? token)
(operator-led token))
(error 'not-an-infix-operator token))
token
left
stream))
(define default-lbp 200)
(define (lbp token)
(if (operator? token)
(operator-lbp token)
default-lbp))
(define default-rbp 200)
(define (rbp token)
(if (operator? token)
(operator-rbp token)
default-rbp))
(define-record-discloser operator-type
(lambda (obj)
(list 'operator (operator-name obj))))
; Mumble
(define (delim-error token stream)
(error 'invalid-use-of-delimiter token))
(define (erb-error token left stream)
(error 'too-many-right-parentheses token))
(define (premterm-err token stream)
(error 'premature-termination-of-input token))
; Parse
(define *parse-debug* #f)
(define (parse rbp-level stream)
(if *parse-debug* (print `(parse ,rbp-level)))
(let parse-loop ((translation (nudcall (read-token stream) stream)))
(if (< rbp-level (lbp (peek-token stream)))
(parse-loop (ledcall (read-token stream) translation stream))
(begin (if *parse-debug* (print translation))
translation))))
(define (print s) (write s) (newline))
(define (parse-prefix operator stream)
(list (operator-name operator)
(parse (rbp operator) stream)))
(define (parse-infix operator left stream)
(list (operator-name operator)
left
(parse (rbp operator) stream)))
(define (parse-nary operator left stream)
(cons (operator-name operator) (cons left (prsnary operator stream))))
(define (prsnary operator stream)
(define (loop l)
(if (eq? operator (peek-token stream))
(begin (read-token stream)
(loop (cons (parse (rbp operator) stream) l)))
(reverse l)))
(loop (list (parse (rbp operator) stream))))
; Parenthesis matching, with internal commas.
; Kind of a kludge if you ask me.
(define (parse-matchfix operator stream) ; |x|
(cons (operator-name operator)
(prsmatch operator stream)))
(define (prsmatch close-op stream)
(if (eq? (peek-token stream) close-op)
(begin (read-token stream)
'())
(let loop ((l (list (parse 10 stream))))
(if (eq? (peek-token stream) close-op)
(begin (read-token stream)
(reverse l))
(if (eq? (peek-token stream) comma-operator)
(begin (read-token stream)
(loop (cons (parse 10 stream) l)))
(error 'comma-or-match-not-found (read-token stream)))))))
(define comma-operator (make-operator 'comma 10 #f delim-error #f))
; if A then B [else C]
(define (if-nud token stream)
(let* ((pred (parse (rbp token) stream))
(then (if (eq? (peek-token stream) then-operator)
(parse (rbp (read-token stream)) stream)
(error 'missing-then pred))))
(if (eq? (peek-token stream) else-operator)
`(if ,pred ,then ,(parse (rbp (read-token stream)) stream))
`(if ,pred ,then))))
(define if-operator (make-operator 'if #f 45 if-nud #f))
(define then-operator (make-operator 'then 5 25 delim-error #f))
(define else-operator (make-operator 'else 5 25 delim-error #f))
; Lexer support:
(define lexer-type
(make-record-type 'lexer '(ttab punctab keytab)))
(define lexer-ttab (record-accessor lexer-type 'ttab))
(define lexer-punctab (record-accessor lexer-type 'punctab))
(define lexer-keytab (record-accessor lexer-type 'keytab))
(define make-lexer-table
(let ((make (record-constructor lexer-type '(ttab punctab keytab))))
(lambda ()
(let ((ttab (make-tokenizer-table)))
(set-up-usual-tokenization! ttab)
(make ttab (make-table) (make-table))))))
(define (lex ltab port)
(let ((thing (tokenize (lexer-ttab ltab) port)))
(cond ((eof-object? thing)
end-of-input-operator)
((symbol? thing)
(or (table-ref (lexer-keytab ltab) thing)
thing))
(else thing))))
; Keywords
(define (define-keyword ltab name op)
(table-set! (lexer-keytab ltab) name op))
; Punctuation
; lexnode = (* operator (table-of char (+ lexnode #f))) -- discrimination tree
(define (define-punctuation ltab string op)
(let ((end (- (string-length string) 1)))
(let loop ((i 0)
(table (lexer-punctab ltab)))
(let* ((c (string-ref string i))
(lexnode
(or (table-ref table c)
(let ((lexnode
(cons (error-operator (substring string 0 (+ i 1)))
(make-table))))
(table-set! table c lexnode)
(if (= i 0)
(set-char-tokenization! (lexer-ttab ltab)
c
(operator-reader lexnode)
#t))
lexnode))))
(if (>= i end)
(set-car! lexnode op)
(loop (+ i 1) (cdr lexnode)))))))
(define (operator-reader lexnode)
(lambda (c port)
(let loop ((lexnode lexnode))
(let ((nextc (peek-char port)))
(let ((nextnode (table-ref (cdr lexnode) nextc)))
(if nextnode
(begin (read-char port)
(loop nextnode))
(car lexnode)))))))
(define (error-operator string)
(make-operator 'invalid-operator #f #f
(lambda rest (error "invalid operator" string))
#f))
; Mumble
(define end-of-input-operator
(make-operator "end of input" -1 #f premterm-err #f))
(define (port->stream port ltab)
(define (really-get)
(lex ltab port))
(define peeked? #f)
(define peek #f)
(define (stream op arg)
(case op
((get) (if peeked?
(begin (set! peeked? #f) peek)
(really-get)))
((peek) (if peeked?
peek
(begin (set! peeked? #t)
(set! peek (really-get))
peek)))))
stream)

11
scheme/infix/sgol-runtime.scm
View File

@ -1,11 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
(define (%unspecific)
(if #f #f))
(define (!= x y)
(not (= x y)))
(define (%tuple . rest)
(list->vector (cons 'tuple rest)))

213
scheme/infix/sgol.scm
View File

@ -1,213 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Lexer for Infix Scheme (JAR's obscure syntax)
; Bears no relation to Pratt's CGOL
; To do: add ML-ish binding constructs.
; (sgol-read) reads an expression
;
; semicolon terminates input
; comment character is # (comment goes to end of line)
;
; f(x, y) reads as (f x y)
;
; if x then y else z reads as (if x y z)
; x and y, x or y, not x do the obvious thing
;
; x + y reads as (+ x y) - similarly for - * / = < > <= >=
;
; x::y reads as (cons x y) - ML's syntax
; x++y reads as (append x y) - whose syntax? Haskell's?
; [] reads as '()
; [a, b, ...] reads as (list a b ...)
;
; () reads as the-unit
; (x, y, ...) reads as (tuple x y ...)
;
; a[i] reads as (vector-ref a i)
; a[i, j, ...] reads as (array-ref a i j ...)
;
; x := y reads as (set! x y)
; car(x) := y reads as (set-car! x y) - similarly for cdr
; x[y] := z reads as (vector-set! x y z) - similarly for array-ref
;
; 'foo' tries to read as 'foo but usually loses
(define sgol-lexer-table (make-lexer-table))
(set-char-tokenization! (lexer-ttab sgol-lexer-table)
#\#
(lambda (c port)
c ;ignored
(gobble-line port)
(read port))
#t)
(define (gobble-line port)
(let loop ()
(let ((c (read-char port)))
(cond ((eof-object? c) c)
((char=? c #\newline) #f)
(else (loop))))))
;
(define (define-sgol-keyword name op)
(define-keyword sgol-lexer-table name op))
(define (define-sgol-punctuation string op)
(define-punctuation sgol-lexer-table string op))
; Arguments to make-operator are: name lbp rbp nud led
(define (open-paren-nud token stream)
(let ((right (prsmatch close-paren-operator stream)))
(if (null? right)
'the-unit ; ()
(if (null? (cdr right))
(car right) ; (x)
(cons 'tuple right))))) ; (x, y, ..., z)
; f(x, y) reads as (f x y)
; f((x, y)) reads as (f (tuple x y))
(define (open-paren-led token left stream)
(cons left (prsmatch close-paren-operator stream)))
(define-sgol-punctuation "("
(make-operator 'open-paren 200 #f open-paren-nud open-paren-led))
(define-sgol-punctuation "," comma-operator)
(define close-paren-operator
(make-operator 'close-paren 5 #f delim-error erb-error))
(define-sgol-punctuation ")" close-paren-operator)
; Boolean operators
(define-sgol-keyword 'true '#t)
(define-sgol-keyword 'false '#f)
(define-sgol-keyword 'if if-operator)
(define-sgol-keyword 'then then-operator)
(define-sgol-keyword 'else else-operator)
(define-sgol-keyword 'not (make-operator 'not 70 70 parse-prefix #f))
(define-sgol-keyword 'and (make-operator 'and 65 #f #f parse-nary))
(define-sgol-keyword 'or (make-operator 'or 60 #f #f parse-nary))
; Lists
(define (open-bracket-nud token stream)
(let ((elements (prsmatch close-bracket-operator stream)))
(if (null? elements)
`'()
`(list ,@elements))))
(define (open-bracket-led token left stream)
(let ((subscripts (prsmatch close-bracket-operator stream)))
(if (and (not (null? subscripts))
(null? (cdr subscripts)))
`(vector-ref ,left ,@subscripts)
`(array-ref ,left ,@subscripts))))
(define-sgol-punctuation "["
(make-operator 'open-bracket 200 #f open-bracket-nud open-bracket-led))
(define close-bracket-operator
(make-operator 'close-bracket 5 #f delim-error erb-error))
(define-sgol-punctuation "]" close-bracket-operator)
(define-sgol-punctuation "::"
(make-operator 'cons 75 74 #f parse-infix))
(define-sgol-punctuation "++"
(make-operator 'append 75 74 #f parse-nary))
; Quotation
(define-sgol-punctuation "'"
(make-operator 'quote 5 #f parse-matchfix #f)) ;This isn't right
; Arithmetic
(define-sgol-punctuation "+"
(make-operator '+ 100 100 parse-prefix parse-infix))
(define-sgol-punctuation "-"
(make-operator '- 100 100 parse-prefix parse-infix))
(define-sgol-punctuation "*"
(make-operator '* 120 120 #f parse-infix)) ;should be parse-nary
(define-sgol-punctuation "/"
(make-operator '/ 120 120 #f parse-infix))
(define-sgol-punctuation "="
(make-operator '= 80 80 #f parse-infix))
(define-sgol-punctuation ">"
(make-operator '> 80 80 #f parse-infix))
(define-sgol-punctuation "<"
(make-operator '< 80 80 #f parse-infix))
(define-sgol-punctuation ">="
(make-operator '>= 80 80 #f parse-infix))
(define-sgol-punctuation "<="
(make-operator '<= 80 80 #f parse-infix))
(define-sgol-punctuation "!="
(make-operator '!= 80 80 #f parse-infix))
; Side effects
(define (:=-led token left stream)
(let* ((form (parse-infix token left stream))
(lhs (cadr form))
(rhs (caddr form)))
(if (pair? lhs)
(case (car lhs)
((car) `(set-car! ,@(cdr lhs) ,rhs))
((cdr) `(set-cdr! ,@(cdr lhs) ,rhs))
((vector-ref) `(vector-set! ,@(cdr lhs) ,rhs))
((array-ref) `(array-set! ,@(cdr lhs) ,rhs))
(else (error "invalid LHS for :=" form)))
form)))
(define-sgol-punctuation ":="
(make-operator 'set! 70 #f #f :=-led))
; End of input...
(define-sgol-punctuation ";" end-of-input-operator)
; Read using Pratt parser with SGOL tokenizer table
(define (sgol-read . port-option)
(toplevel-parse (port->stream (if (null? port-option)
(current-input-port)
(car port-option))
sgol-lexer-table)))
; Read/print loop
(define (rpl)
(let ((thing (sgol-read)))
(if (not (eq? thing end-of-input-operator))
(begin (write thing)
(newline)
(rpl)))))
; Read/eval/print loop
(define (rpl)
(let ((thing (sgol-read)))
(if (not (eq? thing end-of-input-operator))
(begin (write thing)
(newline)
(rpl)))))

154
scheme/infix/tokenize.scm
View File

@ -1,154 +0,0 @@
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; A tokenizer.
; Nonstandard things needed:
; record package
; char->ascii
; peek-char
; reverse-list->string
; error
(define (reverse-list->string l n)
(list->string (reverse l)))
; Tokenizer tables
(define tokenizer-table-type
(make-record-type 'tokenizer-table
'(translation dispatch-vector terminating?-vector)))
(define make-tokenizer-table
(let ()
(define make
(record-constructor tokenizer-table-type
'(translation dispatch-vector terminating?-vector)))
(define (make-tokenizer-table)
(make (if (char=? (string-ref (symbol->string 't) 0) #\T)
char-upcase
char-downcase)
(make-vector 256 (lambda (c port)
(error "illegal character read" c)))
(make-vector 256 #t)))
make-tokenizer-table))
(define ttab-translation
(record-accessor tokenizer-table-type 'translation))
(define ttab-dispatch-vector
(record-accessor tokenizer-table-type 'dispatch-vector))
(define ttab-terminating?-vector
(record-accessor tokenizer-table-type 'terminating?-vector))
(define set-tokenizer-table-translator!
(record-modifier tokenizer-table-type 'translation))
(define (set-char-tokenization! ttab char reader term?)
(vector-set! (ttab-dispatch-vector ttab) (char->ascii char) reader)
(vector-set! (ttab-terminating?-vector ttab) (char->ascii char) term?))
; Main dispatch
(define (tokenize ttab port)
(let ((c (read-char port)))
(if (eof-object? c)
c
((vector-ref (ttab-dispatch-vector ttab) (char->ascii c))
c port))))
; Atoms (symbols and numbers)
(define (scan-atom c ttab port)
(let ((translate (ttab-translation ttab)))
(let loop ((l (list (translate c))) (n 1))
(let ((c (peek-char port)))
(cond ((or (eof-object? c)
(vector-ref (ttab-terminating?-vector ttab)
(char->ascii c)))
(reverse-list->string l n))
(else
(loop (cons (translate (read-char port)) l)
(+ n 1))))))))
; Allow ->foo, -v-, etc.
(define (parse-atom string)
(let ((c (string-ref string 0)))
(cond ((char=? c #\+)
(parse-possible-number string))
((char=? c #\-)
(parse-possible-number string))
((char=? c #\.)
(parse-possible-number string))
(else
(if (char-numeric? c)
(parse-number string)
(string->symbol string))))))
; First char is + - .
(define (parse-possible-number string)
(if (and (> (string-length string) 1)
(char-numeric? (string-ref string 1)))
(parse-number string)
(string->symbol string)))
(define (parse-number string)
(or (string->number string 'e 'd)
(error "unsupported number syntax" string)))
; Usual stuff (what you'd expect to be common to Scheme and ML syntax)
(define (set-up-usual-tokenization! ttab)
(define (tokenize-whitespace c port) c ;ignored
(tokenize ttab port))
(define (tokenize-constituent c port)
(parse-atom (scan-atom c ttab port)))
(for-each (lambda (c)
(set-char-tokenization! ttab (ascii->char c)
tokenize-whitespace #t))
ascii-whitespaces)
(for-each (lambda (c)
(set-char-tokenization! ttab c tokenize-constituent #f))
(string->list
(string-append ".0123456789"
"ABCDEFGHIJKLMNOPQRSTUVWXYZ"
"abcdefghijklmnopqrstuvwxyz")))
(set-char-tokenization! ttab #\" tokenize-string #t)
)
(define (make-constituent! c ttab)
(set-char-tokenization! ttab c
(lambda (c port)
(parse-atom (scan-atom c ttab port)))
#f))
(define (tokenize-string c port) c ;ignored
(let loop ((l '()) (i 0))
(let ((c (read-char port)))
(cond ((eof-object? c)
(error "end of file within a string"))
((char=? c #\\)
(let ((c (read-char port)))
(if (or (char=? c #\\) (char=? c #\"))
(loop (cons c l) (+ i 1))
(error "invalid escaped character in string" c))))
((char=? c #\") (reverse-list->string l i))
(else (loop (cons c l) (+ i 1)))))))
; Auxiliary for parse-atom and tokenize-string
;(define (reverse-list->string l n) ;In microcode?
; (let ((s (make-string n)))
; (do ((l l (cdr l))
; (i (- n 1) (- i 1)))
; ((< i 0) s)
; (string-set! s i (car l)))))

2
scheme/link/generate-c-header.scm
View File

@ -174,7 +174,7 @@
type index))
'("VECTOR" "RECORD")
'("(i)" "(i) + 1"))
(c-define "S48_RECORD_TYPE(x) (s48_stob_ref((x), S48_STOBTYPE_RECORD))")
(c-define "S48_RECORD_TYPE(x) (s48_stob_ref((x), S48_STOBTYPE_RECORD, 0))")
(c-define "S48_UNSAFE_RECORD_TYPE(x) (STOB_REF((x), 0))")
(for-each (lambda (type)
(c-define "S48_~A_LENGTH(x) (s48_stob_byte_length((x), S48_STOBTYPE_~A))"

20
scheme/more-interfaces.scm
View File

@ -648,3 +648,23 @@
option-optional-arg?
option-processor
args-fold))
(define-interface srfi-42-interface
(export ((do-ec
list-ec append-ec
string-ec string-append-ec
vector-ec vector-of-length-ec
sum-ec product-ec
min-ec max-ec
any?-ec every?-ec
first-ec last-ec
fold-ec fold3-ec) :syntax)
((:
:list :string :vector
:integers
:range :real-range :char-range
:port
:dispatched) :syntax)
((:do :let :parallel :while :until) :syntax)
:-dispatch-ref :-dispatch-set! make-initial-:-dispatch
(:generator-proc :syntax)))

114
scheme/more-packages.scm
View File

@ -415,6 +415,7 @@
(files (big placeholder))
(optimize auto-integrate))
;----------------
; Big Scheme
@ -423,10 +424,6 @@
signals) ;call-error
(files (big random)))
(define-structure sort (export sort-list sort-list!)
(open scheme-level-2)
(files (big sort)))
(define-structure pp (export p pretty-print define-indentation)
(open scheme-level-2
tables
@ -495,6 +492,87 @@
threads thread-cells fluids)
(files (big thread-fluid)))
;;; Package defs for the Scheme Underground sorting package,
;;; The general sort package:
(define-structure sorting sorting-interface
(open scheme
list-merge-sort
vector-heap-sort
vector-merge-sort
sorted
delete-neighbor-duplicates)
(files (sort sort))
(optimize auto-integrate))
(define-structure sorted sorted-interface
(open scheme
vector-utils)
(files (sort sortp))
(optimize auto-integrate))
(define-structure delete-neighbor-duplicates delete-neighbor-duplicates-interface
(open scheme
receiving
vector-utils)
(files (sort delndups))
(optimize auto-integrate))
(define-structure binary-searches binary-searches-interface
(open scheme
vector-utils)
(files (sort vbinsearch)))
(define-structure list-merge-sort list-merge-sort-interface
(open scheme
receiving
(subset signals (error)))
(files (sort lmsort))
(optimize auto-integrate))
(define-structure vector-merge-sort vector-merge-sort-interface
(open scheme
receiving
vector-utils
vector-insertion-sort-internal)
(files (sort vmsort))
(optimize auto-integrate))
(define-structure vector-heap-sort vector-heap-sort-interface
(open scheme
receiving
vector-utils)
(files (sort vhsort))
(optimize auto-integrate))
(define-structures ((vector-insertion-sort vector-insertion-sort-interface)
(vector-insertion-sort-internal
vector-insertion-sort-internal-interface))
(open scheme
vector-utils)
(files (sort visort))
(optimize auto-integrate))
(define-structure vector-utils (export vector-copy
vector-portion-copy
vector-portion-copy!
vector-start+end
vectors-start+end-2)
(open scheme)
(files (sort vector-util)))
;;; end Package defs for the Scheme Underground sorting package,
(define-structure sort (export sort-list sort-list!)
(open scheme-level-2
sorting)
(begin
(define (sort-list l obj-<)
(list-sort obj-< l))
(define (sort-list! l obj-<)
(list-sort! obj-< l))))
(define-structure big-util big-util-interface
(open scheme-level-2
formats
@ -695,7 +773,7 @@
; SRFI-4 - needs hacks to the reader
(define-structure srfi-5 (export (let :syntax))
(open (modify scheme-level-2 (hide let)))
(open (modify scheme-level-2 (rename (let standard-let))))
(files (srfi srfi-5)))
(define-structure srfi-6 (export open-input-string
@ -729,8 +807,9 @@
(define available-srfis
'(srfi-1 srfi-2 srfi-5 srfi-6 srfi-7 srfi-8 srfi-9
srfi-11 srfi-13 srfi-14 srfi-16 srfi-17 srfi-19 srfi-23
srfi-25 srfi-26 srfi-27 srfi-28 srfi-30 srfi-31
srfi-37))
srfi-25 srfi-26 srfi-27 srfi-28
srfi-30 srfi-31 srfi-37
srfi-42))
; Some SRFI's redefine Scheme variables.
(define shadowed
@ -813,8 +892,8 @@
(subset srfi-1 (reverse!))
srfi-6
srfi-8
signals
srfi-9)
srfi-9
srfi-23)
(files (srfi srfi-19))))
; SRFI-20 - withdrawn
@ -873,6 +952,12 @@
srfi-11)
(files (srfi srfi-37)))
; Eager Comprehensions
(define-structure srfi-42 srfi-42-interface
(open scheme
srfi-23)
(files (srfi srfi-42)))
; ... end of package definitions.
; Temporary compatibility stuff
@ -935,7 +1020,17 @@
search-trees
sicp
sockets
sort
delete-neighbor-duplicates
binary-searches
sorted
list-merge-sort
vector-merge-sort
vector-heap-sort
vector-insertion-sort
sorting
strong
thread-fluids
traverse
@ -960,6 +1055,7 @@
srfi-11 srfi-13 srfi-14 srfi-16 srfi-17
srfi-23 srfi-25 srfi-26 srfi-27 srfi-28
srfi-31 srfi-37
srfi-42
)
:structure)
make-srfi-19

2
scheme/opt/flatten.scm
View File

@ -9,7 +9,7 @@
(set-optimizer! 'flat-environments
(lambda (forms package)
(map (lambda (form)
(flatten-form (force form)))
(flatten-form (force-node form)))
forms)))
(define (flatten-form node)

4
scheme/opt/inline.scm
View File

@ -87,9 +87,7 @@
; I'm aware that this is pedantic.
(define (unused-name env name)
(let ((sym (if (generated? name)
(generated-name name)
name)))
(let ((sym (name->symbol name)))
(do ((i 0 (+ i 1))
(name sym
(string->symbol (string-append (symbol->string sym)

4
scheme/opt/usage.scm
View File

@ -189,6 +189,10 @@
free
usages)))
(define-usage-analyzer 'flat-lambda #f
(lambda (node free usages)
(error "Inliner applied on flat lambda, please swap OPTIMIZE clauses")))
;--------------------
; Usage records record the number of times that a variable is referenced, set!,
; and called.

8
scheme/rts/numio.scm
View File

@ -121,6 +121,14 @@
#f) ;inexact
((char=? (string-ref string pos) #\#)
#f)
((and (= radix 10)
(case (char-downcase (string-ref string pos))
;; One day, we have to include #\s #\f #\d #\l.
;; We don't now because STRING->FLOAT actually does the
;; wrong thing for these currently, so we'd rather barf.
((#\e) #t)
(else #f)))
#f)
(else (loop (+ pos 1))))))))))))
(define-generic really-string->number &really-string->number)

3
scheme/rts/xnum.scm
View File

@ -216,9 +216,12 @@
(define-simple-type :exact (:number)
(lambda (n) (and (number? n) (exact? n))))
(define-method &inexact->exact ((n :exact)) n)
(define-simple-type :inexact (:number)
(lambda (n) (and (number? n) (inexact? n))))
(define-method &exact->inexact ((n :inexact)) n)
; Whattakludge.

185
scheme/sort/delndups.scm Normal file
View File

@ -0,0 +1,185 @@
;;; The SRFI-32 sort package -- delete neighboring duplicate elts
;;; Copyright (c) 1998 by Olin Shivers.
;;; This code is open-source; see the end of the file for porting and
;;; more copyright information.
;;; Olin Shivers 11/98.
;;; Problem:
;;; vector-delete-neighbor-dups pushes N stack frames, where N is the number
;;; of elements in the answer vector. This is arguably a very efficient thing
;;; to do, but it might blow out on a system with a limited stack but a big
;;; heap. We could rewrite this to "chunk" up answers in temp vectors if we
;;; push more than a certain number of frames, then allocate a final answer,
;;; copying all the chunks into the answer. But it's much more complex code.
;;; Exports:
;;; (list-delete-neighbor-dups = lis) -> list
;;; (list-delete-neighbor-dups! = lis) -> list
;;; (vector-delete-neighbor-dups = v [start end]) -> vector
;;; (vector-delete-neighbor-dups! = v [start end]) -> end'
;;; These procedures delete adjacent duplicate elements from a list or
;;; a vector, using a given element equality procedure. The first or leftmost
;;; element of a run of equal elements is the one that survives. The list
;;; or vector is not otherwise disordered.
;;;
;;; These procedures are linear time -- much faster than the O(n^2) general
;;; duplicate-elt deletors that do not assume any "bunching" of elements.
;;; If you want to delete duplicate elements from a large list or vector,
;;; sort the elements to bring equal items together, then use one of these
;;; procedures -- for a total time of O(n lg n).
;;; LIST-DELETE-NEIGHBOR-DUPS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Below are multiple versions of the LIST-DELETE-NEIGHBOR-DUPS procedure,
;;; from simple to complex. RECUR's contract: Strip off any leading X's from
;;; LIS, and return that list neighbor-dup-deleted.
;;;
;;; The final version
;;; - shares a common subtail between the input & output list, up to 1024
;;; elements;
;;; - Needs no more than 1024 stack frames.
;;; Simplest version.
;;; - Always allocates a fresh list / never shares storage.
;;; - Needs N stack frames, if answer is length N.
(define (list-delete-neighbor-dups = lis)
(if (pair? lis)
(let ((x0 (car lis)))
(cons x0 (let recur ((x0 x0) (xs (cdr lis)))
(if (pair? xs)
(let ((x1 (car xs))
(x2+ (cdr xs)))
(if (= x0 x1)
(recur x0 x2+) ; Loop, actually.
(cons x1 (recur x1 x2+))))
xs))))
lis))
;;; This version tries to use cons cells from input by sharing longest
;;; common tail between input & output. Still needs N stack frames, for ans
;;; of length N.
(define (list-delete-neighbor-dups = lis)
(if (pair? lis)
(let* ((x0 (car lis))
(xs (cdr lis))
(ans (let recur ((x0 x0) (xs xs))
(if (pair? xs)
(let ((x1 (car xs))
(x2+ (cdr xs)))
(if (= x0 x1)
(recur x0 x2+)
(let ((ans-tail (recur x1 x2+)))
(if (eq? ans-tail x2+) xs
(cons x1 ans-tail)))))
xs))))
(if (eq? ans xs) lis (cons x0 ans)))
lis))
;;; LIST-DELETE-NEIGHBOR-DUPS!
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code runs in constant list space, constant stack, and also
;;; does only the minimum SET-CDR!'s necessary.
(define (list-delete-neighbor-dups! = lis)
(if (pair? lis)
(let lp1 ((prev lis) (prev-elt (car lis)) (lis (cdr lis)))
(if (pair? lis)
(let ((lis-elt (car lis))
(next (cdr lis)))
(if (= prev-elt lis-elt)
;; We found the first elts of a run of dups, so we know
;; we're going to have to do a SET-CDR!. Scan to the end of
;; the run, do the SET-CDR!, and loop on LP1.
(let lp2 ((lis next))
(if (pair? lis)
(let ((lis-elt (car lis))
(next (cdr lis)))
(if (= prev-elt lis-elt)
(lp2 next)
(begin (set-cdr! prev lis)
(lp1 lis lis-elt next))))
(set-cdr! prev lis))) ; Ran off end => quit.
(lp1 lis lis-elt next))))))
lis)
(define (vector-delete-neighbor-dups elt= v . maybe-start+end)
(call-with-values
(lambda () (vector-start+end v maybe-start+end))
(lambda (start end)
(if (< start end)
(let* ((x (vector-ref v start))
(ans (let recur ((x x) (i start) (j 1))
(if (< i end)
(let ((y (vector-ref v i))
(nexti (+ i 1)))
(if (elt= x y)
(recur x nexti j)
(let ((ansvec (recur y nexti (+ j 1))))
(vector-set! ansvec j y)
ansvec)))
(make-vector j)))))
(vector-set! ans 0 x)
ans)
'#()))))
;;; Packs the surviving elements to the left, in range [start,end'),
;;; and returns END'.
(define (vector-delete-neighbor-dups! elt= v . maybe-start+end)
(call-with-values
(lambda () (vector-start+end v maybe-start+end))
(lambda (start end)
(if (>= start end)
end
;; To eliminate unnecessary copying (read elt i then write the value
;; back at index i), we scan until we find the first dup.
(let skip ((j start) (vj (vector-ref v start)))
(let ((j+1 (+ j 1)))
(if (>= j+1 end)
end
(let ((vj+1 (vector-ref v j+1)))
(if (not (elt= vj vj+1))
(skip j+1 vj+1)
;; OK -- j & j+1 are dups, so we're committed to moving
;; data around. In lp2, v[start,j] is what we've done;
;; v[k,end) is what we have yet to handle.
(let lp2 ((j j) (vj vj) (k (+ j 2)))
(let lp3 ((k k))
(if (>= k end)
(+ j 1) ; Done.
(let ((vk (vector-ref v k))
(k+1 (+ k 1)))
(if (elt= vj vk)
(lp3 k+1)
(let ((j+1 (+ j 1)))
(vector-set! v j+1 vk)
(lp2 j+1 vk k+1))))))))))))))))
;;; Copyright
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code is
;;; Copyright (c) 1998 by Olin Shivers.
;;; The terms are: You may do as you please with this code, as long as
;;; you do not delete this notice or hold me responsible for any outcome
;;; related to its use.
;;;
;;; Blah blah blah. Don't you think source files should contain more lines
;;; of code than copyright notice?
;;;
;;; Code porting
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; If your Scheme has a faster mechanism for handling optional arguments
;;; (e.g., Chez), you should definitely port over to it. Note that argument
;;; defaulting and error-checking are interleaved -- you don't have to
;;; error-check defaulted START/END args to see if they are fixnums that are
;;; legal vector indices for the corresponding vector, etc.

199
scheme/sort/interfaces.scm Normal file
View File

@ -0,0 +1,199 @@
;;; Interface defs for the Scheme Underground sorting package,
;;; in the Scheme 48 module language.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; list-delete-neighbor-dups = l -> list
;;; vector-delete-neighbor-dups = v [start end] -> vector
;;; vector-delete-neighbor-dups! = v [start end] -> vector
;;;
(define-interface delete-neighbor-duplicates-interface
(export (list-delete-neighbor-dups
(proc ((proc (:value :value) :boolean)
:value)
:value))
(vector-delete-neighbor-dups
(proc ((proc (:value :value) :boolean)
:vector
&opt
:exact-integer :exact-integer)
:vector))
(vector-delete-neighbor-dups!
(proc ((proc (:value :value) :boolean)
:vector
&opt
:exact-integer :exact-integer)
:vector))))
;;; vector-binary-search elt< elt->key key v [start end] -> integer-or-false
;;; vector-binary-search3 c v [start end] -> integer-or-false
(define-interface binary-searches-interface
(export vector-binary-search
vector-binary-search3))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; list-sorted? l < -> boolean
;;; vector-sorted? v < [start end] -> boolean
(define-interface sorted-interface
(export (list-sorted? (proc (:value (proc (:value :value) :boolean)) :boolean))
(vector-sorted? (proc ((proc (:value :value) :boolean)
:vector
&opt :exact-integer :exact-integer)
:boolean))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; list-merge-sort < l -> list
;;; list-merge-sort! < l -> list
;;; list-merge < lis lis -> list
;;; list-merge! < lis lis -> list
(define-interface list-merge-sort-interface
(export ((list-merge-sort list-merge-sort!)
(proc ((proc (:value :value) :boolean) :value) :value))
((list-merge list-merge!)
(proc ((proc (:value :value) :boolean) :value :value) :value))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; vector-merge-sort < v [start end temp] -> vector
;;; vector-merge-sort! < v [start end temp] -> unspecific
;;; vector-merge < v1 v2 [start1 end1 start2 end2] -> vector
;;; vector-merge! < v v1 v2 [start0 start1 end1 start2 end2] -> unspecific
(define-interface vector-merge-sort-interface
(export
(vector-merge-sort (proc ((proc (:value :value) :boolean)
:vector
&opt
:exact-integer :exact-integer
:vector)
:vector))
(vector-merge-sort! (proc ((proc (:value :value) :boolean)
:vector
&opt
:exact-integer :exact-integer
:vector)
:unspecific))
(vector-merge (proc ((proc (:value :value) :boolean)
:vector :vector
&opt
:exact-integer :exact-integer
:exact-integer :exact-integer)
:vector))
(vector-merge! (proc ((proc (:value :value) :boolean)
:vector :vector :vector
&opt
:exact-integer :exact-integer :exact-integer
:exact-integer :exact-integer)
:unspecific))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; heap-sort < v [start end] -> vector
;;; heap-sort! < v -> unspecific
(define-interface vector-heap-sort-interface
(export (heap-sort (proc ((proc (:value :value) :boolean)
:vector
&opt :exact-integer :exact-integer)
:vector))
(heap-sort! (proc ((proc (:value :value) :boolean) :vector) :unspecific))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; insert-sort < v [start end] -> vector
;;; insert-sort! < v [start end] -> unspecific
;;;
;;; internal:
;;; %insert-sort! < v start end -> unspecific
(define-interface vector-insertion-sort-interface
(export (insert-sort (proc ((proc (:value :value) :boolean)
:vector
&opt :exact-integer :exact-integer)
:vector))
(insert-sort! (proc ((proc (:value :value) :boolean)
:vector
&opt :exact-integer :exact-integer)
:unspecific))))
(define-interface vector-insertion-sort-internal-interface
(export (%insert-sort! (proc ((proc (:value :value) :boolean)
:vector
:exact-integer :exact-integer)
:unspecific))))
;;; The general sort interface:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; list-sorted? < l -> boolean
;;;
;;; list-merge < l1 l2 -> list
;;; list-merge! < l1 l2 -> list
;;;
;;; list-sort < l -> list
;;; list-sort! < l -> list
;;; list-stable-sort < l -> list
;;; list-stable-sort! < l -> list
;;;
;;; list-delete-neighbor-dups l = -> list
;;;
;;; vector-sorted? < v [start end] -> boolean
;;;
;;; vector-merge < v1 v2 [start1 end1 start2 end2] -> vector
;;; vector-merge! < v v1 v2 [start start1 end1 start2 end2] -> unspecific
;;;
;;; vector-sort < v [start end] -> vector
;;; vector-sort! < v -> unspecific
;;;
;;; vector-stable-sort < v [start end] -> vector
;;; vector-stable-sort! < v -> unspecific
;;;
;;; vector-delete-neighbor-dups v = [start end] -> vector
(define-interface sorting-interface
(compound-interface
sorted-interface
(export
((list-merge list-merge!)
(proc ((proc (:value :value) :boolean) :value :value) :value))
((list-sort list-sort! list-stable-sort list-stable-sort!)
(proc ((proc (:value :value) :boolean) :value) :value))
(vector-merge (proc ((proc (:value :value) :boolean)
:vector :vector
&opt
:exact-integer :exact-integer
:exact-integer :exact-integer)
:vector))
(vector-merge! (proc ((proc (:value :value) :boolean)
:vector :vector :vector
&opt
:exact-integer :exact-integer :exact-integer
:exact-integer :exact-integer)
:unspecific))
((vector-sort vector-stable-sort)
(proc ((proc (:value :value) :boolean)
:vector
&opt
:exact-integer :exact-integer)
:vector))
((vector-sort! vector-stable-sort!)
(proc ((proc (:value :value) :boolean) :vector) :unspecific))
(list-delete-neighbor-dups
(proc ((proc (:value :value) :boolean)
:value)
:value))
(vector-delete-neighbor-dups
(proc ((proc (:value :value) :boolean)
:vector
&opt
:exact-integer :exact-integer)
:vector)))))

386
scheme/sort/lmsort.scm Normal file
View File

@ -0,0 +1,386 @@
;;; list merge & list merge-sort -*- Scheme -*-
;;; Copyright (c) 1998 by Olin Shivers.
;;; This code is open-source; see the end of the file for porting and
;;; more copyright information.
;;; Olin Shivers
;;; Exports:
;;; (list-merge < lis lis) -> list
;;; (list-merge! < lis lis) -> list
;;; (list-merge-sort < lis) -> list
;;; (list-merge-sort! < lis) -> list
;;; A stable list merge sort of my own device
;;; Two variants: pure & destructive
;;;
;;; This list merge sort is opportunistic (a "natural" sort) -- it exploits
;;; existing order in the input set. Instead of recursing all the way down to
;;; individual elements, the leaves of the merge tree are maximal contiguous
;;; runs of elements from the input list. So the algorithm does very well on
;;; data that is mostly ordered, with a best-case time of O(n) when the input
;;; list is already completely sorted. In any event, worst-case time is
;;; O(n lg n).
;;;
;;; The destructive variant is "in place," meaning that it allocates no new
;;; cons cells at all; it just rearranges the pairs of the input list with
;;; SET-CDR! to order it.
;;;
;;; The interesting control structure is the combination recursion/iteration
;;; of the core GROW function that does an "opportunistic" DFS walk of the
;;; merge tree, adaptively subdividing in response to the length of the
;;; merges, without requiring any auxiliary data structures beyond the
;;; recursion stack. It's actually quite simple -- ten lines of code.
;;; -Olin Shivers 10/20/98
;;; (mlet ((var-list mv-exp) ...) body ...)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A LET* form that handles multiple values. Move this into the two clients
;;; if you don't have a module system handy to restrict its visibility...
(define-syntax mlet ; Multiple-value LET*
(syntax-rules ()
((mlet ((() exp) rest ...) body ...)
(begin exp (mlet (rest ...) body ...)))
((mlet (((var) exp) rest ...) body ...)
(let ((var exp)) (mlet (rest ...) body ...)))
((mlet ((vars exp) rest ...) body ...)
(call-with-values (lambda () exp)
(lambda vars (mlet (rest ...) body ...))))
((mlet () body ...) (begin body ...))))
;;; (list-merge-sort < lis)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A natural, stable list merge sort.
;;; - natural: picks off maximal contiguous runs of pre-ordered data.
;;; - stable: won't invert the order of equal elements in the input list.
(define (list-merge-sort elt< lis)
;; (getrun lis) -> run runlen rest
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Pick a run of non-decreasing data off of non-empty list LIS.
;; Return the length of this run, and the following list.
(define (getrun lis)
(let lp ((ans '()) (i 1) (prev (car lis)) (xs (cdr lis)))
(if (pair? xs)
(let ((x (car xs)))
(if (elt< x prev)
(values (append-reverse ans (cons prev '())) i xs)
(lp (cons prev ans) (+ i 1) x (cdr xs))))
(values (append-reverse ans (cons prev '())) i xs))))
(define (append-reverse rev-head tail)
(let lp ((rev-head rev-head) (tail tail))
(if (null-list? rev-head) tail
(lp (cdr rev-head) (cons (car rev-head) tail)))))
(define (null-list? l)
(cond ((pair? l) #f)
((null? l) #t)
(else (error "null-list?: argument out of domain" l))))
;; (merge a b) -> list
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; List merge -- stably merge lists A (length > 0) & B (length > 0).
;; This version requires up to |a|+|b| stack frames.
(define (merge a b)
(let recur ((x (car a)) (a a)
(y (car b)) (b b))
(if (elt< y x)
(cons y (let ((b (cdr b)))
(if (pair? b)
(recur x a (car b) b)
a)))
(cons x (let ((a (cdr a)))
(if (pair? a)
(recur (car a) a y b)
b))))))
;; (grow s ls ls2 u lw) -> [a la unused]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The core routine. Read the next 20 lines of comments & all is obvious.
;; - S is a sorted list of length LS > 1.
;; - LS2 is some power of two <= LS.
;; - U is an unsorted list.
;; - LW is a positive integer.
;; Starting with S, and taking data from U as needed, produce
;; a sorted list of *at least* length LW, if there's enough data
;; (LW <= LS + length(U)), or use all of U if not.
;;
;; GROW takes maximal contiguous runs of data from U at a time;
;; it is allowed to return a list *longer* than LW if it gets lucky
;; with a long run.
;;
;; The key idea: If you want a merge operation to "pay for itself," the two
;; lists being merged should be about the same length. Remember that.
;;
;; Returns:
;; - A: The result list
;; - LA: The length of the result list
;; - UNUSED: The unused tail of U.
(define (grow s ls ls2 u lw) ; The core of the sort algorithm.
(if (or (<= lw ls) (not (pair? u))) ; Met quota or out of data?
(values s ls u) ; If so, we're done.
(mlet (((ls2) (let lp ((ls2 ls2))
(let ((ls2*2 (+ ls2 ls2)))
(if (<= ls2*2 ls) (lp ls2*2) ls2))))
;; LS2 is now the largest power of two <= LS.
;; (Just think of it as being roughly LS.)
((r lr u2) (getrun u)) ; Get a run, then
((t lt u3) (grow r lr 1 u2 ls2))) ; grow it up to be T.
(grow (merge s t) (+ ls lt) ; Merge S & T,
(+ ls2 ls2) u3 lw)))) ; and loop.
;; Note: (LENGTH LIS) or any constant guaranteed
;; to be greater can be used in place of INFINITY.
(if (pair? lis) ; Don't sort an empty list.
(mlet (((r lr tail) (getrun lis)) ; Pick off an initial run,
((infinity) #o100000000) ; then grow it up maximally.
((a la v) (grow r lr 1 tail infinity)))
a)
'()))
;;; (list-merge-sort! < lis)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A natural, stable, destructive, in-place list merge sort.
;;; - natural: picks off maximal contiguous runs of pre-ordered data.
;;; - stable: won't invert the order of equal elements in the input list.
;;; - destructive, in-place: this routine allocates no extra working memory;
;;; it simply rearranges the list with SET-CDR! operations.
(define (list-merge-sort! elt< lis)
;; (getrun lis) -> runlen last rest
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Pick a run of non-decreasing data off of non-empty list LIS.
;; Return the length of this run, the last cons cell of the run,
;; and the following list.
(define (getrun lis)
(let lp ((lis lis) (x (car lis)) (i 1) (next (cdr lis)))
(if (pair? next)
(let ((y (car next)))
(if (elt< y x)
(values i lis next)
(lp next y (+ i 1) (cdr next))))
(values i lis next))))
;; (merge! a enda b endb) -> [m endm]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Destructively and stably merge non-empty lists A & B.
;; The last cons of A is ENDA. (The cdr of ENDA can be non-nil.)
;; the last cons of B is ENDB. (The cdr of ENDB can be non-nil.)
;;
;; Return the first and last cons cells of the merged list.
;; This routine is iterative & in-place: it runs in constant stack and
;; doesn't allocate any cons cells. It is also tedious but simple; don't
;; bother reading it unless necessary.
(define (merge! a enda b endb)
;; The logic of these two loops is completely driven by these invariants:
;; SCAN-A: (CDR PREV) = A. X = (CAR A). Y = (CAR B).
;; SCAN-B: (CDR PREV) = B. X = (CAR A). Y = (CAR B).
(letrec ((scan-a (lambda (prev x a y b) ; Zip down A until we
(cond ((elt< y x) ; find an elt > (CAR B).
(set-cdr! prev b)
(let ((next-b (cdr b)))
(if (eq? b endb)
(begin (set-cdr! b a) enda) ; Done.
(scan-b b x a (car next-b) next-b))))
((eq? a enda) (maybe-set-cdr! a b) endb) ; Done.
(else (let ((next-a (cdr a))) ; Continue scan.
(scan-a a (car next-a) next-a y b))))))
(scan-b (lambda (prev x a y b) ; Zip down B while its
(cond ((elt< y x) ; elts are < (CAR A).
(if (eq? b endb)
(begin (set-cdr! b a) enda) ; Done.
(let ((next-b (cdr b))) ; Continue scan.
(scan-b b x a (car next-b) next-b))))
(else (set-cdr! prev a)
(if (eq? a enda)
(begin (maybe-set-cdr! a b) endb) ; Done.
(let ((next-a (cdr a)))
(scan-a a (car next-a) next-a y b)))))))
;; This guy only writes if he has to. Called at most once.
;; Pointer equality rules; pure languages are for momma's boys.
(maybe-set-cdr! (lambda (pair val) (if (not (eq? (cdr pair) val))
(set-cdr! pair val)))))
(let ((x (car a)) (y (car b)))
(if (elt< y x)
;; B starts the answer list.
(values b (if (eq? b endb)
(begin (set-cdr! b a) enda)
(let ((next-b (cdr b)))
(scan-b b x a (car next-b) next-b))))
;; A starts the answer list.
(values a (if (eq? a enda)
(begin (maybe-set-cdr! a b) endb)
(let ((next-a (cdr a)))
(scan-a a (car next-a) next-a y b))))))))
;; (grow s ends ls ls2 u lw) -> [a enda la unused]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The core routine.
;; - S is a sorted list of length LS > 1, with final cons cell ENDS.
;; (CDR ENDS) doesn't have to be nil.
;; - LS2 is some power of two <= LS.
;; - U is an unsorted list.
;; - LW is a positive integer.
;; Starting with S, and taking data from U as needed, produce
;; a sorted list of *at least* length LW, if there's enough data
;; (LW <= LS + length(U)), or use all of U if not.
;;
;; GROW takes maximal contiguous runs of data from U at a time;
;; it is allowed to return a list *longer* than LW if it gets lucky
;; with a long run.
;;
;; The key idea: If you want a merge operation to "pay for itself," the two
;; lists being merged should be about the same length. Remember that.
;;
;; Returns:
;; - A: The result list (not properly terminated)
;; - ENDA: The last cons cell of the result list.
;; - LA: The length of the result list
;; - UNUSED: The unused tail of U.
(define (grow s ends ls ls2 u lw)
(if (and (pair? u) (< ls lw))
;; We haven't met the LW quota but there's still some U data to use.
(mlet (((ls2) (let lp ((ls2 ls2))
(let ((ls2*2 (+ ls2 ls2)))
(if (<= ls2*2 ls) (lp ls2*2) ls2))))
;; LS2 is now the largest power of two <= LS.
;; (Just think of it as being roughly LS.)
((lr endr u2) (getrun u)) ; Get a run from U;
((t endt lt u3) (grow u endr lr 1 u2 ls2)) ; grow it up to be T.
((st end-st) (merge! s ends t endt))) ; Merge S & T,
(grow st end-st (+ ls lt) (+ ls2 ls2) u3 lw)) ; then loop.
(values s ends ls u))) ; Done -- met LW quota or ran out of data.
;; Note: (LENGTH LIS) or any constant guaranteed
;; to be greater can be used in place of INFINITY.
(if (pair? lis)
(mlet (((lr endr rest) (getrun lis)) ; Pick off an initial run.
((infinity) #o100000000) ; Then grow it up maximally.
((a enda la v) (grow lis endr lr 1 rest infinity)))
(set-cdr! enda '()) ; Nil-terminate answer.
a) ; We're done.
'())) ; Don't sort an empty list.
;;; Merge
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These two merge procedures are stable -- ties favor list A.
(define (list-merge < a b)
(cond ((not (pair? a)) b)
((not (pair? b)) a)
(else (let recur ((x (car a)) (a a) ; A is a pair; X = (CAR A).
(y (car b)) (b b)) ; B is a pair; Y = (CAR B).
(if (< y x)
(let ((b (cdr b)))
(if (pair? b)
(cons y (recur x a (car b) b))
(cons y a)))
(let ((a (cdr a)))
(if (pair? a)
(cons x (recur (car a) a y b))
(cons x b))))))))
;;; This destructive merge does as few SET-CDR!s as it can -- for example, if
;;; the list is already sorted, it does no SET-CDR!s at all. It is also
;;; iterative, running in constant stack.
(define (list-merge! < a b)
;; The logic of these two loops is completely driven by these invariants:
;; SCAN-A: (CDR PREV) = A. X = (CAR A). Y = (CAR B).
;; SCAN-B: (CDR PREV) = B. X = (CAR A). Y = (CAR B).
(letrec ((scan-a (lambda (prev a x b y) ; Zip down A doing
(if (< y x) ; no SET-CDR!s until
(let ((next-b (cdr b))) ; we hit a B elt that
(set-cdr! prev b) ; has to be inserted.
(if (pair? next-b)
(scan-b b a x next-b (car next-b))
(set-cdr! b a)))
(let ((next-a (cdr a)))
(if (pair? next-a)
(scan-a a next-a (car next-a) b y)
(set-cdr! a b))))))
(scan-b (lambda (prev a x b y) ; Zip down B doing
(if (< y x) ; no SET-CDR!s until
(let ((next-b (cdr b))) ; we hit an A elt that
(if (pair? next-b) ; has to be
(scan-b b a x next-b (car next-b)) ; inserted.
(set-cdr! b a)))
(let ((next-a (cdr a)))
(set-cdr! prev a)
(if (pair? next-a)
(scan-a a next-a (car next-a) b y)
(set-cdr! a b)))))))
(cond ((not (pair? a)) b)
((not (pair? b)) a)
;; B starts the answer list.
((< (car b) (car a))
(let ((next-b (cdr b)))
(if (null? next-b)
(set-cdr! b a)
(scan-b b a (car a) next-b (car next-b))))
b)
;; A starts the answer list.
(else (let ((next-a (cdr a)))
(if (null? next-a)
(set-cdr! a b)
(scan-a a next-a (car next-a) b (car b))))
a))))
;;; Copyright
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code is
;;; Copyright (c) 1998 by Olin Shivers.
;;; The terms are: You may do as you please with this code, as long as
;;; you do not delete this notice or hold me responsible for any outcome
;;; related to its use.
;;;
;;; Blah blah blah.
;;; Code tuning & porting
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This is very portable code. It's R4RS with the following exceptions:
;;; - The R5RS multiple-value VALUES & CALL-WITH-VALUES procedures for
;;; handling multiple-value return.
;;;
;;; This code is *tightly* bummed as far as I can go in portable Scheme.
;;;
;;; - The fixnum arithmetic in LIST-MERGE-SORT! and COUNTED-LIST-MERGE!
;;; that could be safely switched over to unsafe, fixnum-specific ops,
;;; if you're sure that 2*maxlen is a fixnum, where maxlen is the length
;;; of the longest list you could ever have.
;;;
;;; - I typically write my code in a style such that every CAR and CDR
;;; application is protected by an upstream PAIR?. This is the case in this
;;; code, so all the CAR's and CDR's could safely switched over to unsafe
;;; versions. But check over the code before you do it, in case the source
;;; has been altered since I wrote this.

70
scheme/sort/packages.scm Normal file
View File

@ -0,0 +1,70 @@
;;; Package defs for the Scheme Underground sorting package,
;;; in the Scheme 48 module language.
;;; The general sort package:
(define-structure sorting sorting-interface
(open scheme
list-merge-sort
vector-heap-sort
vector-merge-sort
sorted
delete-neighbor-duplicates)
(files sort)
(optimize auto-integrate))
(define-structure sorted sorted-interface
(open scheme
vector-utils)
(files sortp)
(optimize auto-integrate))
(define-structure delete-neighbor-duplicates delete-neighbor-duplicates-interface
(open scheme
receiving
vector-utils)
(files delndups)
(optimize auto-integrate))
(define-structure binary-searches binary-searches-interface
(open scheme
vector-utils)
(files vbinsearch))
(define-structure list-merge-sort list-merge-sort-interface
(open scheme
receiving
(subset signals (error)))
(files lmsort)
(optimize auto-integrate))
(define-structure vector-merge-sort vector-merge-sort-interface
(open scheme
receiving
vector-utils
vector-insertion-sort-internal)
(files vmsort)
(optimize auto-integrate))
(define-structure vector-heap-sort vector-heap-sort-interface
(open scheme
receiving
vector-utils)
(files vhsort)
(optimize auto-integrate))
(define-structures ((vector-insertion-sort vector-insertion-sort-interface)
(vector-insertion-sort-internal
vector-insertion-sort-internal-interface))
(open scheme
vector-utils)
(files visort)
(optimize auto-integrate))
(define-structure vector-utils (export vector-copy
vector-portion-copy
vector-portion-copy!
vector-start+end
vectors-start+end-2)
(open scheme)
(files vector-util))

26
scheme/sort/sort.scm Normal file
View File

@ -0,0 +1,26 @@
;;; The SRFI-32 sort package -- general sort & merge procedures
;;;
;;; Copyright (c) 1998 by Olin Shivers.
;;; You may do as you please with this code, as long as you do not delete this
;;; notice or hold me responsible for any outcome related to its use.
;;; Olin Shivers 10/98.
;;; This file just defines the general sort API in terms of some
;;; algorithm-specific calls.
(define (list-sort < l) ; Sort lists by converting to
(let ((v (list->vector l))) ; a vector and sorting that.
(heap-sort! < v)
(vector->list v)))
(define list-sort! list-merge-sort!)
(define list-stable-sort list-merge-sort)
(define list-stable-sort! list-merge-sort!)
(define vector-sort heap-sort)
(define vector-sort! heap-sort!)
(define vector-stable-sort vector-merge-sort)
(define vector-stable-sort! vector-merge-sort!)

1056
scheme/sort/sort.txt Normal file
View File

File diff suppressed because it is too large Load Diff

35
scheme/sort/sortp.scm Normal file
View File

@ -0,0 +1,35 @@
;;; The SRFI-?? sort package -- sorted predicates
;;; Olin Shivers 10/98.
;;;
;;; (list-sorted? < lis) -> boolean
;;; (vector-sorted? < v [start end]) -> boolean
(define (list-sorted? < list)
(or (not (pair? list))
(let lp ((prev (car list)) (tail (cdr list)))
(or (not (pair? tail))
(let ((next (car tail)))
(and (not (< next prev))
(lp next (cdr tail))))))))
(define (vector-sorted? elt< v . maybe-start+end)
(call-with-values
(lambda () (vector-start+end v maybe-start+end))
(lambda (start end)
(or (>= start end) ; Empty range
(let lp ((i (+ start 1)) (vi-1 (vector-ref v start)))
(or (>= i end)
(let ((vi (vector-ref v i)))
(and (not (elt< vi vi-1))
(lp (+ i 1) vi)))))))))
;;; Copyright and porting non-notices
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Give me a break. It's fifteen lines of code. I place this code in the
;;; public domain; help yourself.
;;;
;;; If your Scheme has a faster mechanism for handling optional arguments
;;; (e.g., Chez), you should definitely port over to it. Note that argument
;;; defaulting and error-checking are interleaved -- you don't have to
;;; error-check defaulted START/END args to see if they are fixnums that are
;;; legal vector indices for the corresponding vector, etc.

65
scheme/sort/test.scm Normal file
View File

@ -0,0 +1,65 @@
;;; Little test harness, 'cause I'm paraoid about tricky code.
;;; It's scsh specific -- Scheme 48 random-number stuff & the mail-notification
;;; stuff.
(define r (make-random 42))
(define (rand n) (modulo (r) n))
;;; For testing stable sort -- 3 & -3 compare the same.
(define (my< x y) (< (abs x) (abs y)))
(define (unstable-sort-test v) ; quick & heap vs simple insert
(let ((v1 (vector-copy v))
(v2 (vector-copy v))
(v3 (vector-copy v))
(v4 (vector-copy v)))
(quick-sort! < v1)
(quick-sort3! - v1)
(heap-sort! < v2)
(insert-sort! < v3)
(and (or (not (equal? v1 v2))
(not (equal? v1 v3))
(not (equal? v1 v4))
(not (vector-sorted? < v1)))
(list v v1 v2 v3 v4))))
(define (stable-sort-test v) ; insert, list & vector merge sorts
(let ((v1 (vector-copy v))
(v2 (vector-copy v))
(v3 (list->vector (list-merge-sort! my< (vector->list v))))
(v4 (list->vector (list-merge-sort my< (vector->list v)))))
(vector-merge-sort! my< v1)
(insert-sort! my< v2)
(and (or (not (equal? v1 v2))
(not (equal? v1 v3))
(not (equal? v1 v4))
(not (vector-sorted? my< v1)))
(list v v1 v2 v3 v4))))
(define (do-test max-size)
(let lp ((i 0))
(let ((i (cond ((= i 1000)
(write-char #\.)
(force-output)
0)
(else (+ i 1))))
(v (random-vector (rand max-size))))
(cond ((unstable-sort-test v) => (lambda (x) (cons 'u x)))
((stable-sort-test v) => (lambda (x) (cons 's x)))
(else (lp i))))))
(define (test-n-mail max-size)
(let ((losers (do-test max-size))
(email-address "shivers@cc.gatech.edu"))
(run (mail -s "sort lost" ,email-address) (<< ,losers))))
(define (random-vector size)
(let ((v (make-vector size)))
(fill-vector-randomly! v (* 10 size))
v))
(define (fill-vector-randomly! v range)
(let ((half (quotient range 2)))
(do ((i (- (vector-length v) 1) (- i 1)))
((< i 0))
(vector-set! v i (- (rand range) half)))))

34
scheme/sort/vbinsearch.scm Normal file
View File

@ -0,0 +1,34 @@
;;; The SRFI-32 sort package -- binary search -*- Scheme -*-
;;; Copyright (c) 1998 by Olin Shivers.
;;; This code is in the public domain.
;;; Olin Shivers 98/11
;;; Returns the index of the matching element.
;;; (vector-binary-search < car 4 '#((1 . one) (3 . three)
;;; (4 . four) (25 . twenty-five)))
;;; => 2
(define (vector-binary-search key< elt->key key v . maybe-start+end)
(call-with-values
(lambda () (vector-start+end v maybe-start+end))
(lambda (start end)
(let lp ((left start) (right end)) ; Search V[left,right).
(and (< left right)
(let* ((m (quotient (+ left right) 2))
(elt (vector-ref v m))
(elt-key (elt->key elt)))
(cond ((key< key elt-key) (lp left m))
((key< elt-key key) (lp (+ m 1) right))
(else m))))))))
(define (vector-binary-search3 compare v . maybe-start+end)
(call-with-values
(lambda () (vector-start+end v maybe-start+end))
(lambda (start end)
(let lp ((left start) (right end)) ; Search V[left,right).
(and (< left right)
(let* ((m (quotient (+ left right) 2))
(sign (compare (vector-ref v m))))
(cond ((> sign 0) (lp left m))
((< sign 0) (lp (+ m 1) right))
(else m))))))))

56
scheme/sort/vector-util.scm Normal file
View File

@ -0,0 +1,56 @@
(define (vector-portion-copy vec start end)
(let* ((len (vector-length vec))
(new-len (- end start))
(new (make-vector new-len)))
(do ((i start (+ i 1))
(j 0 (+ j 1)))
((= i end) new)
(vector-set! new j (vector-ref vec i)))))
(define (vector-copy vec)
(vector-portion-copy vec 0 (vector-length vec)))
(define (vector-portion-copy! target src start end)
(let ((len (- end start)))
(do ((i (- len 1) (- i 1))
(j (- end 1) (- j 1)))
((< i 0))
(vector-set! target i (vector-ref src j)))))
(define (has-element list index)
(cond
((zero? index)
(if (pair? list)
(values #t (car list))
(values #f #f)))
((null? list)
(values #f #f))
(else
(has-element (cdr list) (- index 1)))))
(define (list-ref-or-default list index default)
(call-with-values
(lambda () (has-element list index))
(lambda (has? maybe)
(if has?
maybe
default))))
(define (vector-start+end vector maybe-start+end)
(let ((start (list-ref-or-default maybe-start+end
0 0))
(end (list-ref-or-default maybe-start+end
1 (vector-length vector))))
(values start end)))
(define (vectors-start+end-2 vector-1 vector-2 maybe-start+end)
(let ((start-1 (list-ref-or-default maybe-start+end
0 0))
(end-1 (list-ref-or-default maybe-start+end
1 (vector-length vector-1)))
(start-2 (list-ref-or-default maybe-start+end
2 0))
(end-2 (list-ref-or-default maybe-start+end
3 (vector-length vector-2))))
(values start-1 end-1
start-2 end-2)))

117
scheme/sort/vhsort.scm Normal file
View File

@ -0,0 +1,117 @@
;;; The SRFI-32 sort package -- vector heap sort -*- Scheme -*-
;;; Copyright (c) 2002 by Olin Shivers.
;;; This code is open-source; see the end of the file for porting and
;;; more copyright information.
;;; Olin Shivers 10/98.
;;; Exports:
;;; (heap-sort! elt< v [start end]) -> unspecified
;;; (heap-sort elt< v [start end]) -> vector
;;; Two key facts
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; If a heap structure is embedded into a vector at indices [start,end), then:
;;; 1. The two children of index k are start + 2*(k-start) + 1 = k*2-start+1
;;; and start + 2*(k-start) + 2 = k*2-start+2.
;;;
;;; 2. The first index of a leaf node in the range [start,end) is
;;; first-leaf = floor[(start+end)/2]
;;; (You can deduce this from fact #1 above.)
;;; Any index before FIRST-LEAF is an internal node.
(define (really-heap-sort! elt< v start end)
;; Vector V contains a heap at indices [START,END). The heap is in heap
;; order in the range (I,END) -- i.e., every element in this range is >=
;; its children. Bubble HEAP[I] down into the heap to impose heap order on
;; the range [I,END).
(define (restore-heap! end i)
(let* ((vi (vector-ref v i))
(first-leaf (quotient (+ start end) 2)) ; Can fixnum overflow.
(final-k (let lp ((k i))
(if (>= k first-leaf)
k ; Leaf, so done.
(let* ((k*2-start (+ k (- k start))) ; Don't overflow.
(child1 (+ 1 k*2-start))
(child2 (+ 2 k*2-start))
(child1-val (vector-ref v child1)))
(receive (max-child max-child-val)
(if (< child2 end)
(let ((child2-val (vector-ref v child2)))
(if (elt< child2-val child1-val)
(values child1 child1-val)
(values child2 child2-val)))
(values child1 child1-val))
(cond ((elt< vi max-child-val)
(vector-set! v k max-child-val)
(lp max-child))
(else k)))))))) ; Done.
(vector-set! v final-k vi)))
;; Put the unsorted subvector V[start,end) into heap order.
(let ((first-leaf (quotient (+ start end) 2))) ; Can fixnum overflow.
(do ((i (- first-leaf 1) (- i 1)))
((< i start))
(restore-heap! end i)))
(do ((i (- end 1) (- i 1)))
((<= i start))
(let ((top (vector-ref v start)))
(vector-set! v start (vector-ref v i))
(vector-set! v i top)
(restore-heap! i start))))
;;; Here are the two exported interfaces.
(define (heap-sort! elt< v . maybe-start+end)
(call-with-values
(lambda () (vector-start+end v maybe-start+end))
(lambda (start end)
(really-heap-sort! elt< v start end))))
(define (heap-sort elt< v . maybe-start+end)
(call-with-values
(lambda () (vector-start+end v maybe-start+end))
(lambda (start end)
(let ((ans (vector-portion-copy v start end)))
(really-heap-sort! elt< ans 0 (- end start))
ans))))
;;; Notes on porting
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Bumming the code for speed
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; If you can use a module system to lock up the internal function
;;; REALLY-HEAP-SORT! so that it can only be called from HEAP-SORT and
;;; HEAP-SORT!, then you can hack the internal functions to run with no safety
;;; checks. The safety checks performed by the exported functions HEAP-SORT &
;;; HEAP-SORT! guarantee that there will be no type errors or array-indexing
;;; errors. In addition, with the exception of the two computations of
;;; FIRST-LEAF, all arithmetic will be fixnum arithmetic that never overflows
;;; into bignums, assuming your Scheme provides that you can't allocate an
;;; array so large you might need a bignum to index an element, which is
;;; definitely the case for every implementation with which I am familiar.
;;;
;;; If you want to code up the first-leaf = (quotient (+ s e) 2) computation
;;; so that it will never fixnum overflow when S & E are fixnums, you can do
;;; it this way:
;;; - compute floor(e/2), which throws away e's low-order bit.
;;; - add e's low-order bit to s, and divide that by two:
;;; floor[(s + e mod 2) / 2]
;;; - add these two parts together.
;;; giving you
;;; (+ (quotient e 2)
;;; (quotient (+ s (modulo e 2)) 2))
;;; If we know that e & s are fixnums, and that 0 <= s <= e, then this
;;; can only fixnum-overflow when s = e = max-fixnum. Note that the
;;; two divides and one modulo op can be done very quickly with two
;;; right-shifts and a bitwise and.
;;;
;;; I suspect there has never been a heapsort written in the history of
;;; the world in C that got this detail right.
;;;
;;; If your Scheme has a faster mechanism for handling optional arguments
;;; (e.g., Chez), you should definitely port over to it. Note that argument
;;; defaulting and error-checking are interleaved -- you don't have to
;;; error-check defaulted START/END args to see if they are fixnums that are
;;; legal vector indices for the corresponding vector, etc.

76
scheme/sort/visort.scm Normal file
View File

@ -0,0 +1,76 @@
;;; The SRFI-?? sort package -- stable vector insertion sort -*- Scheme -*-
;;; Copyright (c) 1998 by Olin Shivers.
;;; This code is open-source; see the end of the file for porting and
;;; more copyright information.
;;; Olin Shivers 10/98.
;;; Exports:
;;; insert-sort < v [start end] -> vector
;;; insert-sort! < v [start end] -> unspecific
;;;
;;; %insert-sort! is also called from vqsort.scm's quick-sort function.
(define (insert-sort elt< v . maybe-start+end)
(call-with-values
(lambda () (vector-start+end v maybe-start+end))
(lambda (start end)
(let ((ans (vector-portion-copy v start end)))
(%insert-sort! elt< ans 0 (- end start))
ans))))
(define (insert-sort! < v . maybe-start+end)
(call-with-values
(lambda () (vector-start+end v maybe-start+end))
(lambda (start end)
(%insert-sort! < v start end))))
(define (%insert-sort! elt< v start end)
(do ((i (+ 1 start) (+ i 1))) ; Invariant: [start,i) is sorted.
((>= i end))
(let ((val (vector-ref v i)))
(vector-set! v (let lp ((j i)) ; J is the location of the
(if (<= j start)
start ; "hole" as it bubbles down.
(let* ((j-1 (- j 1))
(vj-1 (vector-ref v j-1)))
(cond ((elt< val vj-1)
(vector-set! v j vj-1)
(lp j-1))
(else j)))))
val))))
;;; Copyright
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code is
;;; Copyright (c) 1998 by Olin Shivers.
;;; The terms are: You may do as you please with this code, as long as
;;; you do not delete this notice or hold me responsible for any outcome
;;; related to its use.
;;;
;;; Blah blah blah. Don't you think source files should contain more lines
;;; of code than copyright notice?
;;; Code tuning & porting
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; This code is tightly bummed as far as I can go in portable Scheme.
;;;
;;; The code can be converted to use unsafe vector-indexing and
;;; fixnum-specific arithmetic ops -- the safety checks done on entry to
;;; INSERT-SORT and INSERT-SORT! are sufficient to guarantee nothing bad will
;;; happen. However, note that if you alter %INSERT-SORT! to use dangerous
;;; primitives, you must ensure it is only called from clients that guarantee
;;; to observe its preconditions. In the SRFI-?? reference implementation,
;;; %INSERT-SORT! is only called from INSERT-SORT! and the quick-sort code in
;;; vqsort.scm, and the preconditions are guaranteed for these two clients.
;;; This should provide *big* speedups. In fact, all the code bumming I've
;;; done pretty much disappears in the noise unless you have a good compiler
;;; and also can dump the vector-index checks and generic arithmetic -- so
;;; I've really just set things up for you to exploit.
;;;
;;; If your Scheme has a faster mechanism for handling optional arguments
;;; (e.g., Chez), you should definitely port over to it. Note that argument
;;; defaulting and error-checking are interleaved -- you don't have to
;;; error-check defaulted START/END args to see if they are fixnums that are
;;; legal vector indices for the corresponding vector, etc.

238
scheme/sort/vmsort.scm Normal file
View File

@ -0,0 +1,238 @@
;;; The SRFI-32 sort package -- stable vector merge & merge sort -*- Scheme -*-
;;; Copyright (c) 1998 by Olin Shivers.
;;; This code is open-source; see the end of the file for porting and
;;; more copyright information.
;;; Olin Shivers 10/98.
;;; Exports:
;;; (vector-merge < v1 v2 [start1 end1 start2 end2]) -> vector
;;; (vector-merge! < v v1 v2 [start0 start1 end1 start2 end2]) -> unspecific
;;;
;;; (vector-merge-sort < v [start end temp]) -> vector
;;; (vector-merge-sort! < v [start end temp]) -> unspecific
;;; Merge
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (vector-merge < v1 v2 [start1 end1 start2 end2]) -> vector
;;; (vector-merge! < v v1 v2 [start start1 end1 start2 end2]) -> unspecific
;;;
;;; Stable vector merge -- V1's elements come out ahead of equal V2 elements.
(define (vector-merge < v1 v2 . maybe-starts+ends)
(call-with-values
(lambda () (vectors-start+end-2 v1 v2 maybe-starts+ends))
(lambda (start1 end1 start2 end2)
(let ((ans (make-vector (+ (- end1 start1) (- end2 start2)))))
(%vector-merge! < ans v1 v2 0 start1 end1 start2 end2)
ans))))
(define (vector-merge! < v v1 v2 . maybe-starts+ends)
(call-with-values
(lambda ()
(if (pair? maybe-starts+ends)
(values (car maybe-starts+ends)
(cdr maybe-starts+ends))
(values 0
'())))
(lambda (start rest)
(call-with-values
(lambda () (vectors-start+end-2 v1 v2 rest))
(lambda (start1 end1 start2 end2)
(%vector-merge! < v v1 v2 start start1 end1 start2 end2))))))
;;; This routine is not exported. The code is tightly bummed.
;;;
;;; If these preconditions hold, the routine can be bummed to run with
;;; unsafe vector-indexing and fixnum arithmetic ops:
;;; - V V1 V2 are vectors.
;;; - START0 START1 END1 START2 END2 are fixnums.
;;; - (<= 0 START0 END0 (vector-length V),
;;; where end0 = start0 + (end1 - start1) + (end2 - start2)
;;; - (<= 0 START1 END1 (vector-length V1))
;;; - (<= 0 START2 END2 (vector-length V2))
;;; If you put these error checks in the two client procedures above, you can
;;; safely convert this procedure to use unsafe ops -- which is why it isn't
;;; exported. This will provide *huge* speedup.
(define (%vector-merge! elt< v v1 v2 start start1 end1 start2 end2)
(letrec ((vblit (lambda (fromv j i end) ; Blit FROMV[J,END) to V[I,?].
(let lp ((j j) (i i))
(vector-set! v i (vector-ref fromv j))
(let ((j (+ j 1)))
(if (< j end) (lp j (+ i 1))))))))
(cond ((<= end1 start1) (if (< start2 end2) (vblit v2 start2 start)))
((<= end2 start2) (vblit v1 start1 start))
;; Invariants: I is next index of V to write; X = V1[J]; Y = V2[K].
(else (let lp ((i start)
(j start1) (x (vector-ref v1 start1))
(k start2) (y (vector-ref v2 start2)))
(let ((i1 (+ i 1))) ; "i+1" is a complex number in R4RS!
(if (elt< y x)
(let ((k (+ k 1)))
(vector-set! v i y)
(if (< k end2)
(lp i1 j x k (vector-ref v2 k))
(vblit v1 j i1 end1)))
(let ((j (+ j 1)))
(vector-set! v i x)
(if (< j end1)
(vblit v2 k i1 end2)
(lp i1 j (vector-ref v1 j) k y))))))))))
;;; (vector-merge-sort < v [start end temp]) -> vector
;;; (vector-merge-sort! < v [start end temp]) -> unspecific
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Stable natural vector merge sort
(define (vector-merge-sort! < v . maybe-args)
(call-with-values
(lambda () (vector-start+end v maybe-args))
(lambda (start end)
(let ((temp (if (and (pair? maybe-args) ; kludge
(pair? (cdr maybe-args))
(pair? (cddr maybe-args)))
(caddr maybe-args)
(vector-copy v))))
(%vector-merge-sort! < v start end temp)))))
(define (vector-merge-sort < v . maybe-args)
(let ((ans (vector-copy v)))
(apply vector-merge-sort! < ans maybe-args)
ans))
;;; %VECTOR-MERGE-SORT! is not exported.
;;; Preconditions:
;;; V TEMP vectors
;;; START END fixnums
;;; START END legal indices for V and TEMP
;;; If these preconditions are ensured by the cover functions, you
;;; can safely change this code to use unsafe fixnum arithmetic and vector
;;; indexing ops, for *huge* speedup.
;;; This merge sort is "opportunistic" -- the leaves of the merge tree are
;;; contiguous runs of already sorted elements in the vector. In the best
;;; case -- an already sorted vector -- it runs in linear time. Worst case
;;; is still O(n lg n) time.
(define (%vector-merge-sort! elt< v0 l r temp0)
(define (xor a b) (not (eq? a b)))
;; Merge v1[l,l+len1) and v2[l+len1,l+len1+len2) into target[l,l+len1+len2)
;; Merge left-to-right, so that TEMP may be either V1 or V2
;; (that this is OK takes a little bit of thought).
;; V2=TARGET? is true if V2 and TARGET are the same, which allows
;; merge to punt the final blit half of the time.
(define (merge target v1 v2 l len1 len2 v2=target?)
(letrec ((vblit (lambda (fromv j i end) ; Blit FROMV[J,END) to TARGET[I,?]
(let lp ((j j) (i i)) ; J < END. The final copy.
(vector-set! target i (vector-ref fromv j))
(let ((j (+ j 1)))
(if (< j end) (lp j (+ i 1))))))))
(let* ((r1 (+ l len1))
(r2 (+ r1 len2)))
; Invariants:
(let lp ((n l) ; N is next index of
(j l) (x (vector-ref v1 l)) ; TARGET to write.
(k r1) (y (vector-ref v2 r1))) ; X = V1[J]
(let ((n+1 (+ n 1))) ; Y = V2[K]
(if (elt< y x)
(let ((k (+ k 1)))
(vector-set! target n y)
(if (< k r2)
(lp n+1 j x k (vector-ref v2 k))
(vblit v1 j n+1 r1)))
(let ((j (+ j 1)))
(vector-set! target n x)
(if (< j r1)
(lp n+1 j (vector-ref v1 j) k y)
(if (not v2=target?) (vblit v2 k n+1 r2))))))))))
;; Might hack GETRUN so that if the run is short it pads it out to length
;; 10 with insert sort...
;; Precondition: l < r.
(define (getrun v l r)
(let lp ((i (+ l 1)) (x (vector-ref v l)))
(if (>= i r)
(- i l)
(let ((y (vector-ref v i)))
(if (elt< y x)
(- i l)
(lp (+ i 1) y))))))
;; RECUR: Sort V0[L,L+LEN) for some LEN where 0 < WANT <= LEN <= (R-L).
;; That is, sort *at least* WANT elements in V0 starting at index L.
;; May put the result into either V0[L,L+LEN) or TEMP0[L,L+LEN).
;; Must not alter either vector outside this range.
;; Return:
;; - LEN -- the number of values we sorted
;; - ANSVEC -- the vector holding the value
;; - ANS=V0? -- tells if ANSVEC is V0 or TEMP
;;
;; LP: V[L,L+PFXLEN) holds a sorted prefix of V0.
;; TEMP = if V = V0 then TEMP0 else V0. (I.e., TEMP is the other vec.)
;; PFXLEN2 is a power of 2 <= PFXLEN.
;; Solve RECUR's problem.
(if (< l r) ; Don't try to sort an empty range.
(receive (ignored-len ignored-ansvec ansvec=v0?)
(let recur ((l l) (want (- r l)))
(let ((len (- r l)))
(let lp ((pfxlen (getrun v0 l r)) (pfxlen2 1)
(v v0) (temp temp0)
(v=v0? #t))
(if (or (>= pfxlen want) (= pfxlen len))
(values pfxlen v v=v0?)
(let ((pfxlen2 (let lp ((j pfxlen2))
(let ((j*2 (+ j j)))
(if (<= j pfxlen) (lp j*2) j))))
(tail-len (- len pfxlen)))
;; PFXLEN2 is now the largest power of 2 <= PFXLEN.
;; (Just think of it as being roughly PFXLEN.)
(receive (nr-len nr-vec nrvec=v0?)
(recur (+ pfxlen l) pfxlen2)
(merge temp v nr-vec l pfxlen nr-len
(xor nrvec=v0? v=v0?))
(lp (+ pfxlen nr-len) (+ pfxlen2 pfxlen2)
temp v (not v=v0?))))))))
(if (not ansvec=v0?) (vector-portion-copy! v0 temp0 l r)))))
;;; Copyright
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code is
;;; Copyright (c) 1998 by Olin Shivers.
;;; The terms are: You may do as you please with this code, as long as
;;; you do not delete this notice or hold me responsible for any outcome
;;; related to its use.
;;;
;;; Blah blah blah. Don't you think source files should contain more lines
;;; of code than copyright notice?
;;; Code tuning & porting
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code is *tightly* bummed as far as I can go in portable Scheme.
;;;
;;; The two internal primitives that do the real work can be converted to
;;; use unsafe vector-indexing and fixnum-specific arithmetic ops *if* you
;;; alter the four small cover functions to enforce the invariants. This should
;;; provide *big* speedups. In fact, all the code bumming I've done pretty
;;; much disappears in the noise unless you have a good compiler and also
;;; can dump the vector-index checks and generic arithmetic -- so I've really
;;; just set things up for you to exploit.
;;;
;;; The optional-arg parsing, defaulting, and error checking is done with a
;;; portable R4RS macro. But if your Scheme has a faster mechanism (e.g.,
;;; Chez), you should definitely port over to it. Note that argument defaulting
;;; and error-checking are interleaved -- you don't have to error-check
;;; defaulted START/END args to see if they are fixnums that are legal vector
;;; indices for the corresponding vector, etc.

20
scheme/srfi/srfi-1.scm
View File

@ -1027,6 +1027,26 @@
;;; We extend MAP to handle arguments of unequal length.
(define map map-in-order)
;;; Apply F across lists, guaranteeing to go left-to-right.
;;; NOTE: Some implementations of R5RS MAP are compliant with this spec;
;;; in which case this procedure may simply be defined as a synonym for FOR-EACH.
(define (for-each f lis1 . lists)
(check-arg procedure? f for-each)
(if (pair? lists)
(let recur ((lists (cons lis1 lists)))
(receive (cars cdrs) (%cars+cdrs lists)
(if (pair? cars)
(begin
(apply f cars) ; Do head first,
(recur cdrs))))) ; then tail.
;; Fast path.
(let recur ((lis lis1))
(if (not (null-list? lis))
(begin
(f (car lis)) ; Do head first,
(recur (cdr lis))))))) ; then tail.
;;; filter, remove, partition
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

94
scheme/srfi/srfi-13.scm
View File

@ -1365,30 +1365,38 @@
;;; comparison testing with fancier implementations.
;;; See below for fast KMP version.
;(define (string-contains string substring . maybe-starts+ends)
; (let-string-start+end2 (start1 end1 start2 end2)
; string-contains string substring maybe-starts+ends
; (let* ((len (- end2 start2))
; (i-bound (- end1 len)))
; (let lp ((i start1))
; (and (< i i-bound)
; (if (string= string substring i (+ i len) start2 end2)
; i
; (lp (+ i 1))))))))
;;; Searching for an occurrence of a substring
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (%string-contains string substring start1 end1 start2 end2 the-string=)
(let* ((len (- end2 start2))
(i-bound (- end1 len)))
(let lp ((i start1))
(and (<= i i-bound)
(if (the-string= string substring i (+ i len) start2 end2)
i
(lp (+ i 1)))))))
(define (string-contains text pattern . maybe-starts+ends)
(let-string-start+end2 (t-start t-end p-start p-end)
string-contains text pattern maybe-starts+ends
(%kmp-search pattern text char=? p-start p-end t-start t-end)))
(%string-contains text pattern t-start t-end p-start p-end string=)))
(define (string-contains-ci text pattern . maybe-starts+ends)
(let-string-start+end2 (t-start t-end p-start p-end)
string-contains-ci text pattern maybe-starts+ends
(%kmp-search pattern text char-ci=? p-start p-end t-start t-end)))
(%string-contains text pattern t-start t-end p-start p-end string-ci=)))
;;; Searching for an occurrence of a substring
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Broken, see http://srfi.schemers.org/srfi-13/post-mail-archive/msg00003.html
; (define (string-contains text pattern . maybe-starts+ends)
; (let-string-start+end2 (t-start t-end p-start p-end)
; string-contains text pattern maybe-starts+ends
; (%kmp-search pattern text char=? p-start p-end t-start t-end)))
; (define (string-contains-ci text pattern . maybe-starts+ends)
; (let-string-start+end2 (t-start t-end p-start p-end)
; string-contains-ci text pattern maybe-starts+ends
; (%kmp-search pattern text char-ci=? p-start p-end t-start t-end)))
;;; Knuth-Morris-Pratt string searching
@ -1705,7 +1713,7 @@
;; string starts.
(let lp ((len 0) (nzlist #f) (lis string-list))
(if (pair? lis)
(let ((slen (string-length (car string-list))))
(let ((slen (string-length (car lis))))
(lp (+ len slen)
(if (or nzlist (zero? slen)) nzlist lis)
(cdr lis)))
@ -2045,36 +2053,36 @@
;;; details.
;;; -Olin Shivers
;;; MIT Scheme copyright terms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This material was developed by the Scheme project at the Massachusetts
;;; Institute of Technology, Department of Electrical Engineering and
;;; Computer Science. Permission to copy and modify this software, to
;;; redistribute either the original software or a modified version, and
;;; to use this software for any purpose is granted, subject to the
;;; following restrictions and understandings.
;;; The MIT Scheme project gave Olin Shivers the permission to use the
;;; code from this SRFI under the following license:
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions are
;;; met:
;;;
;;; 1. Any copy made of this software must include this copyright notice
;;; in full.
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;;
;;; 2. Users of this software agree to make their best efforts (a) to
;;; return to the MIT Scheme project any improvements or extensions that
;;; they make, so that these may be included in future releases; and (b)
;;; to inform MIT of noteworthy uses of this software.
;;; 2. Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials provided
;;; with the distribution.
;;;
;;; 3. All materials developed as a consequence of the use of this
;;; software shall duly acknowledge such use, in accordance with the usual
;;; standards of acknowledging credit in academic research.
;;; 3. The name of the author may not be used to endorse or promote
;;; products derived from this software without specific prior
;;; written permission.
;;;
;;; 4. MIT has made no warrantee or representation that the operation of
;;; this software will be error-free, and MIT is under no obligation to
;;; provide any services, by way of maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this material,
;;; there shall be no use of the name of the Massachusetts Institute of
;;; Technology nor of any adaptation thereof in any advertising,
;;; promotional, or sales literature without prior written consent from
;;; MIT in each case.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;;; DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT,
;;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
;;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
;;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
;;; IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;; POSSIBILITY OF SUCH DAMAGE.
;;; Scsh copyright terms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

71
scheme/srfi/srfi-14.scm
View File

@ -10,6 +10,22 @@
;;; Copyright (c) 1988-1995 Massachusetts Institute of Technology
;;; The MIT Scheme license is a "free software" license. See the end of
;;; this file for the tedious details.
;;;
;;;
;;; On 16 Dec 2003, Olin added the following comment in a private email
;;; to Mike Sperber, Jonathan Rees and Martin Gasbichler:
;;;
;;; This code has nothing in common w/the MIT code. Just check it out.
;;; The only connection is (1) some of the API design and (2) the basic
;;; data-structure (a 256-elt string of \000 & non-\000 chars), which is
;;; obvious art. I was being overly generous when I included the MIT copyright.
;;; The system was completely rewritten for the 2000 SRFI reference version;
;;; I should have removed the MIT notices then. In particular, as a casual
;;; examination will show, the implementation of the common API is *quite*
;;; different -- I don't even mean at the in-the-small level, but at the
;;; medium-level architectural/structural details.
;;; Exports:
;;; char-set? char-set= char-set<=
@ -516,7 +532,7 @@
base-cs)
;;; {string, char, char-set, char predicate} -> char-set
;;; {string, char, char-set} -> char-set
(define (x->char-set x)
(cond ((char-set? x) x)
@ -867,35 +883,34 @@
;;; save calling overhead and enable procedure integration -- but they
;;; are not appropriate for exported routines.
;;; Copyright notice
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Copyright (c) 1988-1995 Massachusetts Institute of Technology
;;; The MIT Scheme project gave Olin Shivers the permission to use the
;;; code from this SRFI under the following license:
;;;
;;; This material was developed by the Scheme project at the Massachusetts
;;; Institute of Technology, Department of Electrical Engineering and
;;; Computer Science. Permission to copy and modify this software, to
;;; redistribute either the original software or a modified version, and
;;; to use this software for any purpose is granted, subject to the
;;; following restrictions and understandings.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions are
;;; met:
;;;
;;; 1. Any copy made of this software must include this copyright notice
;;; in full.
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;;
;;; 2. Users of this software agree to make their best efforts (a) to
;;; return to the MIT Scheme project any improvements or extensions that
;;; they make, so that these may be included in future releases; and (b)
;;; to inform MIT of noteworthy uses of this software.
;;; 2. Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials provided
;;; with the distribution.
;;;
;;; 3. All materials developed as a consequence of the use of this
;;; software shall duly acknowledge such use, in accordance with the usual
;;; standards of acknowledging credit in academic research.
;;; 3. The name of the author may not be used to endorse or promote
;;; products derived from this software without specific prior
;;; written permission.
;;;
;;; 4. MIT has made no warrantee or representation that the operation of
;;; this software will be error-free, and MIT is under no obligation to
;;; provide any services, by way of maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this material,
;;; there shall be no use of the name of the Massachusetts Institute of
;;; Technology nor of any adaptation thereof in any advertising,
;;; promotional, or sales literature without prior written consent from
;;; MIT in each case.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;;; DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT,
;;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
;;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
;;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
;;; IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;; POSSIBILITY OF SUCH DAMAGE.

124
scheme/srfi/srfi-19.scm
View File

@ -145,9 +145,9 @@
(define (tm:time-error caller type value)
(if (member type tm:time-error-types)
(if value
(error caller "TIME-ERROR type ~S: ~S" type value)
(error caller "TIME-ERROR type ~S" type))
(error caller "TIME-ERROR unsupported error type ~S" type)))
(error caller "TIME-ERROR type" type value)
(error caller "TIME-ERROR type" type))
(error caller "TIME-ERROR unsupported error type" type)))
;; A table of leap seconds
@ -159,24 +159,24 @@
;; & open-input-string
;; ie (set! tm:leap-second-table (tm:read-tai-utc-date "tai-utc.dat"))
(define (tm:read-tai-utc-data filename)
(define (convert-jd jd)
(* (- (inexact->exact jd) tm:tai-epoch-in-jd) tm:sid))
(define (convert-sec sec)
(inexact->exact sec))
(let ( (port (open-input-file filename))
(table '()) )
(let loop ((line (read-line port)))
(if (not (eof-object? line))
(begin
(let* ( (data (read (open-input-string (string-append "(" line ")"))))
(year (car data))
(jd (cadddr (cdr data)))
(secs (cadddr (cdddr data))) )
(if (>= year 1972)
(set! table (cons (cons (convert-jd jd) (convert-sec secs)) table)))
(loop (read-line port))))))
table))
; (define (tm:read-tai-utc-data filename)
; (define (convert-jd jd)
; (* (- (inexact->exact jd) tm:tai-epoch-in-jd) tm:sid))
; (define (convert-sec sec)
; (inexact->exact sec))
; (let ( (port (open-input-file filename))
; (table '()) )
; (let loop ((line (read-line port)))
; (if (not (eof-object? line))
; (begin
; (let* ( (data (read (open-input-string (string-append "(" line ")"))))
; (year (car data))
; (jd (cadddr (cdr data)))
; (secs (cadddr (cdddr data))) )
; (if (>= year 1972)
; (set! table (cons (cons (convert-jd jd) (convert-sec secs)) table)))
; (loop (read-line port))))))
; table))
;; each entry is ( utc seconds since epoch . # seconds to add for tai )
;; note they go higher to lower, and end in 1972.
@ -205,9 +205,9 @@
(78796800 . 11)
(63072000 . 10)))
(define (read-leap-second-table filename)
(set! tm:leap-second-table (tm:read-tai-utc-data filename))
(values))
; (define (read-leap-second-table filename)
; (set! tm:leap-second-table (tm:read-tai-utc-data filename))
; (values))
(define (tm:leap-second-delta utc-seconds)
@ -302,14 +302,9 @@
(define (tm:current-time-thread)
(tm:time-error 'current-time 'unsupported-clock-type 'time-thread))
;; SCSH portability: use cpu-ticks/sec
;; Scheme48 portability: no process time in Scheme48 (regeression from SCSH)
(define (tm:current-time-process)
(let ((ticks/s (cpu-ticks/sec)))
(receive (userticks systicks childuserticks childsysticks) (process-times)
(make-time time-process
(* (remainder userticks ticks/s) (/ tm:nano ticks/s))
(quotient userticks ticks/s)))))
(tm:time-error 'current-time 'unsupported-clock-type 'time-gc))
;; SCSH portability: GC time not available in scsh
(define (tm:current-time-gc)
@ -632,16 +627,17 @@
(else
(tm:char-pos char str (+ index 1) len))))
(define (tm:split-real r)
(if (integer? r)
(values r 0)
(let ((str (number->string (exact->inexact r))))
(let ((ppos (tm:char-pos #\. str 0 (string-length str))))
(if ppos
(values
(string->number (substring str 0 ppos))
(string->number (substring str (+ ppos 1) (string-length str))))
(values r 0))))))
;; return a string representing the decimal expansion of the fractional
;; portion of a number, limited by a specified precision
(define (tm:decimal-expansion r precision)
(let loop ((num (- r (round r)))
(p precision))
(if (or (= p 0) (= num 0))
""
(let* ((num-times-10 (* 10 num))
(round-num-times-10 (round num-times-10)))
(string-append (number->string (inexact->exact round-num-times-10))
(loop (- num-times-10 round-num-times-10) (- p 1)))))))
;; gives the seconds/date/month/year
(define (tm:decode-julian-day-number jdn)
@ -667,7 +663,7 @@
;; SCSH portability: use scsh's DATE procedure
(define (tm:local-tz-offset)
(date:tz-secs (date)))
0) ;; FIXME: quick hack
;; special thing -- ignores nanos
(define (tm:time->julian-day-number seconds tz-offset)
@ -822,22 +818,21 @@
(define (date->julian-day date)
(let ( (nanosecond (date-nanosecond date))
(second (date-second date))
(minute (date-minute date))
(hour (date-hour date))
(day (date-day date))
(month (date-month date))
(year (date-year date))
(offset (date-zone-offset date)) )
(second (date-second date))
(minute (date-minute date))
(hour (date-hour date))
(day (date-day date))
(month (date-month date))
(year (date-year date))
(offset (date-zone-offset date)) )
(+ (tm:encode-julian-day-number day month year)
(- 1/2)
;; SCSH portability: use binary /
(+ (/ (/ (+ (* hour 60 60)
(* minute 60)
second
(/ nanosecond tm:nano))
tm:sid)
(- offset))))))
(+ (/ (+ (* hour 60 60)
(* minute 60)
second
(/ nanosecond tm:nano)
(- offset))
tm:sid)))))
(define (date->modified-julian-day date)
(- (date->julian-day date)
@ -1046,17 +1041,11 @@
(display (tm:padding (date-second date)
pad-with 2)
port))
(receive (i f)
;;; SCSH portability: make use of / binary
(tm:split-real (/
(date-nanosecond date)
(* tm:nano 1.0)))
(let* ((ns (number->string f))
(le (string-length ns)))
(if (> le 2)
(begin
(display tm:locale-number-separator port)
(display (substring ns 2 le) port)))))))
(let* ((f (tm:decimal-expansion (/ (date-nanosecond date) tm:nano) 9)))
(if (> (string-length f) 0)
(begin
(display tm:locale-number-separator port)
(display f port))))))
(cons #\h (lambda (date pad-with port)
(display (date->string date "~b") port)))
(cons #\H (lambda (date pad-with port)
@ -1486,4 +1475,3 @@
(if (tm:date-ok? newdate)
newdate
(tm:time-error 'string->date 'bad-date-format-string (list "Incomplete date read. " newdate template-string)))))

956
scheme/srfi/srfi-42.scm Normal file
View File

@ -0,0 +1,956 @@
; <PLAINTEXT>
; Eager Comprehensions in [outer..inner|expr]-Convention
; ======================================================
;
; sebastian.egner@philips.com, Eindhoven, The Netherlands, Feb-2003.
; Scheme R5RS (incl. macros), SRFI-23 (error).
;
; Loading the implementation into Scheme48 0.57:
; ,open srfi-23
; ,load ec.scm
;
; Loading the implementation into PLT/DrScheme 202:
; ; File > Open ... "ec.scm", click Execute
;
; Loading the implementation into SCM 5d7:
; (require 'macro) (require 'record)
; (load "ec.scm")
;
; Implementation comments:
; * All local (not exported) identifiers are named ec-<something>.
; * This implementation focuses on portability, performance,
; readability, and simplicity roughly in this order. Design
; decisions related to performance are taken for Scheme48.
; * Alternative implementations, Comments and Warnings are
; mentioned after the definition with a heading.
; ==========================================================================
; The fundamental comprehension do-ec
; ==========================================================================
;
; All eager comprehensions are reduced into do-ec and
; all generators are reduced to :do.
;
; We use the following short names for syntactic variables
; q - qualifier
; cc - current continuation, thing to call at the end;
; the CPS is (m (cc ...) arg ...) -> (cc ... expr ...)
; cmd - an expression being evaluated for its side-effects
; expr - an expression
; gen - a generator of an eager comprehension
; ob - outer binding
; oc - outer command
; lb - loop binding
; ne1? - not-end1? (before the payload)
; ib - inner binding
; ic - inner command
; ne2? - not-end2? (after the payload)
; ls - loop step
; etc - more arguments of mixed type
; (do-ec q ... cmd)
; handles nested, if/not/and/or, begin, :let, and calls generator
; macros in CPS to transform them into fully decorated :do.
; The code generation for a :do is delegated to do-ec:do.
(define-syntax do-ec
(syntax-rules (nested if not and or begin :do let)
; explicit nesting -> implicit nesting
((do-ec (nested q ...) etc ...)
(do-ec q ... etc ...) )
; implicit nesting -> fold do-ec
((do-ec q1 q2 etc1 etc ...)
(do-ec q1 (do-ec q2 etc1 etc ...)) )
; no qualifiers at all -> evaluate cmd once
((do-ec cmd)
(begin cmd (if #f #f)) )
; now (do-ec q cmd) remains
; filter -> make conditional
((do-ec (if test) cmd)
(if test (do-ec cmd)) )
((do-ec (not test) cmd)
(if (not test) (do-ec cmd)) )
((do-ec (and test ...) cmd)
(if (and test ...) (do-ec cmd)) )
((do-ec (or test ...) cmd)
(if (or test ...) (do-ec cmd)) )
; begin -> make a sequence
((do-ec (begin etc ...) cmd)
(begin etc ... (do-ec cmd)) )
; fully decorated :do-generator -> delegate to do-ec:do
((do-ec (:do olet lbs ne1? ilet ne2? lss) cmd)
(do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss)) )
; anything else -> call generator-macro in CPS; reentry at (*)
((do-ec (g arg1 arg ...) cmd)
(g (do-ec:do cmd) arg1 arg ...) )))
; (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss)
; generates code for a single fully decorated :do-generator
; with cmd as payload, taking care of special cases.
(define-syntax do-ec:do
(syntax-rules (:do let)
; reentry point (*) -> generate code
((do-ec:do cmd
(:do (let obs oc ...)
lbs
ne1?
(let ibs ic ...)
ne2?
(ls ...) ))
(ec-simplify
(let obs
oc ...
(let loop lbs
(ec-simplify
(if ne1?
(ec-simplify
(let ibs
ic ...
cmd
(ec-simplify
(if ne2?
(loop ls ...) )))))))))) ))
; (ec-simplify <expression>)
; generates potentially more efficient code for <expression>.
; The macro handles if, (begin <command>*), and (let () <command>*)
; and takes care of special cases.
(define-syntax ec-simplify
(syntax-rules (if not let begin)
; one- and two-sided if
; literal <test>
((ec-simplify (if #t consequent))
consequent )
((ec-simplify (if #f consequent))
(if #f #f) )
((ec-simplify (if #t consequent alternate))
consequent )
((ec-simplify (if #f consequent alternate))
alternate )
; (not (not <test>))
((ec-simplify (if (not (not test)) consequent))
(ec-simplify (if test consequent)) )
((ec-simplify (if (not (not test)) consequent alternate))
(ec-simplify (if test consequent alternate)) )
; (let () <command>*)
; empty <binding spec>*
((ec-simplify (let () command ...))
(ec-simplify (begin command ...)) )
; begin
; flatten use helper (ec-simplify 1 done to-do)
((ec-simplify (begin command ...))
(ec-simplify 1 () (command ...)) )
((ec-simplify 1 done ((begin to-do1 ...) to-do2 ...))
(ec-simplify 1 done (to-do1 ... to-do2 ...)) )
((ec-simplify 1 (done ...) (to-do1 to-do ...))
(ec-simplify 1 (done ... to-do1) (to-do ...)) )
; exit helper
((ec-simplify 1 () ())
(if #f #f) )
((ec-simplify 1 (command) ())
command )
((ec-simplify 1 (command1 command ...) ())
(begin command1 command ...) )
; anything else
((ec-simplify expression)
expression )))
; ==========================================================================
; The special generators :do, :let, :parallel, :while, and :until
; ==========================================================================
(define-syntax :do
(syntax-rules ()
; full decorated -> continue with cc, reentry at (*)
((:do (cc ...) olet lbs ne1? ilet ne2? lss)
(cc ... (:do olet lbs ne1? ilet ne2? lss)) )
; short form -> fill in default values
((:do cc lbs ne1? lss)
(:do cc (let ()) lbs ne1? (let ()) #t lss) )))
(define-syntax :let
(syntax-rules (index)
((:let cc var (index i) expression)
(:do cc (let ((var expression) (i 0))) () #t (let ()) #f ()) )
((:let cc var expression)
(:do cc (let ((var expression))) () #t (let ()) #f ()) )))
(define-syntax :parallel
(syntax-rules (:do)
((:parallel cc)
cc )
((:parallel cc (g arg1 arg ...) gen ...)
(g (:parallel-1 cc (gen ...)) arg1 arg ...) )))
; (:parallel-1 cc (to-do ...) result [ next ] )
; iterates over to-do by converting the first generator into
; the :do-generator next and merging next into result.
(define-syntax :parallel-1 ; used as
(syntax-rules (:do let)
; process next element of to-do, reentry at (**)
((:parallel-1 cc ((g arg1 arg ...) gen ...) result)
(g (:parallel-1 cc (gen ...) result) arg1 arg ...) )
; reentry point (**) -> merge next into result
((:parallel-1
cc
gens
(:do (let (ob1 ...) oc1 ...)
(lb1 ...)
ne1?1
(let (ib1 ...) ic1 ...)
ne2?1
(ls1 ...) )
(:do (let (ob2 ...) oc2 ...)
(lb2 ...)
ne1?2
(let (ib2 ...) ic2 ...)
ne2?2
(ls2 ...) ))
(:parallel-1
cc
gens
(:do (let (ob1 ... ob2 ...) oc1 ... oc2 ...)
(lb1 ... lb2 ...)
(and ne1?1 ne1?2)
(let (ib1 ... ib2 ...) ic1 ... ic2 ...)
(and ne2?1 ne2?2)
(ls1 ... ls2 ...) )))
; no more gens -> continue with cc, reentry at (*)
((:parallel-1 (cc ...) () result)
(cc ... result) )))
(define-syntax :while
(syntax-rules ()
((:while cc (g arg1 arg ...) test)
(g (:while-1 cc test) arg1 arg ...) )))
(define-syntax :while-1
(syntax-rules (:do)
((:while-1 cc test (:do olet lbs ne1? ilet ne2? lss))
(:do cc olet lbs (and ne1? test) ilet ne2? lss) )))
(define-syntax :until
(syntax-rules ()
((:until cc (g arg1 arg ...) test)
(g (:until-1 cc test) arg1 arg ...) )))
(define-syntax :until-1
(syntax-rules (:do)
((:until-1 cc test (:do olet lbs ne1? ilet ne2? lss))
(:do cc olet lbs ne1? ilet (and ne2? (not test)) lss) )))
; ==========================================================================
; The typed generators :list :string :vector etc.
; ==========================================================================
(define-syntax :list
(syntax-rules (index)
((:list cc var (index i) arg ...)
(:parallel cc (:list var arg ...) (:integers i)) )
((:list cc var arg1 arg2 arg ...)
(:list cc var (append arg1 arg2 arg ...)) )
((:list cc var arg)
(:do cc
(let ())
((t arg))
(not (null? t))
(let ((var (car t))))
#t
((cdr t)) ))))
(define-syntax :string
(syntax-rules (index)
((:string cc var (index i) arg)
(:do cc
(let ((str arg) (len 0))
(set! len (string-length str)))
((i 0))
(< i len)
(let ((var (string-ref str i))))
#t
((+ i 1)) ))
((:string cc var (index i) arg1 arg2 arg ...)
(:string cc var (index i) (string-append arg1 arg2 arg ...)) )
((:string cc var arg1 arg ...)
(:string cc var (index i) arg1 arg ...) )))
; Alternative: An implementation in the style of :vector can also
; be used for :string. However, it is less interesting as the
; overhead of string-append is much less than for 'vector-append'.
(define-syntax :vector
(syntax-rules (index)
((:vector cc var arg)
(:vector cc var (index i) arg) )
((:vector cc var (index i) arg)
(:do cc
(let ((vec arg) (len 0))
(set! len (vector-length vec)))
((i 0))
(< i len)
(let ((var (vector-ref vec i))))
#t
((+ i 1)) ))
((:vector cc var (index i) arg1 arg2 arg ...)
(:parallel cc (:vector cc var arg1 arg2 arg ...) (:integers i)) )
((:vector cc var arg1 arg2 arg ...)
(:do cc
(let ((vec #f)
(len 0)
(vecs (ec-:vector-filter (list arg1 arg2 arg ...))) ))
((k 0))
(if (< k len)
#t
(if (null? vecs)
#f
(begin (set! vec (car vecs))
(set! vecs (cdr vecs))
(set! len (vector-length vec))
(set! k 0)
#t )))
(let ((var (vector-ref vec k))))
#t
((+ k 1)) ))))
(define (ec-:vector-filter vecs)
(if (null? vecs)
'()
(if (zero? (vector-length (car vecs)))
(ec-:vector-filter (cdr vecs))
(cons (car vecs) (ec-:vector-filter (cdr vecs))) )))
; Alternative: A simpler implementation for :vector uses vector->list
; append and :list in the multi-argument case. Please refer to the
; 'design.scm' for more details.
(define-syntax :integers
(syntax-rules (index)
((:integers cc var (index i))
(:do cc ((var 0) (i 0)) #t ((+ var 1) (+ i 1))) )
((:integers cc var)
(:do cc ((var 0)) #t ((+ var 1))) )))
(define-syntax :range
(syntax-rules (index)
; handle index variable and add optional args
((:range cc var (index i) arg1 arg ...)
(:parallel cc (:range var arg1 arg ...) (:integers i)) )
((:range cc var arg1)
(:range cc var 0 arg1 1) )
((:range cc var arg1 arg2)
(:range cc var arg1 arg2 1) )
; special cases (partially evaluated by hand from general case)
((:range cc var 0 arg2 1)
(:do cc
(let ((b arg2))
(if (not (and (integer? b) (exact? b)))
(error
"arguments of :range are not exact integer "
"(use :real-range?)" 0 b 1 )))
((var 0))
(< var b)
(let ())
#t
((+ var 1)) ))
((:range cc var 0 arg2 -1)
(:do cc
(let ((b arg2))
(if (not (and (integer? b) (exact? b)))
(error
"arguments of :range are not exact integer "
"(use :real-range?)" 0 b 1 )))
((var 0))
(> var b)
(let ())
#t
((- var 1)) ))
((:range cc var arg1 arg2 1)
(:do cc
(let ((a arg1) (b arg2))
(if (not (and (integer? a) (exact? a)
(integer? b) (exact? b) ))
(error
"arguments of :range are not exact integer "
"(use :real-range?)" a b 1 )) )
((var a))
(< var b)
(let ())
#t
((+ var 1)) ))
((:range cc var arg1 arg2 -1)
(:do cc
(let ((a arg1) (b arg2) (s -1) (stop 0))
(if (not (and (integer? a) (exact? a)
(integer? b) (exact? b) ))
(error
"arguments of :range are not exact integer "
"(use :real-range?)" a b -1 )) )
((var a))
(> var b)
(let ())
#t
((- var 1)) ))
; the general case
((:range cc var arg1 arg2 arg3)
(:do cc
(let ((a arg1) (b arg2) (s arg3) (stop 0))
(if (not (and (integer? a) (exact? a)
(integer? b) (exact? b)
(integer? s) (exact? s) ))
(error
"arguments of :range are not exact integer "
"(use :real-range?)" a b s ))
(if (zero? s)
(error "step size must not be zero in :range") )
(set! stop (+ a (* (max 0 (ceiling (/ (- b a) s))) s))) )
((var a))
(not (= var stop))
(let ())
#t
((+ var s)) ))))
; Comment: The macro :range inserts some code to make sure the values
; are exact integers. This overhead has proven very helpful for
; saving users from themselves.
(define-syntax :real-range
(syntax-rules (index)
; add optional args and index variable
((:real-range cc var arg1)
(:real-range cc var (index i) 0 arg1 1) )
((:real-range cc var (index i) arg1)
(:real-range cc var (index i) 0 arg1 1) )
((:real-range cc var arg1 arg2)
(:real-range cc var (index i) arg1 arg2 1) )
((:real-range cc var (index i) arg1 arg2)
(:real-range cc var (index i) arg1 arg2 1) )
((:real-range cc var arg1 arg2 arg3)
(:real-range cc var (index i) arg1 arg2 arg3) )
; the fully qualified case
((:real-range cc var (index i) arg1 arg2 arg3)
(:do cc
(let ((a arg1) (b arg2) (s arg3) (istop 0))
(if (not (and (real? a) (real? b) (real? s)))
(error "arguments of :real-range are not real" a b s) )
(if (and (exact? a) (or (not (exact? b)) (not (exact? s))))
(set! a (exact->inexact a)) )
(set! istop (/ (- b a) s)) )
((i 0))
(< i istop)
(let ((var (+ a (* s i)))))
#t
((+ i 1)) ))))
; Comment: The macro :real-range adapts the exactness of the start
; value in case any of the other values is inexact. This is a
; precaution to avoid (list-ec (: x 0 3.0) x) => '(0 1.0 2.0).
(define-syntax :char-range
(syntax-rules (index)
((:char-range cc var (index i) arg1 arg2)
(:parallel cc (:char-range var arg1 arg2) (:integers i)) )
((:char-range cc var arg1 arg2)
(:do cc
(let ((imax (char->integer arg2))))
((i (char->integer arg1)))
(<= i imax)
(let ((var (integer->char i))))
#t
((+ i 1)) ))))
; Warning: There is no R5RS-way to implement the :char-range generator
; because the integers obtained by char->integer are not necessarily
; consecutive. We simply assume this anyhow for illustration.
(define-syntax :port
(syntax-rules (index)
((:port cc var (index i) arg1 arg ...)
(:parallel cc (:port var arg1 arg ...) (:integers i)) )
((:port cc var arg)
(:port cc var arg read) )
((:port cc var arg1 arg2)
(:do cc
(let ((port arg1) (read-proc arg2)))
((var (read-proc port)))
(not (eof-object? var))
(let ())
#t
((read-proc port)) ))))
; ==========================================================================
; The typed generator :dispatched and utilities for constructing dispatchers
; ==========================================================================
(define-syntax :dispatched
(syntax-rules (index)
((:dispatched cc var (index i) dispatch arg1 arg ...)
(:parallel cc
(:integers i)
(:dispatched var dispatch arg1 arg ...) ))
((:dispatched cc var dispatch arg1 arg ...)
(:do cc
(let ((d dispatch)
(args (list arg1 arg ...))
(g #f)
(empty (list #f)) )
(set! g (d args))
(if (not (procedure? g))
(error "unrecognized arguments in dispatching"
args
(d '()) )))
((var (g empty)))
(not (eq? var empty))
(let ())
#t
((g empty)) ))))
; Comment: The unique object empty is created as a newly allocated
; non-empty list. It is compared using eq? which distinguishes
; the object from any other object, according to R5RS 6.1.
(define-syntax :generator-proc
(syntax-rules (:do let)
; call g with a variable, reentry at (**)
((:generator-proc (g arg ...))
(g (:generator-proc var) var arg ...) )
; reentry point (**) -> make the code from a single :do
((:generator-proc
var
(:do (let obs oc ...)
((lv li) ...)
ne1?
(let ((i v) ...) ic ...)
ne2?
(ls ...)) )
(ec-simplify
(let obs
oc ...
(let ((lv li) ... (ne2 #t))
(ec-simplify
(let ((i #f) ...) ; v not yet valid
(lambda (empty)
(if (and ne1? ne2)
(ec-simplify
(begin
(set! i v) ...
ic ...
(let ((value var))
(ec-simplify
(if ne2?
(ec-simplify
(begin (set! lv ls) ...) )
(set! ne2 #f) ))
value )))
empty ))))))))
; silence warnings of some macro expanders
((:generator-proc var)
(error "illegal macro call") )))
(define (dispatch-union d1 d2)
(lambda (args)
(let ((g1 (d1 args)) (g2 (d2 args)))
(if g1
(if g2
(if (null? args)
(append (if (list? g1) g1 (list g1))
(if (list? g2) g2 (list g2)) )
(error "dispatching conflict" args (d1 '()) (d2 '())) )
g1 )
(if g2 g2 #f) ))))
; ==========================================================================
; The dispatching generator :
; ==========================================================================
(define (make-initial-:-dispatch)
(lambda (args)
(case (length args)
((0) 'SRFI42)
((1) (let ((a1 (car args)))
(cond
((list? a1)
(:generator-proc (:list a1)) )
((string? a1)
(:generator-proc (:string a1)) )
((vector? a1)
(:generator-proc (:vector a1)) )
((and (integer? a1) (exact? a1))
(:generator-proc (:range a1)) )
((real? a1)
(:generator-proc (:real-range a1)) )
((input-port? a1)
(:generator-proc (:port a1)) )
(else
#f ))))
((2) (let ((a1 (car args)) (a2 (cadr args)))
(cond
((and (list? a1) (list? a2))
(:generator-proc (:list a1 a2)) )
((and (string? a1) (string? a1))
(:generator-proc (:string a1 a2)) )
((and (vector? a1) (vector? a2))
(:generator-proc (:vector a1 a2)) )
((and (integer? a1) (exact? a1) (integer? a2) (exact? a2))
(:generator-proc (:range a1 a2)) )
((and (real? a1) (real? a2))
(:generator-proc (:real-range a1 a2)) )
((and (char? a1) (char? a2))
(:generator-proc (:char-range a1 a2)) )
((and (input-port? a1) (procedure? a2))
(:generator-proc (:port a1 a2)) )
(else
#f ))))
((3) (let ((a1 (car args)) (a2 (cadr args)) (a3 (caddr args)))
(cond
((and (list? a1) (list? a2) (list? a3))
(:generator-proc (:list a1 a2 a3)) )
((and (string? a1) (string? a1) (string? a3))
(:generator-proc (:string a1 a2 a3)) )
((and (vector? a1) (vector? a2) (vector? a3))
(:generator-proc (:vector a1 a2 a3)) )
((and (integer? a1) (exact? a1)
(integer? a2) (exact? a2)
(integer? a3) (exact? a3))
(:generator-proc (:range a1 a2 a3)) )
((and (real? a1) (real? a2) (real? a3))
(:generator-proc (:real-range a1 a2 a3)) )
(else
#f ))))
(else
(letrec ((every?
(lambda (pred args)
(if (null? args)
#t
(and (pred (car args))
(every? pred (cdr args)) )))))
(cond
((every? list? args)
(:generator-proc (:list (apply append args))) )
((every? string? args)
(:generator-proc (:string (apply string-append args))) )
((every? vector? args)
(:generator-proc (:list (apply append (map vector->list args)))) )
(else
#f )))))))
(define :-dispatch
(make-initial-:-dispatch) )
(define (:-dispatch-ref)
:-dispatch )
(define (:-dispatch-set! dispatch)
(if (not (procedure? dispatch))
(error "not a procedure" dispatch) )
(set! :-dispatch dispatch) )
(define-syntax :
(syntax-rules (index)
((: cc var (index i) arg1 arg ...)
(:dispatched cc var (index i) :-dispatch arg1 arg ...) )
((: cc var arg1 arg ...)
(:dispatched cc var :-dispatch arg1 arg ...) )))
; ==========================================================================
; The utility comprehensions fold-ec, fold3-ec
; ==========================================================================
(define-syntax fold3-ec
(syntax-rules (nested)
((fold3-ec x0 (nested q1 ...) q etc1 etc2 etc3 etc ...)
(fold3-ec x0 (nested q1 ... q) etc1 etc2 etc3 etc ...) )
((fold3-ec x0 q1 q2 etc1 etc2 etc3 etc ...)
(fold3-ec x0 (nested q1 q2) etc1 etc2 etc3 etc ...) )
((fold3-ec x0 expression f1 f2)
(fold3-ec x0 (nested) expression f1 f2) )
((fold3-ec x0 qualifier expression f1 f2)
(let ((result #f) (empty #t))
(do-ec qualifier
(let ((value expression)) ; don't duplicate
(if empty
(begin (set! result (f1 value))
(set! empty #f) )
(set! result (f2 value result)) )))
(if empty x0 result) ))))
(define-syntax fold-ec
(syntax-rules (nested)
((fold-ec x0 (nested q1 ...) q etc1 etc2 etc ...)
(fold-ec x0 (nested q1 ... q) etc1 etc2 etc ...) )
((fold-ec x0 q1 q2 etc1 etc2 etc ...)
(fold-ec x0 (nested q1 q2) etc1 etc2 etc ...) )
((fold-ec x0 expression f2)
(fold-ec x0 (nested) expression f2) )
((fold-ec x0 qualifier expression f2)
(let ((result x0))
(do-ec qualifier (set! result (f2 expression result)))
result ))))
; ==========================================================================
; The comprehensions list-ec string-ec vector-ec etc.
; ==========================================================================
(define-syntax list-ec
(syntax-rules ()
((list-ec etc1 etc ...)
(reverse (fold-ec '() etc1 etc ... cons)) )))
; Alternative: Reverse can safely be replaced by reverse! if you have it.
;
; Alternative: It is possible to construct the result in the correct order
; using set-cdr! to add at the tail. This removes the overhead of copying
; at the end, at the cost of more book-keeping.
(define-syntax append-ec
(syntax-rules ()
((append-ec etc1 etc ...)
(apply append (list-ec etc1 etc ...)) )))
(define-syntax string-ec
(syntax-rules ()
((string-ec etc1 etc ...)
(list->string (list-ec etc1 etc ...)) )))
; Alternative: For very long strings, the intermediate list may be a
; problem. A more space-aware implementation collect the characters
; in an intermediate list and when this list becomes too large it is
; converted into an intermediate string. At the end, the intermediate
; strings are concatenated with string-append.
(define-syntax string-append-ec
(syntax-rules ()
((string-append-ec etc1 etc ...)
(apply string-append (list-ec etc1 etc ...)) )))
(define-syntax vector-ec
(syntax-rules ()
((vector-ec etc1 etc ...)
(list->vector (list-ec etc1 etc ...)) )))
; Comment: A similar approach as for string-ec can be used for vector-ec.
; However, the space overhead for the intermediate list is much lower
; than for string-ec and as there is no vector-append, the intermediate
; vectors must be copied explicitly.
(define-syntax vector-of-length-ec
(syntax-rules (nested)
((vector-of-length-ec k (nested q1 ...) q etc1 etc ...)
(vector-of-length-ec k (nested q1 ... q) etc1 etc ...) )
((vector-of-length-ec k q1 q2 etc1 etc ...)
(vector-of-length-ec k (nested q1 q2) etc1 etc ...) )
((vector-of-length-ec k expression)
(vector-of-length-ec k (nested) expression) )
((vector-of-length-ec k qualifier expression)
(let ((len k))
(let ((vec (make-vector len))
(i 0) )
(do-ec qualifier
(if (< i len)
(begin (vector-set! vec i expression)
(set! i (+ i 1)) )
(error "vector is too short for the comprehension") ))
(if (= i len)
vec
(error "vector is too long for the comprehension") ))))))
(define-syntax sum-ec
(syntax-rules ()
((sum-ec etc1 etc ...)
(fold-ec (+) etc1 etc ... +) )))
(define-syntax product-ec
(syntax-rules ()
((product-ec etc1 etc ...)
(fold-ec (*) etc1 etc ... *) )))
(define-syntax min-ec
(syntax-rules ()
((min-ec etc1 etc ...)
(fold3-ec (min) etc1 etc ... min min) )))
(define-syntax max-ec
(syntax-rules ()
((max-ec etc1 etc ...)
(fold3-ec (max) etc1 etc ... max max) )))
(define-syntax last-ec
(syntax-rules (nested)
((last-ec default (nested q1 ...) q etc1 etc ...)
(last-ec default (nested q1 ... q) etc1 etc ...) )
((last-ec default q1 q2 etc1 etc ...)
(last-ec default (nested q1 q2) etc1 etc ...) )
((last-ec default expression)
(last-ec default (nested) expression) )
((last-ec default qualifier expression)
(let ((result default))
(do-ec qualifier (set! result expression))
result ))))
; ==========================================================================
; The fundamental early-stopping comprehension first-ec
; ==========================================================================
(define-syntax first-ec
(syntax-rules (nested)
((first-ec default (nested q1 ...) q etc1 etc ...)
(first-ec default (nested q1 ... q) etc1 etc ...) )
((first-ec default q1 q2 etc1 etc ...)
(first-ec default (nested q1 q2) etc1 etc ...) )
((first-ec default expression)
(first-ec default (nested) expression) )
((first-ec default qualifier expression)
(let ((result default) (stop #f))
(ec-guarded-do-ec
stop
(nested qualifier)
(begin (set! result expression)
(set! stop #t) ))
result ))))
; (ec-guarded-do-ec stop (nested q ...) cmd)
; constructs (do-ec q ... cmd) where the generators gen in q ... are
; replaced by (:until gen stop).
(define-syntax ec-guarded-do-ec
(syntax-rules (nested if not and or begin)
((ec-guarded-do-ec stop (nested (nested q1 ...) q2 ...) cmd)
(ec-guarded-do-ec stop (nested q1 ... q2 ...) cmd) )
((ec-guarded-do-ec stop (nested (if test) q ...) cmd)
(if test (ec-guarded-do-ec stop (nested q ...) cmd)) )
((ec-guarded-do-ec stop (nested (not test) q ...) cmd)
(if (not test) (ec-guarded-do-ec stop (nested q ...) cmd)) )
((ec-guarded-do-ec stop (nested (and test ...) q ...) cmd)
(if (and test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
((ec-guarded-do-ec stop (nested (or test ...) q ...) cmd)
(if (or test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
((ec-guarded-do-ec stop (nested (begin etc ...) q ...) cmd)
(begin etc ... (ec-guarded-do-ec stop (nested q ...) cmd)) )
((ec-guarded-do-ec stop (nested gen q ...) cmd)
(do-ec
(:until gen stop)
(ec-guarded-do-ec stop (nested q ...) cmd) ))
((ec-guarded-do-ec stop (nested) cmd)
(do-ec cmd) )))
; Alternative: Instead of modifying the generator with :until, it is
; possible to use call-with-current-continuation:
;
; (define-synatx first-ec
; ...same as above...
; ((first-ec default qualifier expression)
; (call-with-current-continuation
; (lambda (cc)
; (do-ec qualifier (cc expression))
; default ))) ))
;
; This is much simpler but not necessarily as efficient.
; ==========================================================================
; The early-stopping comprehensions any?-ec every?-ec
; ==========================================================================
(define-syntax any?-ec
(syntax-rules (nested)
((any?-ec (nested q1 ...) q etc1 etc ...)
(any?-ec (nested q1 ... q) etc1 etc ...) )
((any?-ec q1 q2 etc1 etc ...)
(any?-ec (nested q1 q2) etc1 etc ...) )
((any?-ec expression)
(any?-ec (nested) expression) )
((any?-ec qualifier expression)
(first-ec #f qualifier (if expression) #t) )))
(define-syntax every?-ec
(syntax-rules (nested)
((every?-ec (nested q1 ...) q etc1 etc ...)
(every?-ec (nested q1 ... q) etc1 etc ...) )
((every?-ec q1 q2 etc1 etc ...)
(every?-ec (nested q1 q2) etc1 etc ...) )
((every?-ec expression)
(every?-ec (nested) expression) )
((every?-ec qualifier expression)
(first-ec #t qualifier (if (not expression)) #f) )))

4
scheme/vm/prim-io.scm
View File

@ -370,8 +370,8 @@
(lambda (from from-index to to-index count)
(cond ((and (or (vm-string? from)
(code-vector? from))
(or (vm-string? from)
(code-vector? from))
(or (vm-string? to)
(code-vector? to))
(<= 0 from-index)
(<= 0 to-index)
(<= 0 count)

4
scsh/aix/sysdep.h
View File

@ -1,4 +0,0 @@
#undef HAVE_DLOPEN
#undef HAVE_TZNAME
#define HAVE_TZNAME

0
scsh/bsd/sysdep.h
View File

53
scsh/configure.scm.in Normal file
View File

@ -0,0 +1,53 @@
(define (host) "@scsh_host@")
(define (machine-vendor-os)
(let ((match (regexp-search (rx (submatch (+ (~ #\-))) "-"
(submatch (+ (~ #\-))) "-"
(submatch (+ any)))
(host))))
(list (match:substring match 1)
(match:substring match 2)
(match:substring match 3))))
(define (machine)
(car (machine-vendor-os)))
(define (vendor)
(cadr (machine-vendor-os)))
(define (os)
(caddr (machine-vendor-os)))
(define (prefix) "@scsh_prefix@")
(define (exec-prefix) "@scsh_exec_prefix@")
(define (bin-dir) "@scsh_bindir@")
(define (lib-dir) "@scsh_libdir@")
(define (include-dir) "@scsh_includedir@")
(define (man-dir) "@scsh_mandir@")
(define (lib-dirs-list) (quote @scsh_lib_dirs_list@))
(define (libs) "@scsh_LIBS@")
(define (defs) "@scsh_DEFS@")
(define (cflags) "@scsh_CFLAGS@")
(define (cppflags) "@scsh_CPPFLAGS@")
(define (ldflags) "@scsh_LDFLAGS@")
(define (compiler-flags)
(string-join (list "-I" (include-dir) (defs))))
(define (linker-flags)
(string-join (list "-L" (lib-dir) (libs) "-lscsh") " "))
;;; Local Variables:
;;; mode: Scheme
;;; End:

2
scsh/cygwin32/sysdep.h
View File

@ -1,2 +0,0 @@
/* Cygwin's adds _'s but making configure.in know about dlltool seemed evil */
#define DLSYM_ADDS_USCORE

5
scsh/db.scm
View File

@ -1,10 +1,7 @@
;;; Very vanilla DBM processing code
;;; Copyright (c) 1995 by David Albertz (dalbertz@clark.lcs.mit.edu).
;;; This code is freely available for use by anyone for any purpose,
;;; so long as you don't charge money for it, remove this notice, or
;;; hold us liable for any results of its use. --enjoy.
;;; See file COPYING
;;; This is just a straight translation of the UNIX freebie NDBM code.

5
scsh/dbm.scm
View File

@ -1,10 +1,7 @@
;;; DBM processing code
;;; Copyright (c) 1995 by David Albertz (dalbertz@clark.lcs.mit.edu).
;;; This code is freely available for use by anyone for any purpose,
;;; so long as you don't charge money for it, remove this notice, or
;;; hold us liable for any results of its use. --enjoy.
;;; See file COPYING
;;; Usage: (dbm-open name flags mode . access_method access_info)
;;; name := name of database file (no extension)

5
scsh/filemtch.scm
View File

@ -2,10 +2,7 @@
;;; Copyright (c) 1994 by David Albertz (dalbertz@clark.lcs.mit.edu).
;;; Copyright (c) 1994 by Olin Shivers (shivers@clark.lcs.mit.edu).
;;; This code is freely available for use by anyone for any purpose,
;;; so long as you don't charge money for it, remove this notice, or
;;; hold us liable for any results of its use. --enjoy.
;;; See file COPYING
;;; Usage: (file-match root dots? . pattern-list)
;;; root Search starts from here. Usefully "." (cwd)

9
scsh/fname.scm
View File

@ -1,9 +1,6 @@
;;; Code for processing Unix file names.
;;; Copyright (c) 1992 by Olin Shivers (shivers@lcs.mit.edu).
;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
;;; notice appearing here to the effect that you may use this code any
;;; way you like, as long as you don't charge money for it, remove this
;;; notice, or hold me liable for its results.
;;; See file COPYING
;;; We adhere to Posix file name rules, plus we treat files beginning with
;;; ~ as absolute paths.
@ -115,7 +112,9 @@
(apply string-append
(if (and (pair? pathlist)
(string=? "" (car pathlist)))
w/slashes ; Absolute path not relocated.
(if (null? (cdr pathlist)) ; special case for pathlist = '("")
'("/")
w/slashes) ; Absolute path not relocated.
(cons (file-name-as-directory root) w/slashes)))))

4
scsh/fr.scm
View File

@ -350,7 +350,7 @@
;;; Reading and parsing records
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (field-reader [field-parser rec-reader]) -> reader
;;; (reader [port]) -> [raw-record parsed-record] or [eof #()]
;;; (reader [port]) -> [raw-record parsed-record] or [eof '()]
;;;
;;; This is the field reader, which is basically just a composition of
;;; RECORD-READER and FIELD-PARSER.
@ -363,7 +363,7 @@
(lambda maybe-port
(let ((record (apply rec-reader maybe-port)))
(if (eof-object? record)
(values record '#())
(values record '())
(values record (parser record)))))))

0
scsh/generic/sysdep.h
View File

37
scsh/glob.scm
View File

@ -4,10 +4,6 @@
;;; Copyright (c) 1994 by Olin Shivers (shivers@clark.lcs.mit.edu).
;;; See file COPYING.
;;; This code is freely available for use by anyone for any purpose,
;;; so long as you don't charge money for it, remove this notice, or
;;; hold us liable for any results of its use. --enjoy.
;;; Usage: (glob pattern-list)
;;; pattern-list := a list of glob-pattern strings
@ -73,7 +69,7 @@
(cond ((string=? pat "") (values '() #t))
((constant-glob? pat)
(values (cons pat '()) #f)) ; Don't check filesys.
(values (cons (glob-unquote pat) '()) #f)) ; Don't check filesys.
(else (let* ((dots? (char=? #\. (string-ref pat 0))) ; Match dot files?
(candidates (maybe-directory-files fname dots?))
@ -253,12 +249,16 @@
(parse-comma-sequence pattern (+ i 1))
(lp i (cross-append prefixes pats) '()))))
((#\\)
(let ((i (+ i 1)))
(if (= i pattern-len)
(let ((next-i (+ i 1)))
(if (= next-i pattern-len)
(error "Dangling escape char in glob pattern" pattern)
(lp (+ i 1)
prefixes
(cons (string-ref pattern i) pat)))))
(if (memv (string-ref pattern next-i) '(#\{, #\,, #\},#\\))
(lp (+ next-i 1)
prefixes
(cons (string-ref pattern next-i) pat))
(lp (+ i 1)
prefixes
(cons (string-ref pattern i) pat))))))
((#\,)
(if comma-terminates?
(values (finish prefixes pat) i)
@ -317,4 +317,21 @@
(cons #\\ result)
result))))))
(define (glob-unquote string)
(let ((len (string-length string)))
(let lp ((i 0)
(result '()))
(if (= i len)
(list->string (reverse result))
(let* ((c (string-ref string i)))
(if (char=? c #\\)
(let ((next-i (+ i 1)))
(if (= next-i len)
(error "Dangling escape char in glob pattern" string)
(let ((quoted (string-ref string next-i)))
(lp (+ i 2)
(cons quoted result)))))
(lp (+ i 1)
(cons c result))))))))

39
scsh/gnu/time_dep1.c Normal file
View File

@ -0,0 +1,39 @@
/* OS-dependent support for fine-grained timer.
** Copyright (c) 1995 by Olin Shivers.
**
** We return the current time in seconds and sub-second "ticks" where the
** number of ticks/second is OS dependent (and is defined in time_dep.scm).
** This definition works on any BSD Unix with the gettimeofday()
** microsecond-resolution timer.
*/
#include <errno.h>
#include <sys/time.h>
#include "scheme48.h"
#include "../time1.h"
s48_value time_plus_ticks()
{
struct timeval t;
struct timezone tz;
s48_value sch_tv_sec = S48_UNSPECIFIC;
s48_value sch_tv_usec = S48_UNSPECIFIC;
s48_value sch_listval = S48_UNSPECIFIC;
s48_value sch_retval = S48_UNSPECIFIC;
S48_DECLARE_GC_PROTECT(3);
S48_GC_PROTECT_3(sch_tv_sec, sch_tv_usec, sch_listval);
if( gettimeofday(&t, &tz) ) s48_raise_os_error (errno);
sch_tv_sec = s48_enter_integer(t.tv_sec);
sch_tv_usec = s48_enter_integer(t.tv_usec);
sch_listval = s48_cons (sch_tv_usec, S48_NULL);
sch_retval = s48_cons (sch_tv_sec, sch_listval);
S48_GC_UNPROTECT();
return sch_retval;
}

0
scsh/hpux/sysdep.h
View File

0
scsh/irix/sysdep.h
View File

118
scsh/lib-dirs.scm Normal file
View File

@ -0,0 +1,118 @@
;;; More imports for the new library-search facility:
;;; HANDLE: with-handler
;;; LIST-LIB: any
;;; SCSH-LEVEL-0: directory-files open-input-file file-directory?
;;; SCSH-LEVEL-0: getenv
;;; SCSH-LEVEL-0: the file-name procs
(define default-lib-dirs '("/usr/local/lib/scsh/modules/"))
(define (set-default-lib-dirs! path-list)
(set! default-lib-dirs path-list))
;;; Search library dirs for FILE.
(define (find-library-file file lib-dirs script-file)
(letrec ((recur (lambda (dir)
; (format (error-output-port) "flf -- entering ~a\n" dir)
(let* ((f (string-append dir file))) ; Resolve it.
(or (check-file-for-open f) ; Found it.
(any (lambda (f) ; Search subdirs.
(let ((dir (string-append dir f "/")))
(and (file-directory?/safe dir) (recur dir))))
(directory-files/safe dir)))))))
(any (lambda (dir)
(cond ((eq? dir 'script-dir)
(let* ((script-dir (file-name-directory script-file))
(fname (string-append script-dir file)))
(check-file-for-open fname)))
;; Ends in / means recursive search.
((file-name-directory? dir)
(recur dir))
(else (check-file-for-open (absolute-file-name file dir)))))
lib-dirs)))
;;; (in-any-event abort-exp body ...)
;;; If *anything* goes wrong, bag the BODY forms, and eval ABORT-EXP instead.
(define-syntax in-any-event
(syntax-rules ()
((in-any-event abort-exp body ...)
(call-with-current-continuation
(lambda (ret)
(with-handler (lambda (condition more) (ret abort-exp))
(lambda () body ...)))))))
(define (check-file-for-open f)
(in-any-event #f (let ((iport (open-input-file f)))
(close-input-port iport)
f))) ; Any error, say false.
(define (directory-files/safe dir)
(in-any-event '() (directory-files dir))) ; Any error, say ().
(define (file-directory?/safe f)
(in-any-event #f (file-directory? f))) ; Any error, say false.
(define (resolve-dir-name dir)
(if (file-name-directory? dir)
(file-name-as-directory (resolve-file-name dir))
(resolve-file-name dir)))
;;; Expand out env vars & ~user home dir prefixes.
(define (expand-lib-dir dir)
(substitute-env-vars (resolve-dir-name dir)))
;;; Parse up the $SCSH_LIB_DIRS path list.
(define (parse-lib-dirs-env-var)
(let ((s (getenv "SCSH_LIB_DIRS")))
(if (not s)
default-lib-dirs
(with-current-input-port (make-string-input-port s)
(let recur ()
(let ((val (read)))
(cond ((eof-object? val) '())
((string? val) (cons val (recur)))
((not val) (append default-lib-dirs (recur)))
(else
(error
(format #f
(string-append
"Illegal path element in $SCSH_LIB_DIRS\n"
"$SCSH_LIB_DIRS: ~a\n"
"The following element is not a string or #f: ~a")
s val))))))))))
;; We don't want to try to parse $SCSH_LIB_DIRS until we actually
;; need the value -- if the user is using the -lp-default switch,
;; for example, a parse error shouldn't effect the startup.
(define %lib-dirs #f)
(define reinit-lib-dirs
(make-reinitializer (lambda () (set! %lib-dirs #f))))
(define (lib-dirs)
(if (not %lib-dirs) (set! %lib-dirs (parse-lib-dirs-env-var)))
%lib-dirs)
;; Don't export -- direct modification of %lib-dirs
(define (set-lib-dirs! val) (set! %lib-dirs val))
(define (lib-dirs-append-script-dir!)
(set-lib-dirs! (append (lib-dirs) '(script-dir))))
(define (lib-dirs-prepend-script-dir!)
(set-lib-dirs! (cons 'script-dir (lib-dirs))))
(define (reset-lib-dirs!)
(set-lib-dirs! default-lib-dirs))
(define (clear-lib-dirs!)
(set-lib-dirs! '()))
(define (lib-dirs-prepend! dir)
(set-lib-dirs! (cons dir (lib-dirs))))
(define (lib-dirs-append! dir)
(set-lib-dirs! (append (lib-dirs) (list dir))))

1
scsh/libscsh.c
View File

@ -4,6 +4,7 @@
#include <stdarg.h>
#include <stdio.h>
#include <stdlib.h>
#include "scheme48.h"
#include "libscsh.h"
#include "sysdep.h"

0
scsh/linux/sysdep.h
View File

7
scsh/md5.c
View File

@ -292,7 +292,8 @@ MD5Transform(uint32 buf[4], uint32 const in[16])
*
*/
static s48_value make_context(void);
static s48_value make_MD5_CTX(void);
static MD5_CTX* extract_context(s48_value);
static s48_value MD5Init_stub(s48_value sch_context);
static s48_value MD5Update_stub (s48_value sch_context, s48_value input);
static s48_value MD5Final_stub (s48_value sch_context);
@ -313,7 +314,7 @@ static s48_value MD5Init_stub(s48_value sch_context){
static s48_value MD5Update_stub (s48_value sch_context, s48_value input){
MD5Update (extract_context (sch_context),
s48_extract_string (input),
(unsigned char*) s48_extract_string (input),
S48_STRING_LENGTH (input));
return S48_UNSPECIFIC;
}
@ -322,7 +323,7 @@ static s48_value MD5Final_stub (s48_value sch_context){
unsigned char digest[16];
MD5Final (digest, extract_context (sch_context));
return (s48_enter_substring (digest, 16));
return s48_enter_substring ((char*) digest, 16);
}

4
scsh/md5.scm
View File

@ -70,7 +70,9 @@
(init-md5-context! context)
(let lp ()
(let ((got (read-block buffer 0 buffer-size port)))
(cond ((< got buffer-size)
(cond ((eof-object? got)
(md5-context->md5-digest context))
((< got buffer-size)
(if (not (eof-object? (peek-char port)))
(error "read-block didn't read port to the end"))
(update-md5-context! context (substring buffer 0 got))

5
scsh/ndbm.scm
View File

@ -1,10 +1,7 @@
;;; Very vanilla DBM processing code
;;; Copyright (c) 1995 by David Albertz (dalbertz@clark.lcs.mit.edu).
;;; This code is freely available for use by anyone for any purpose,
;;; so long as you don't charge money for it, remove this notice, or
;;; hold us liable for any results of its use. --enjoy.
;;; See file COPYING
;;; This is just a straight translation of the UNIX freebie NDBM code.

16
scsh/network.scm
View File

@ -24,7 +24,7 @@
(service-info (cadr args) "tcp")))
(else
(error
"socket-connect: bad arg ~s"
"socket-connect: bad port arg ~s"
args)))))
(internet-address->socket-address host port)))
((= protocol-family
@ -265,13 +265,13 @@
(fdport-data
(socket:outport sock))))
'#())
(if (not (connect-socket-successful? sock))
(let ((errno (socket-option sock level/socket socket/error)))
(errno-error errno
(errno-msg errno)
%connect
sock
name)))))))
(let ((errno (socket-option sock level/socket socket/error)))
(if (not (zero? errno))
(errno-error errno
(errno-msg errno)
%connect
sock
name)))))))
(import-os-error-syscall %connect (sockfd family name) "scheme_connect")

25
scsh/network1.c
View File

@ -107,9 +107,14 @@ s48_value scheme_connect(s48_value sock, s48_value family, s48_value scheme_name
{
struct sockaddr_in name;
S48_DECLARE_GC_PROTECT (1);
S48_GC_PROTECT_1 (scheme_name);
u_long addr= htonl(s48_extract_unsigned_integer (S48_CAR (scheme_name)));
u_short port= htons(s48_extract_fixnum (S48_CDR (scheme_name)));
S48_GC_UNPROTECT ();
memset(&name, 0, sizeof(name));
name.sin_family=AF_INET;
@ -321,12 +326,12 @@ s48_value send_substring(s48_value scm_sockfd,
int flags = s48_extract_fixnum (scm_flags);
int start = s48_extract_fixnum (scm_start);
int end = s48_extract_fixnum (scm_end);
char* buf_part = s48_extract_string (buf) + start;
switch(s48_extract_fixnum (scm_family))
{
case 0: /* only with connected sockets */
{
char* buf_part = s48_extract_string (buf) + start;
n = send(s, buf_part, end-start, flags);
break;
}
@ -334,6 +339,7 @@ s48_value send_substring(s48_value scm_sockfd,
{
struct sockaddr_un name;
int scheme_length=S48_STRING_LENGTH(scheme_name);
char* buf_part = s48_extract_string (buf) + start;
memset(&name, 0, sizeof(name));
@ -353,8 +359,16 @@ s48_value send_substring(s48_value scm_sockfd,
case AF_INET:
{
struct sockaddr_in name;
u_long addr = htonl (s48_extract_unsigned_integer (S48_CAR (scheme_name)));
u_short port = htons(s48_extract_fixnum (S48_CDR (scheme_name)));
u_long addr;
u_short port;
char* buf_part;
S48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2 (scheme_name,buf);
addr = htonl (s48_extract_unsigned_integer (S48_CAR (scheme_name)));
port = htons (s48_extract_fixnum (S48_CDR (scheme_name)));
buf_part = s48_extract_string (buf) + start;
memset(&name, 0, sizeof(name));
@ -366,13 +380,14 @@ s48_value send_substring(s48_value scm_sockfd,
buf_part, end-start,
flags,
(struct sockaddr *)&name, sizeof(name));
break;
S48_GC_UNPROTECT();
break;
}
default:
s48_raise_argument_type_error (s48_extract_fixnum (scm_family));
/* error unknown address family */
}
if (n >= 0)
return s48_enter_fixnum (n);

2
scsh/next/sysdep.h
View File

@ -1,2 +0,0 @@
#undef HAVE_SIGACTION
#define HAVE_SIGACTION

5
scsh/proc2.c
View File

@ -1,9 +1,6 @@
/* Copyright (c) 1993 by Olin Shivers.
**
** Please imagine a long, tedious, legalistic 5-page gnu-style copyright
** notice appearing here to the effect that you may use this code any
** way you like, as long as you don't charge money for it, remove this
** notice, or hold me liable for its results.
** See file COPYING
*/
/* If the above copyright notice is a problem for your app, send me mail. */

11
scsh/process_args.c
View File

@ -1,6 +1,7 @@
#include <stdio.h>
#include <stdlib.h>
#include <stdarg.h>
#include <string.h>
#define streq(a,b) (strcmp((a),(b))==0)
@ -51,7 +52,7 @@ static void bad_args(char* msg, char* arg) {
printf (msg,arg);
printf ("\n");
usage();
exit(1);
exit(1);
}
@ -73,10 +74,10 @@ void process_args(char **argv,
for (; *argv; argv++){
char *arg = argv[0];
#define S48_ARGCMP(s) (streq(arg,s))
if (S48_ARGCMP ("-h")) { /* heapsize */
argv++;
if( !*argv ) bad_args("Option %s requires an argument", arg); /* die */
@ -118,7 +119,7 @@ void process_args(char **argv,
argv++;
if( !*argv ) bad_args("Option %s requires an argument", arg);
}
/* These switches terminate arg scanning. */
else if (S48_ARGCMP ("-s") ||
S48_ARGCMP ("-sdf") ||
@ -136,7 +137,7 @@ void process_args(char **argv,
bad_args("Unknown switch %s", arg);
}
}
#undef S48_ARGCMP
return;

6
scsh/procobj.scm
View File

@ -349,8 +349,10 @@
;;; All you have to do, if a wait on proc was successful
(define (waited-by-wait proc status)
(obituary proc status)
(mark-proc-waited! proc))
(if (not (status:stop-sig status))
(begin
(obituary proc status)
(mark-proc-waited! proc))))
;;; we know from somewhere that proc is dead
(define (obituary proc status)

41
scsh/pty.scm
View File

@ -18,20 +18,23 @@
(define (fork-pty-session thunk)
(receive (pty-in ttyname) (open-pty)
(let* ((process (fork (lambda ()
(close-input-port pty-in)
(become-session-leader)
(let ((tty (open-control-tty ttyname)))
(move->fdes tty 0)
(dup->outport tty 1)
(dup->outport tty 2))
(let ((tty-in (open-file ttyname open/read+write)))
(let* ((process (fork (lambda ()
(close-input-port pty-in)
(become-session-leader)
(make-control-tty tty-in)
(move->fdes tty-in 0)
(dup->outport tty-in 1)
(dup->outport tty-in 2)
(make-pty-a-tty! (current-input-port))
; (set-port-buffering (dup->outport tty 2)
; bufpol/none))
(with-stdio-ports* thunk))))
(pty-out (dup->outport pty-in)))
(with-stdio-ports* thunk))))
(pty-out (dup->outport pty-in)))
(close-input-port tty-in)
; (set-port-buffering pty-out bufpol/none)
(values process pty-in pty-out ttyname))))
(make-pty-a-tty! pty-in)
(values process pty-in pty-out ttyname)))))
;;; (open-pty)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -44,7 +47,7 @@
;;; opened read+write, and you can use DUP->OUTPORT to map it to
;;; corresponding output ports.
(define (open-pty)
(define (open-pty-from-devname)
(let ((next-pty (make-pty-generator)))
(let loop ()
(cond ((next-pty) =>
@ -58,6 +61,15 @@
(else (error "open-pty: could not open new pty"))))))
(import-os-error-syscall allocate-pty () "allocate_pty")
(define (open-pty)
(let ((pty-fd.tty-name (allocate-pty)))
(if pty-fd.tty-name
(values (make-input-fdport (car pty-fd.tty-name) 0)
(cdr pty-fd.tty-name))
(open-pty-from-devname))))
;;; The following code may in fact be system dependent.
;;; If so, we'll move it out to the architecture specific directories.
@ -101,3 +113,8 @@
(set! n (- n 1)))
(string-set! pattern n-pos (string-ref numbers n))
(string-copy pattern))))))
(define (make-pty-a-tty! fd/port)
(sleazy-call/fdes fd/port %make-pty-a-tty!))
(import-os-error-syscall %make-pty-a-tty! (fd) "pty2tty")

3
scsh/rdelim.scm
View File

@ -191,7 +191,8 @@
(let-optionals args ((port (current-input-port))
(start 0)
(end (string-length buf)))
(if (immutable? buf)
(error "Immutable buffer argument to %read-delimited!" buf))
(let ((delims (x->char-set delims)))
(let lp ((start start) (total 0))
(receive (terminator num-read)

37
scsh/rx/parse.scm
View File

@ -220,7 +220,7 @@
(if cset?
(if (re-char-set? re-or-cset) ; A char set or code
(uncase-char-set re-or-cset) ; producing a char set.
(re-char-set:cset (uncase re-or-cset))
`(,(r 'uncase) ,re-or-cset))
(if (static-regexp? re-or-cset) ; A regexp or code
@ -273,7 +273,7 @@
cs1)
. ,(if (char-set? cs2)
(list (char-set->scheme cs2 r))
(cdr cs2))))))
(list cs2))))))
(if cset? cs (make-re-char-set cs)))
(error "SRE set-difference operator (- ...) requires at least one argument")))
@ -291,11 +291,16 @@
(else
(if (every string? sre) ; A set spec -- ("wxyz").
(let* ((cs (apply char-set-union
(map string->char-set sre)))
(cs (if case-sensitive? cs (uncase-char-set cs))))
(if cset? cs (make-re-char-set cs)))
(let ((cs (apply char-set-union
(map string->char-set sre))))
(if case-sensitive?
(if cset?
cs
(make-re-char-set cs))
(let ((uncased-re (uncase-char-set cs)))
(if cset?
(re-char-set:cset uncased-re)
uncased-re))))
(error "Illegal SRE" sre))))))
;; It must be a char-class name (ANY, ALPHABETIC, etc.)
@ -375,7 +380,7 @@
(error "Unmatched range specifier" range-specs)
(let lp ((i (- len 1)) (cset cset))
(if (< i 0)
(if cs? cset (uncase-char-set cset)) ; Case fold if necessary.
(if cs? cset (re-char-set:cset (uncase-char-set cset))) ; Case fold if necessary.
(lp (- i 2)
(ucs-range->char-set! (char->ascii (string-ref specs (- i 1)))
(+ 1 (char->ascii (string-ref specs i)))
@ -437,11 +442,15 @@
re-choice:posix))
((re-char-set? re)
(if (re-any? re)
(r 're-any) ; Special hack for ANY.
(doit/leaf 'make-re-char-set 'make-re-char-set/posix
`(,(char-set->scheme (re-char-set:cset re) r))
re-char-set:posix)))
(cond
((re-any? re)
(r 're-any)) ; Special hack for ANY.
((re-empty? re)
(r 're-empty)) ; Special hack for EMPTY.
(else
(doit/leaf 'make-re-char-set 'make-re-char-set/posix
`(,(char-set->scheme (re-char-set:cset re) r))
re-char-set:posix))))
((re-repeat? re)
(doit 'make-re-repeat 'make-re-repeat/tsm (re-repeat:tsm re)
@ -705,7 +714,7 @@
. ,ranges))))
(values loose ranges)))))
(let lp ((i 127) (from #f) (to #f) (loose '()) (ranges '()))
(let lp ((i 255) (from #f) (to #f) (loose '()) (ranges '()))
(if (< i 0)
(add-range from to loose ranges)

2
scsh/rx/posixstr.scm
View File

@ -93,7 +93,7 @@
(define (regexp->posix-string re)
;; We *must* simplify, to guarantee correct translation.
(let ((re (simplify-regexp re)))
(if (simple-empty-re? re) (values #f #f #f #f)
(if (simple-empty-re? re) (values #f #f #f '#())
(translate-regexp re))))

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