Some more tests for bos/eos.

CRE-SEARCH? (defined in scsh/rx/re-low.scm) calls REGEXP-MATCH with
4th and 5th arguments indicating whether this corresponds to begin/end
of line. For matching a string, these must be #t. The reason it was
working previously (with both parameters set to #f) was a bug in
regexp1.c:116 (fixed now by placing the appropriate parenthesis),
caused by | having higher precedence than ?: in C (as a result, the
flags passed to the C regexp engine were not correctly computed).

.gitignore

@@ -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

COPYING

@@ -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.
 

CVS_README

@@ -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

Makefile.in

@@ -14,7 +14,7 @@ INSTALL = @INSTALL@
 INSTALL_PROGRAM = @INSTALL_PROGRAM@
 INSTALL_DATA = @INSTALL_DATA@
 
-LDFLAGS = -g @LDFLAGS@
+LDFLAGS = @LDFLAGS@
 LIBOBJS = @LIBOBJS@
 
 RM	= rm -f
@@ -29,7 +29,12 @@ libdir = @libdir@
 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 ###
 
 htmldir = $(libdir)/scsh/doc/scsh-manual/html
 
@@ -41,13 +46,16 @@ htmldir = $(libdir)/scsh/doc/scsh-manual/html
 # Ultrix
 #   LDFLAGS = -N
 
-.c.o:
-	$(CC) -g -c $(DEFS) -I$(srcdir)/c -I$(srcdir)/cig $(CPPFLAGS) $(CFLAGS) -o $@ $<
+.SUFFIXES:
+.SUFFIXES: .c .o
 
-# BUILD_RUNNABLE has to be Scheme 48 0.53. This is used for builds directly 
+.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
 # 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)
@@ -101,27 +109,23 @@ START_LINKER = echo ',batch' && echo ',bench on'
 # Targets:
 
 IMAGE = scheme48.image
-INITIAL = build/initial.image
+INITIAL = $(srcdir)/build/initial.image
 VM = scshvm
-LIBCIG = cig/lib$(VM).a
-CIG = cig/cig
-CIGOBJS = cig/libcig.o cig/libcig1.o
 
 #scsh-lib
 LIBSCSHVM = scsh/lib$(VM).a
 LIBSCSH = scsh/libscsh.a
 SCSHVMHACKS = scsh/proc2.o
 
-# 	
-# 	
+#
+#
 SCSHOBJS = \
 	scsh/cstuff.o \
 	scsh/dirstuff1.o \
 	scsh/fdports1.o \
 	scsh/flock1.o \
-	scsh/machine/time_dep1.o \
 	scsh/signals1.o \
-	scsh/machine/libansi.o \
+	scsh/@machine@/libansi.o \
 	scsh/network1.o \
 	scsh/putenv.o \
 	scsh/rx/regexp1.o \
@@ -139,7 +143,7 @@ SCSH_INITIALIZERS = s48_init_syslog s48_init_posix_regexp \
 	s48_init_userinfo s48_init_sighandlers \
 	s48_init_syscalls s48_init_network s48_init_flock \
 	s48_init_dirstuff s48_init_time s48_init_tty \
-	s48_init_cig s48_init_libscsh s48_init_md5
+	s48_init_libscsh s48_init_md5
 
 UNIX_OBJS = c/unix/misc.o c/unix/io.o c/unix/fd-io.o c/unix/event.o
 
@@ -147,8 +151,8 @@ 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 
-OBJS = scsh/process_args.o c/init.o $(S48OBJS) $(CIGOBJS) $(SCSHOBJS) \
+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)
 
 FAKEHS	= c/fake/dlfcn.h c/fake/sigact.h c/fake/strerror.h \
@@ -163,7 +167,14 @@ 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 $(LIBCIG) scsh $(LIBSCSH) $(LIBSCSHVM) 
+enough: $(VM) $(IMAGE) go scsh $(LIBSCSH) $(LIBSCSHVM)
+
+# Run unit tests
+test: enough
+	@echo "Running test suite..."
+	@(($(srcdir)/go -lm $(srcdir)/scsh/test/test-packages.scm    \
+         	       -o test-all -c "(test-all)" | grep -v 'OK$$') \
+	   || (echo "All tests passed"))
 
 # --------------------
 # External code to include in the VM
@@ -174,7 +185,6 @@ EXTERNAL_FLAGS = $(SOCKET_FLAGS)
 EXTERNAL_INITIALIZERS = $(ADDITIONAL_INITIALIZER) $(SOCKET_INITIALIZERS) 	\
 	$(LOOKUP_INITIALIZERS) 							\
 	$(SCSH_INITIALIZERS) $(SRFI_INITIALIZERS)				\
-	s48_init_cig
 
 
 # Rules for any external code.
@@ -210,16 +220,11 @@ 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
 
 
-# This says how to process .scm files with cig to make .c stubs.
-#.SUFFIXES: .scm
-#.scm.c:
-#	$(srcdir)/$(VM) -o $(srcdir)/$(VM) -i $(CIG) < $< > $*.c
-
 # These .h files mediate between the code exported from foo1.c
 # and imported into foo.scm's stub foo.c.
 
@@ -236,13 +241,13 @@ scsh/sighandlers1.o: scsh/sighandlers1.h
 
 scsh/syslog1.o:	c/scheme48.h
 
-include $(srcdir)/scsh/machine/Makefile.inc
+include $(srcdir)/scsh/@machine@/Makefile.inc
 # Berkeley make wants to see this instead: (or use GNU make on BSD. -bri)
-#.include "$(srcdir)/scsh/machine/Makefile.inc"
+#.include "$(srcdir)/scsh/@machine@/Makefile.inc"
 
 $(VM): c/main.o $(OBJS) $(UNIX_OBJS) $(LIBOBJS) $(EXTERNAL_OBJECTS)
 	rm -f /tmp/s48_external_$$$$.c &&					\
-	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					\
@@ -253,13 +258,6 @@ $(VM): c/main.o $(OBJS) $(UNIX_OBJS) $(LIBOBJS) $(EXTERNAL_OBJECTS)
 
 
 
-#JMG: again cig and scsh-lib
-$(LIBCIG): c/main.o $(OBJS)
-#	$(CC) -r -o $@ main.o $(OBJS)
-	$(RM) $@
-	$(AR) $@ c/main.o  $(OBJS)
-	$(RANLIB) $@
-
 $(LIBSCSHVM): c/smain.o $(OBJS)
 	$(RM) $@
 	$(AR) $@ c/smain.o $(OBJS)
@@ -268,24 +266,24 @@ $(LIBSCSHVM): c/smain.o $(OBJS)
 $(LIBSCSH): $(OBJS) $(UNIX_OBJS) $(LIBOBJS) $(EXTERNAL_OBJECTS)
 	$(RM) $@								\
 	rm -f /tmp/s48_external_$$$$.c &&					\
-	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 $@ \
 		-DDEFAULT_IMAGE_NAME=\"$(LIB)/$(IMAGE)\" \
-		$(CPPFLAGS) $(DEFS) c/main.c
+		$(CPPFLAGS) $(DEFS) $(srcdir)/c/main.c
 
 c/init.o: c/init.c c/scheme48vm.h c/scheme48heap.h
 	$(CC) -c $(CFLAGS) -o $@ \
 		-DDEFAULT_IMAGE_NAME=\"$(LIB)/$(IMAGE)\" \
-		$(CPPFLAGS) $(DEFS) c/init.c
+		$(CPPFLAGS) $(DEFS) $(srcdir)/c/init.c
 
 c/scheme48vm.o: c/prescheme.h c/scheme48vm.h c/scheme48heap.h c/event.h \
 			c/io.h c/fd-io.h c/scheme48vm-prelude.h
@@ -312,8 +310,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
-	build/build-usual-image . "`pwd`/scheme" '$(IMAGE)' './$(VM)' \
-		'$(INITIAL)'
+	$(srcdir)/build/build-usual-image $(srcdir) "$(srcdir)/scheme" '$(IMAGE)' './$(VM)' \
+		'$(srcdir)/$(INITIAL)'
 
 ### Fake targets:  all clean install man dist
 
@@ -321,14 +319,14 @@ install: enough dirs inst-script inst-vm inst-misc inst-man inst-inc 	\
 	 inst-doc install-scsh
 
 inst-vm: $(VM)
-	$(INSTALL_PROGRAM) $(VM) $(LIB)
+	$(INSTALL_PROGRAM) $(VM) $(DESTDIR)$(LIB)
 
 inst-man:
-	if [ -d $(mandir) -a -w $(mandir) ]; then			   \
+	if [ -d $(DESTDIR)$(mandir) -a -w $(DESTDIR)$(mandir) ]; then	   \
 		sed 's=LBIN=$(bindir)=g' doc/scsh.man |		   \
 			sed 's=LLIB=$(LIB)=g' |				   \
 			sed 's=LSCSH=$(RUNNABLE)=g' >$(MANPAGE) &&	   \
-		$(INSTALL_DATA) $(MANPAGE) $(mandir) &&			   \
+		$(INSTALL_DATA) $(MANPAGE) $(DESTDIR)$(mandir) &&	   \
 		$(RM) $(MANPAGE);					   \
 	else								   \
 		echo "$(mandir) not writable dir, not installing man page" \
@@ -336,67 +334,61 @@ inst-man:
 	fi
 
 inst-inc:
-	$(INSTALL_DATA) $(srcdir)/c/scheme48.h $(incdir)	
-	$(INSTALL_DATA) $(srcdir)/c/write-barrier.h $(incdir)
-
-install-cig: cig
-	$(INSTALL_PROGRAM) $(srcdir)/$(CIG) $(LIB)/cig
-	$(INSTALL_PROGRAM) $(srcdir)/$(CIG).image $(LIB)/cig
-	$(INSTALL_DATA) $(srcdir)/$(LIBCIG) $(LIB)/cig
-	$(INSTALL_DATA) $(srcdir)/cig/libcig.h $(LIB)/cig
+	$(INSTALL_DATA) $(srcdir)/c/scheme48.h $(DESTDIR)$(incdir)
+	$(INSTALL_DATA) $(srcdir)/c/write-barrier.h $(DESTDIR)$(incdir)
 
 inst-misc:
 	for stub in env big opt misc link srfi; do				\
-		for f in scheme/$$stub/*.scm; do			\
-			$(INSTALL_DATA) $$f $(LIB)/$$stub || exit 1;	\
+		for f in $(srcdir)/scheme/$$stub/*.scm; do			\
+			$(INSTALL_DATA) $$f $(DESTDIR)$(LIB)/$$stub || exit 1;	\
 		done;							\
 	done &&								\
-	for f in scheme/rts/*num.scm scheme/rts/jar-defrecord.scm; do	\
-		$(INSTALL_DATA) $$f $(LIB)/rts || exit 1;		\
-	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
 
 inst-doc:
 	for f in $(srcdir)/doc/*.txt $(srcdir)/doc/*.ps; do \
-		$(INSTALL_DATA) $$f $(LIB)/doc/; 				\
+		$(INSTALL_DATA) $$f $(DESTDIR)$(LIB)/doc/; 			\
 	done &&									\
 	for f in $(srcdir)/doc/src/*.tex 					\
 		$(srcdir)/doc/src/*.dvi						\
 		$(srcdir)/doc/src/*.ps;						\
-		do $(INSTALL_DATA) $$f $(LIB)/doc/s48-manual/;			\
+		do $(INSTALL_DATA) $$f $(DESTDIR)$(LIB)/doc/s48-manual/;	\
 	done &&									\
 	for f in $(srcdir)/doc/src/manual/*.html;				\
-		do $(INSTALL_DATA) $$f $(LIB)/doc/s48-manual/html/;		\
+		do $(INSTALL_DATA) $$f $(DESTDIR)$(LIB)/doc/s48-manual/html/;	\
 	done &&									\
 	for f in $(srcdir)/doc/scsh-manual/*.tex 				\
 		$(srcdir)/doc/scsh-manual/*.sty 				\
 		$(srcdir)/doc/scsh-manual/*.dvi					\
 		$(srcdir)/doc/scsh-manual/*.ps					\
 		$(srcdir)/doc/scsh-manual/*.pdf;				\
-		do $(INSTALL_DATA) $$f $(LIB)/doc/scsh-manual/;			\
+		do $(INSTALL_DATA) $$f $(DESTDIR)$(LIB)/doc/scsh-manual/;	\
 	done &&									\
 	for f in $(srcdir)/doc/scsh-manual/html/*.html 				\
 		$(srcdir)/doc/scsh-manual/html/*.gif 				\
 		$(srcdir)/doc/scsh-manual/html/*.css;				\
-		do $(INSTALL_DATA) $$f $(htmldir)/;				\
+		do $(INSTALL_DATA) $$f $(DESTDIR)$(htmldir)/;			\
 	done &&									\
 	for f in $(srcdir)/doc/scsh-paper/*.tex 				\
 		$(srcdir)/doc/scsh-paper/*.sty 					\
 		$(srcdir)/doc/scsh-paper/*.dvi					\
 		$(srcdir)/doc/scsh-paper/*.ps;					\
-		do $(INSTALL_DATA) $$f $(LIB)/doc/scsh-paper/;			\
+		do $(INSTALL_DATA) $$f $(DESTDIR)$(LIB)/doc/scsh-paper/;	\
 	done &&									\
 	for f in $(srcdir)/doc/scsh-paper/html/*.html 				\
 		$(srcdir)/doc/scsh-paper/html/*.css;				\
-		do $(INSTALL_DATA) $$f $(LIB)/doc/scsh-paper/html;		\
+		do $(INSTALL_DATA) $$f $(DESTDIR)$(LIB)/doc/scsh-paper/html;	\
 	done
 
 
 inst-script:
-	script=$(bindir)/$(RUNNABLE) &&					\
+	script=$(DESTDIR)$(bindir)/$(RUNNABLE) &&			\
 	echo '#!/bin/sh'	>$$script &&				\
 	echo			>>$$script &&				\
 	echo 'lib=$(LIB)'	>>$$script &&				\
-	echo 'exec $$lib/$(VM) -o $$lib/$(VM) -i $$lib/$(IMAGE) "$$@"'	\
+	echo 'exec $$lib/$(VM) -i $$lib/$(IMAGE) "$$@"'			\
 				>>$$script &&				\
 	chmod +x $$script
 
@@ -405,22 +397,22 @@ go:
 	echo '#!/bin/sh'	>$@ &&					\
 	echo			>>$@ &&					\
 	echo "lib=`pwd`"	>>$@ &&					\
-	echo 'exec $$lib/$(VM) -o $$lib/$(VM) -i $$lib/scsh/scsh.image "$$@"'	\
+	echo 'exec $$lib/$(VM) -i $$lib/scsh/scsh.image "$$@"'		\
 				>>$@ &&					\
 	chmod +x $@
 
 dirs:
 	for dir in $(libdir) $(bindir) $(incdir) $(LIB) $(mandir) $(htmldir); do\
-		{ mkdir -p $$dir && [ -w $$dir ]; } || {		\
-			echo "$$dir not a writable directory" >&2;	\
+		{ mkdir -p $(DESTDIR)$$dir && [ -w $(DESTDIR)$$dir ]; } || {	\
+			echo "$(DESTDIR)$$dir not a writable directory" >&2;	\
 			exit 1;						\
 	}								\
 	done &&								\
 	for dir in								\
 		rts env big opt misc link srfi scsh doc/scsh-manual			\
 		doc/s48-manual/html doc/scsh-paper/html cig; do			\
-		{ mkdir -p $(LIB)/$$dir && [ -w $(LIB)/$$dir ]; } || {		\
-			echo "$(LIB)/$$dir not a writable directory" >&2; 	\
+		{ mkdir -p $(DESTDIR)$(LIB)/$$dir && [ -w $(DESTDIR)$(LIB)/$$dir ]; } || {	\
+			echo "$(DESTDIR)$(LIB)/$$dir not a writable directory" >&2; 	\
 		exit 1;						  		\
 		};							  	\
 	done
@@ -428,25 +420,28 @@ dirs:
 configure: configure.in
 	autoheader && autoconf
 
-clean: clean-cig clean-scsh
-	-rm -f $(VM) *.o c/*/*.o c/*.o 					\
+clean: clean-scsh
+	$(RM)  $(VM) *.o c/*/*.o c/*.o 					\
 		$(IMAGE)						\
 		build/*.tmp $(MANPAGE) build/linker.image		\
 		scheme/debug/*.image scheme/debug/*.debug		\
 		scheme/vm/scheme48vm.c scheme/vm/scheme48heap.c		\
 		go $(distname)
 
-clean-cig:
-	-rm -f cig/*.o $(CIG) $(CIG).image $(LIBCIG)
-
 distclean: clean
-	rm -f Makefile config.log config.status c/sysdep.h config.cache \
-		scsh/machine \
+	$(RM) Makefile config.log config.status c/sysdep.h config.cache \
 		scsh/endian.scm \
-		exportlist.aix
-	$(RM) a.exe $(VM).base $(VM).def $(VM).exp 
+		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
+	@echo 'This command is intended for maintainers to use; it'
+	@echo 'deletes files that may need special tools to rebuild.'
+	$(RM) $(srcdir)/c/{scheme48vm.c,scheme48heap.c,scheme48.h}
+	$(RM) $(srcdir)/build/{linker.image,initial.image}
+
 check:	$(VM) $(IMAGE) scheme/debug/check.scm
 	(								\
 		echo ',batch';						\
@@ -497,8 +492,7 @@ DISTFILES = README COPYING INSTALL RELEASE configure config.sub config.guess \
 		c/sysdep.h.in						\
 		scsh/*.scm scsh/*/*.scm					\
 		scsh/*.[ch] scsh/*/*.[ch]				\
-		scsh/*.scm.in scsh/*/Makefile.inc			\
-		cig/*.scm cig/*.[ch]					\
+		scsh/*.scm.in						\
 		doc/scsh.man						\
 		doc/scsh-manual/*.tex doc/scsh-manual/*.sty		\
 		doc/scsh-manual/man.ps doc/scsh-manual/man.pdf		\
@@ -512,9 +506,9 @@ DISTFILES = README COPYING INSTALL RELEASE configure config.sub config.guess \
 		doc/scsh-paper/html/*.html doc/scsh-paper/html/*.css
 
 
-distname = $(RUNNABLE)-0.`cat build/minor-version-number`
+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 && 		\
@@ -538,7 +532,8 @@ dist: build/initial.image
 	else								\
 		echo "Can't write $$distfile" >&2;			\
 		exit 1;							\
-	fi
+	fi &&								\
+	echo "Hope you already called ./autogen..."
 
 # Increment the minor version number
 inc:
@@ -615,7 +610,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")';	\
@@ -693,7 +688,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\"	\
@@ -731,94 +726,80 @@ i-know-what-i-am-doing:
 	) | $(BUILD_RUNNABLE) -h 5000000 &&					     \
 		mv ../scheme/vm/scheme48vm.c ../scheme/vm/scheme48heap.c ../c
 
-cig: $(CIG) $(CIG).image $(LIBCIG)
-
-
-$(CIG): $(VM) $(IMAGE) $(srcdir)/cig/cig.scm $(srcdir)/cig/libcig.scm
-	(echo ",batch"; \
-	 echo ",translate =scheme48/ $(srcdir)/scheme/"; \
-	 echo ",config ,load $(srcdir)/cig/cig.scm"; \
-	 echo ",config ,load $(srcdir)/cig/libcig.scm"; \
-	 echo ",load-package cig-standalone"; \
-	 echo ",in cig-standalone"; \
-	 echo ",translate =scheme48/ $(LIB)/"; \
-	 echo ",build cig-standalone-toplevel /tmp/cig") \
-	| ./$(VM) -i ./$(IMAGE)
-	$(srcdir)/cig/image2script $(LIB)/$(VM) </tmp/cig > $(CIG)
-	-chmod +x $(CIG)
-	mv /tmp/cig $(srcdir)/cig/cig_bootstrap	
-	$(RM) /tmp/cig
-
-$(CIG).image: $(IMAGE) $(VM) $(srcdir)/cig/cig.scm $(srcdir)/cig/libcig.scm
-	(echo ",batch"; \
-	 echo ",translate =scheme48/ $(srcdir)/scheme/"; \
-	 echo ",config ,load $(srcdir)/cig/cig.scm"; \
-	 echo ",config ,load $(srcdir)/cig/libcig.scm"; \
-	 echo ",load-package cig-aux"; \
-	 echo ",open define-foreign-syntax"; \
-	 echo ",translate =scheme48/ $(LIB)/"; \
-	 echo ",dump /tmp/cig \"(CIG Preloaded -bri)\"") \
-	| ./$(VM) -o ./$(VM) -i ./$(IMAGE)
-	$(srcdir)/cig/image2script $(LIB)/$(VM) \
-			-o $(LIB)/$(VM) \
-			</tmp/cig > $(CIG).image
-	-chmod +x $(CIG).image
-	$(RM) /tmp/cig
-
 #-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
 # SCSH Specifics
 #-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
 scsh: scsh/scsh scsh/scsh.image
 
-SCHEME =scsh/awk.scm \
+SCHEME = \
+	scsh/awk.scm \
+	scsh/command-line.scm \
+	scsh/continuation.scm \
+	scsh/crypt.scm \
+	scsh/configure.scm \
 	scsh/defrec.scm \
-	scsh/endian.scm \
+	scsh/directory.scm \
+	scsh/dot-locking.scm \
 	scsh/enumconst.scm \
+	scsh/environment.scm \
 	scsh/event.scm \
-	scsh/low-interrupt.scm \
+	scsh/fcntl.scm \
+	scsh/fd-syscalls.scm \
 	scsh/fdports.scm \
+	scsh/file.scm \
 	scsh/fileinfo.scm \
 	scsh/filemtch.scm \
 	scsh/filesys.scm \
 	scsh/flock.scm \
 	scsh/fname.scm \
+	scsh/fname-system.scm \
 	scsh/fr.scm \
 	scsh/glob.scm \
-	scsh/dot-locking.scm \
 	scsh/here.scm \
+	scsh/import-os-error-syscall.scm \
+	scsh/lib-dirs.scm \
 	scsh/libscsh.scm \
-	scsh/machine/bufpol.scm \
-	scsh/machine/errno.scm \
-	scsh/machine/fdflags.scm \
-	scsh/machine/netconst.scm \
-	scsh/machine/packages.scm \
-	scsh/machine/signals.scm \
-	scsh/machine/time_dep.scm \
-	scsh/machine/tty-consts.scm \
-	scsh/machine/waitcodes.scm \
+	scsh/low-interrupt.scm \
+	scsh/@machine@/bufpol.scm \
+	scsh/@machine@/errno.scm \
+	scsh/@machine@/fdflags.scm \
+	scsh/@machine@/netconst.scm \
+	scsh/@machine@/packages.scm \
+	scsh/@machine@/signals.scm \
+	scsh/@machine@/time_dep.scm \
+	scsh/@machine@/tty-consts.scm \
+	scsh/@machine@/waitcodes.scm \
 	scsh/md5.scm \
 	scsh/meta-arg.scm \
 	scsh/network.scm \
 	scsh/newports.scm \
+	scsh/port-collect.scm \
+	scsh/process-high-level.scm \
+	scsh/process-state.scm \
+	scsh/process.scm \
 	scsh/procobj.scm \
 	scsh/pty.scm \
 	scsh/rdelim.scm \
+	scsh/resource.scm \
 	scsh/rw.scm \
 	scsh/scsh-condition.scm \
 	scsh/scsh-interfaces.scm \
 	scsh/scsh-package.scm \
 	scsh/scsh-read.scm \
 	scsh/scsh-version.scm \
-	scsh/scsh.scm \
 	scsh/sighandlers.scm \
+	scsh/signal.scm \
 	scsh/startup.scm \
+	scsh/stdio.scm \
 	scsh/stringcoll.scm \
 	scsh/syntax-helpers.scm \
 	scsh/syntax.scm \
-	scsh/syscalls.scm \
+	scsh/system.scm \
+	scsh/temp-file.scm \
 	scsh/time.scm \
 	scsh/top.scm \
 	scsh/tty.scm \
+	scsh/user-group.scm \
 	scsh/utilities.scm \
 	scsh/weaktables.scm \
 	scsh/rx/packages.scm \
@@ -841,23 +822,14 @@ SCHEME =scsh/awk.scm \
 #    	scsh/dbm.scm db.scm ndbm.scm
 #	jcontrol
 
-# Bogus, but it makes the scm->c->o two-ply dependency work.
-# Explicitly giving the .o/.c dependency also makes it go.
-############################################################
-cig/libcig.c:		cig/libcig.scm
-
 scsh/scsh: scsh/scsh-tramp.c
 	$(CC) -o $@ $(CPPFLAGS) $(CFLAGS) \
 	-DVM=\"$(LIB)/$(VM)\" \
 	-DIMAGE=\"$(LIB)/scsh.image\" \
-	scsh/scsh-tramp.c
+	$<
 
-bs:	 build/build-scsh-image
-	sh $(srcdir)/build/build-scsh-image "$(srcdir)" "$(LIB)" "$(IMAGE)" \
-	   "$(VM)" cig/cig.image 
-
-loads = $(srcdir)/scsh/let-opt.scm $(srcdir)/scsh/scsh-interfaces.scm \
-         $(srcdir)/scsh/machine/packages.scm \
+loads =  $(srcdir)/scsh/let-opt.scm $(srcdir)/scsh/scsh-interfaces.scm \
+         $(srcdir)/scsh/@machine@/packages.scm \
 	 $(srcdir)/scsh/rx/packages.scm \
 	 $(srcdir)/scsh/scsh-package.scm \
 	 $(srcdir)/scsh/lib/ccp-pack.scm \
@@ -866,14 +838,19 @@ 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/ `pwd`/scheme/"; \
+	(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) -o ./$(VM) -i $(IMAGE) -h 10000000
+	| ./$(VM) -i $(IMAGE) -h 10000000
 
 # ,flush files => 0k
 # ,flush names => -= 17k
@@ -882,38 +859,63 @@ scsh/scsh.image: $(VM) $(SCHEME) $(IMAGE)
 # ,flush => 550k
 scsh/stripped-scsh.image: $(VM) $(SCHEME) $(IMAGE)
 	(echo ",flush maps source";\
-	 echo ",translate =scheme48/ `pwd`/scheme/"; \
+	 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) -o ./$(VM) -i $(IMAGE) -h 10000000
+	| ./$(VM) -i $(IMAGE) -h 10000000
 
 install-scsh: scsh install-scsh-image install-stripped-scsh-image
-	$(RM) $(bindir)/$(RUNNABLE)
-	$(INSTALL_PROGRAM) $(srcdir)/scsh/scsh $(bindir)/$(RUNNABLE)
-	$(INSTALL_PROGRAM) $(srcdir)/$(LIBSCSHVM) $(libdir)/$(LIBSCSHVM)
-	$(INSTALL_PROGRAM) $(srcdir)/$(LIBSCSH) $(libdir)/$(LIBSCSH)
-	$(RANLIB) $(libdir)/$(LIBSCSH)
+	$(RM) $(DESTDIR)$(bindir)/$(RUNNABLE)
+	$(INSTALL_PROGRAM) $(srcdir)/scsh/scsh $(DESTDIR)$(bindir)/$(RUNNABLE)
+	$(INSTALL_PROGRAM) $(srcdir)/$(LIBSCSHVM) $(DESTDIR)$(libdir)/$(LIBSCSHVM)
+	$(INSTALL_PROGRAM) $(srcdir)/$(LIBSCSH) $(DESTDIR)$(libdir)/$(LIBSCSH)
+	$(RANLIB) $(DESTDIR)$(libdir)/$(LIBSCSH)
 	for f in $(srcdir)/scsh/*.scm $(srcdir)/scsh/*/*.scm; \
-	    do $(INSTALL_DATA) $$f $(LIB)/scsh/; done
+	    do $(INSTALL_DATA) $$f $(DESTDIR)$(LIB)/scsh/; done
 
 install-scsh-image: $(VM) scsh/scsh.image
 	(	echo ',translate =scheme48 $(LIB)';			\
-		echo '(dump-scsh "$(LIB)/scsh.image")';			\
+		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 '(dump-scsh "$(LIB)/stripped-scsh.image")';	\
+		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/machine/*.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=======
+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 > $@

README

@@ -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.
 

RELEASE

@@ -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
@@ -184,7 +320,7 @@ We manage the project using SourceForge:
    - Fix some problems with WAIT-FOR-CHANNELS
    - Fixes in the time zone code
    - Fix a bug in SEND-MESSAGE: There is such a thing as an empty datagram
-   - Renamed string-filter to make-string-filter and char-filter to
+   - Renamed string-filter to make-string-port-filter and char-filter to
      make-char-port-filter
 
 ** API changes

Thanks

@@ -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

autogen.sh

@@ -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

build/build-usual-image

@@ -9,11 +9,13 @@ vm=$4
 initial=$5
 USER=${USER-`logname 2>/dev/null || echo '*GOK*'`}
 
-./$vm -o ./$vm -i $initial batch <<EOF
+./$vm -o ./$vm -i $initial -- batch <<EOF
 ,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)

build/minor-version-number

@@ -1 +1 @@
-6.4
+6.7

c/external.c

@@ -500,71 +500,130 @@ s48_raise_closed_channel_error() {
 void
 s48_raise_os_error(int the_errno) {
   s48_raise_scheme_exception(S48_EXCEPTION_OS_ERROR, 2,
-			     s48_enter_fixnum(the_errno),
+			     s48_enter_integer(the_errno),
 			     s48_enter_string(strerror(the_errno)));
 }
 
 void
 s48_raise_os_error_1(int the_errno, s48_value arg1) {
+
+  s48_value sch_errno = S48_UNSPECIFIC;
+  
+  S48_DECLARE_GC_PROTECT(2);
+  S48_GC_PROTECT_2 (arg1, sch_errno);
+  
+  sch_errno = s48_enter_integer(the_errno);
+
   s48_raise_scheme_exception(S48_EXCEPTION_OS_ERROR, 3,
-			     s48_enter_fixnum(the_errno),
+			     sch_errno,
 			     s48_enter_string(strerror(the_errno)),
 			     arg1);
+
+  S48_GC_UNPROTECT();
 }
 
 void
 s48_raise_os_error_2(int the_errno, s48_value arg1, s48_value arg2) {
+
+  s48_value sch_errno = S48_UNSPECIFIC;
+  
+  S48_DECLARE_GC_PROTECT(3);
+  S48_GC_PROTECT_3 (arg1, arg2, sch_errno);
+  
+  sch_errno = s48_enter_integer(the_errno);
+
   s48_raise_scheme_exception(S48_EXCEPTION_OS_ERROR, 4,
-			     s48_enter_fixnum(the_errno),
+                             sch_errno,
 			     s48_enter_string(strerror(the_errno)),
 			     arg1, arg2);
+  S48_GC_UNPROTECT();
 }
 
 void
 s48_raise_os_error_3(int the_errno, s48_value arg1, s48_value arg2, 
 		     s48_value arg3) {
+
+  s48_value sch_errno = S48_UNSPECIFIC;
+  
+  S48_DECLARE_GC_PROTECT(4);
+  S48_GC_PROTECT_4 (arg1, arg2, arg3, sch_errno);
+  
+  sch_errno = s48_enter_integer(the_errno);
   s48_raise_scheme_exception(S48_EXCEPTION_OS_ERROR, 5,
-			     s48_enter_fixnum(the_errno),
+                             sch_errno,
 			     s48_enter_string(strerror(the_errno)),
 			     arg1, arg2, arg3);
+  S48_GC_UNPROTECT();
 }
 
 void
 s48_raise_os_error_4(int the_errno, s48_value arg1, s48_value arg2, 
 		     s48_value arg3, s48_value arg4) {
+
+  s48_value sch_errno = S48_UNSPECIFIC;
+  
+  S48_DECLARE_GC_PROTECT(5);
+  S48_GC_PROTECT_5 (arg1, arg2, arg3, arg4, sch_errno);
+  
+  sch_errno = s48_enter_integer(the_errno);
   s48_raise_scheme_exception(S48_EXCEPTION_OS_ERROR, 6,
-			     s48_enter_fixnum(the_errno),
+                             sch_errno,
 			     s48_enter_string(strerror(the_errno)),
 			     arg1, arg2, arg3, arg4);
+  S48_GC_UNPROTECT();
 }
 
 void
 s48_raise_os_error_5(int the_errno, s48_value arg1, s48_value arg2, 
 		     s48_value arg3, s48_value arg4, s48_value arg5) {
+
+  s48_value sch_errno = S48_UNSPECIFIC;
+  
+  S48_DECLARE_GC_PROTECT(6);
+  S48_GC_PROTECT_6 (arg1, arg2, arg3, arg4, arg5, sch_errno);
+  
+  sch_errno = s48_enter_integer(the_errno);
   s48_raise_scheme_exception(S48_EXCEPTION_OS_ERROR, 7,
-			     s48_enter_fixnum(the_errno),
+                             sch_errno,
 			     s48_enter_string(strerror(the_errno)),
 			     arg1, arg2, arg3, arg4, arg5);
+  S48_GC_UNPROTECT();
 }
 
 void
 s48_raise_os_error_6(int the_errno, s48_value arg1, s48_value arg2, 
 		     s48_value arg3, s48_value arg4, s48_value arg5,
 		     s48_value arg6) {
+
+  s48_value sch_errno = S48_UNSPECIFIC;
+  
+  S48_DECLARE_GC_PROTECT(7);
+  S48_GC_PROTECT_7 (arg1, arg2, arg3, arg4, arg5, arg6, sch_errno);
+  
+  sch_errno = s48_enter_integer(the_errno);
   s48_raise_scheme_exception(S48_EXCEPTION_OS_ERROR, 8,
-			     s48_enter_fixnum(the_errno),
+                             sch_errno,
 			     s48_enter_string(strerror(the_errno)),
 			     arg1, arg2, arg3, arg4, arg5, arg6);
+  S48_GC_UNPROTECT();
 }
 
 void
 s48_raise_os_error_7(int the_errno, s48_value arg1, s48_value arg2, 
 		     s48_value arg3, s48_value arg4, s48_value arg5,
 		     s48_value arg6, s48_value arg7) {
+
+  s48_value sch_errno = S48_UNSPECIFIC;
+  
+  S48_DECLARE_GC_PROTECT(8);
+  S48_GC_PROTECT_8 (arg1, arg2, arg3, arg4, arg5, arg6, arg7, sch_errno);
+  
+  sch_errno = s48_enter_integer(the_errno);
   s48_raise_scheme_exception(S48_EXCEPTION_OS_ERROR, 9,
-			     s48_enter_fixnum(the_errno),
+                             sch_errno,
 			     s48_enter_string(strerror(the_errno)),
 			     arg1, arg2, arg3, arg4, arg5, arg6, arg7);
+  S48_GC_UNPROTECT();
 }
 
 void

c/init.c

@@ -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;

c/main.c

@@ -24,22 +24,22 @@
 
 /* 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 */
 
 
 
-char ** process_args(char **argv,
-		     long *heap_size,
-		     long *stack_size,
-		     char **object_file,
-		     char **image_name);
+void process_args(char **argv,
+                  long *heap_size,
+                  long *stack_size,
+                  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. */
 
-  argv=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);
 }

c/scheme48.h

@@ -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)))

c/scheme48heap.c

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

c/scheme48vm-prelude.h

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

c/scheme48vm.c

@@ -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;}}

c/srfi/srfi-27.c

@@ -117,6 +117,9 @@ static double mrg32k3a(state_t *s) { /* (double), in {0..m1-1} */
 s48_value mrg32k3a_pack_state1(s48_value state) {
   s48_value result;
   state_t   s;
+  S48_DECLARE_GC_PROTECT(1);
+
+  S48_GC_PROTECT_1(state); /* s48_extract_integer may GC */
 
 #define REF(i) (double)s48_extract_integer(S48_VECTOR_REF(state, (long)(i)))
 
@@ -130,6 +133,8 @@ s48_value mrg32k3a_pack_state1(s48_value state) {
 
 #undef REF
 
+  S48_GC_UNPROTECT();
+
   /* box s into a Scheme object */
   result = S48_MAKE_VALUE(state_t);
   S48_SET_VALUE(result, state_t, s);
@@ -137,9 +142,12 @@ s48_value mrg32k3a_pack_state1(s48_value state) {
 }
 
 s48_value mrg32k3a_unpack_state1(s48_value state) {
-  s48_value result;
+  s48_value result = S48_UNSPECIFIC;
   state_t   s;
 
+  S48_DECLARE_GC_PROTECT(1);
+  S48_GC_PROTECT_1(result);
+
   /* unbox s from the Scheme object */
   s = S48_EXTRACT_VALUE(state, state_t);
 
@@ -161,6 +169,8 @@ s48_value mrg32k3a_unpack_state1(s48_value state) {
 
 #undef SET
 
+  S48_GC_UNPROTECT();
+
   return result;
 }
 

c/unix/event.c

@@ -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"

c/unix/fd-io.c

@@ -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"

c/unix/io.c

@@ -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)
 {

c/unix/socket.c

@@ -381,11 +381,38 @@ s48_close_socket_half(s48_value channel, s48_value input_p)
 static s48_value
 s48_get_host_name(void)
 {
-  char	mbuff[MAXHOSTNAMELEN];
+  char		*mbuff = NULL;
+  size_t	mbuff_len = 0;
+  int		status = 0;
+  s48_value	name;
 
-  if (gethostname(mbuff, sizeof(mbuff)) < 0)
+  do {
+    char	*tmp;
+
+    mbuff_len += 256; /* Initial guess */
+    tmp = (char *) realloc(mbuff, mbuff_len);
+
+    if (tmp == NULL) {
+      free(mbuff);
+      s48_raise_os_error(ENOMEM);
+    }
+    else
+      mbuff = tmp;
+  } while (((status = gethostname(mbuff, mbuff_len)) == 0
+	    && !memchr(mbuff, '\0', mbuff_len))
+#ifdef ENAMETOOLONG
+	   || errno == ENAMETOOLONG
+#endif
+	   );
+
+  if (status != 0 && errno != 0) {
+    /* gethostname failed, abort.  */
+    free(mbuff);
     s48_raise_os_error(errno);
-  
-  return s48_enter_string(mbuff);
+  }
+
+  name = s48_enter_string(mbuff);
+  free(mbuff);
+  return name;
 }
 

cig/.gitignore

@@ -1,3 +0,0 @@
-cig
-cig.image
-

cig/image2script

@@ -1,48 +0,0 @@
-#!/bin/sh -
-
-binary=$1
-shift
-
-if [ `echo $binary | wc -c` -gt 28 ] ; then
-    echo "#!/bin/sh -"
-    echo exec $binary $* -i '"$0"' '"$@"'
-
-elif [ $# -gt 0 ] ; then
-    echo '#!'$binary \\
-    echo $* -i
-
-else echo '#!'$binary -i
-fi
-
-exec cat
-
-
-# This program reads an S48 image from stdin and turns it into
-# an executable by prepending a #! prefix. The vm and its
-# args are passed to this program on the command line.
-#
-# If the vm binary is 27 chars or less, then we can directly
-# execute the vm with one of these scripts:
-#     No args:
-#         image2script /usr/local/bin/svm <image
-#     outputs this script:
-#	  #!/usr/local/bin/svm -i
-#	  ...image bits follow...
-#    
-#     Args:
-#         image2script /usr/bin/svm -h 4000000 -o /usr/bin/svm <image
-#     outputs this script:
-#	  #!/usr/bin/svm \
-#	  -h 4000000 -o /usr/bin/svm -i
-#	  ...image bits follow...
-#
-# The exec system call won't handle the #! line if it contains more than
-# 32 chars, so if the vm binary is over 28 chars, we have to use a /bin/sh
-# trampoline.
-#     image2script /user1/lecturer/shivers/vc/scsh/s48/lib/svm -h 4000000 < ...
-# outputs this script:
-#     #!/bin/sh -
-#     exec /user1/lecturer/shivers/vc/scsh/s48/lib/svm -h 4000000 -i $0 $*
-#     ...image bits follow...
-#
-# 	-Olin

cig/libcig.c

@@ -1,117 +0,0 @@
-/* This is an Scheme48/C interface file, 
-** automatically generated by a hacked version of cig 3.0.
-step 4
-*/
-
-#include <stdio.h>
-#include <stdlib.h> /* For malloc. */
-#include "libcig.h"
-
-s48_value df_strlen_or_false(s48_value g1)
-{
-    extern s48_value strlen_or_false(const char * );
-    s48_value ret1 = S48_FALSE;
-    S48_DECLARE_GC_PROTECT(1);
-    s48_value r1;
-
-    
-    
-    S48_GC_PROTECT_1(ret1);
-    r1 = strlen_or_false((const char * )AlienVal(g1));
-    ret1 = r1;
-    S48_GC_UNPROTECT();
-    return ret1;
-}
-
-s48_value df_cstring_nullp(s48_value g1)
-{
-    extern int cstring_nullp(const char * );
-    s48_value ret1 = S48_FALSE;
-    S48_DECLARE_GC_PROTECT(1);
-    int r1;
-
-    
-    
-    S48_GC_PROTECT_1(ret1);
-    r1 = cstring_nullp((const char * )AlienVal(g1));
-    ret1 = ENTER_BOOLEAN(r1);
-    S48_GC_UNPROTECT();
-    return ret1;
-}
-
-s48_value df_c2scheme_strcpy_free(s48_value g1, s48_value g2)
-{
-    extern int c2scheme_strcpy_free(s48_value , char* );
-    s48_value ret1 = S48_FALSE;
-    S48_DECLARE_GC_PROTECT(1);
-    int r1;
-
-    
-    
-    S48_GC_PROTECT_1(ret1);
-    r1 = c2scheme_strcpy_free(g1, (char* )AlienVal(g2));
-    ret1 = ENTER_BOOLEAN(r1);
-    S48_GC_UNPROTECT();
-    return ret1;
-}
-
-s48_value df_c2scheme_strcpy(s48_value g1, s48_value g2)
-{
-    extern int c2scheme_strcpy(s48_value , char* );
-    s48_value ret1 = S48_FALSE;
-    S48_DECLARE_GC_PROTECT(1);
-    int r1;
-
-    
-    
-    S48_GC_PROTECT_1(ret1);
-    r1 = c2scheme_strcpy(g1, (char* )AlienVal(g2));
-    ret1 = ENTER_BOOLEAN(r1);
-    S48_GC_UNPROTECT();
-    return ret1;
-}
-
-s48_value df_c_veclen(s48_value g1)
-{
-    extern s48_value c_veclen(long* );
-    s48_value ret1 = S48_FALSE;
-    S48_DECLARE_GC_PROTECT(1);
-    s48_value r1;
-
-    
-    
-    S48_GC_PROTECT_1(ret1);
-    r1 = c_veclen((long* )AlienVal(g1));
-    ret1 = r1;
-    S48_GC_UNPROTECT();
-    return ret1;
-}
-
-s48_value df_free(s48_value g1)
-{
-    
-
-    
-    free((void* )AlienVal(g1));
-    return S48_FALSE;
-}
-
-s48_value df_set_strvec_carriers(s48_value g1, s48_value g2)
-{
-    extern void set_strvec_carriers(s48_value , char** );
-
-    
-    set_strvec_carriers(g1, (char** )AlienVal(g2));
-    return S48_FALSE;
-}
-
-void s48_init_cig(void)
-{
-    S48_EXPORT_FUNCTION(df_strlen_or_false);
-    S48_EXPORT_FUNCTION(df_cstring_nullp);
-    S48_EXPORT_FUNCTION(df_c2scheme_strcpy_free);
-    S48_EXPORT_FUNCTION(df_c2scheme_strcpy);
-    S48_EXPORT_FUNCTION(df_c_veclen);
-    S48_EXPORT_FUNCTION(df_free);
-    S48_EXPORT_FUNCTION(df_set_strvec_carriers);
-}

cig/libcig.h

@@ -1,32 +0,0 @@
-#include "scheme48.h"
-
-/* StobData is used by fdports.c. It should be changed over to STOB_REF
-** by removing the extra indirection. */
-#define StobData(x) (S48_ADDRESS_AFTER_HEADER(x, s48_value))
-
-#define IsChar(x) ((((long) x) & 0xff) == S48_CHAR) 
-/* JMG: untested !! */
-
-#define StrByte(x, i)  ((i) + S48_ADDRESS_AFTER_HEADER((x), char))
-#define cig_string_body(x) (S48_ADDRESS_AFTER_HEADER((x), char))
-
-#define AlienVal(x) (S48_STOB_REF((x),0))
-/* JMG: no () around this, because it's a do..while(0) */
-#define SetAlienVal(x, v) S48_STOB_SET((x), 0, (v))
-
-/*  JMG: some hacks to leave to old sources untouched */
-#define ENTER_BOOLEAN(x) (x ? S48_TRUE : S48_FALSE)
-#define EXTRACT_BOOLEAN(x) ((x==S48_TRUE) ? 1 : 0)
-/* #define ENTER_FIXNUM(x) (s48_enter_fixnum(x)) */
-/* #define SCHFALSE S48_FALSE */
-
-extern char *scheme2c_strcpy(s48_value sstr);
-
-extern s48_value strlen_or_false(const char *s);
-
-extern char *copystring_or_die(const char *);
-extern char *copystring(char *, const char *);
-
-extern s48_value strlen_or_false(const char *);
-
-extern void cig_check_nargs(int arity, int nargs, const char *fn);

cig/libcig.scm

@@ -1,139 +0,0 @@
-;;; (DEFINE-FOREIGN ...) forms are expanded by Cig into Scheme stubs.
-;;; These stubs reference some support procedures to rep-convert the
-;;; standard reps (e.g., string). This structure provides these support 
-;;; procedures.
-;;;
-;;; We export three kinds of things:
-;;; - Type predicates that aren't in the R4RS env (e.g., FIXNUM?).
-;;; - Carrier makers for making boxes to return things in.
-;;; - Scheme-side rep-converters for return values.
-
-(define-structure cig-aux
-  (export cstring-null?
-	  C->scheme-string
-	  C->scheme-string-w/len
-	  C->scheme-string-w/len-no-free
-	  C-string-vec->Scheme&free
-	  C-string-vec->Scheme ; Bogus, because clients not reentrant.
-	  string-carrier->string
-	  string-carrier->string-no-free
-	  fixnum?
-	  make-string-carrier
-	  make-alien
-	  alien?
-	  )
-  (open scheme code-vectors define-foreign-syntax)
-
-  (begin
-    (define min-fixnum (- (expt 2 29)))
-    (define max-fixnum (- (expt 2 29) 1))
-    (define (fixnum? x) (and (integer? x) (<= min-fixnum x max-fixnum)))
-
-    ;; Internal utility.
-    (define (mapv! f v)
-      (let ((len (vector-length v)))
-	(do ((i 0 (+ i 1)))
-	    ((= i len) v)
-	  (vector-set! v i (f (vector-ref v i))))))
-
-    ;; Make a carrier for returning strings. 
-    ;; It holds a raw C string and a fixnum giving the length of the string.
-    (define (make-string-carrier) (cons (make-alien) 0))
-
-    (define (make-alien) (make-code-vector 4 0))
-    (define (alien? x) (and (code-vector? x) (= 4 (code-vector-length x)))) ; BOGUS
-
-
-;;; C/Scheme string and vector conversion
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; Generally speaking, in the following routines, 
-;;; a NULL C string param causes a function to return #f.
-(foreign-init-name "cig") 
-
-(define-foreign %cstring-length-or-false
-  (strlen_or_false ((C "const char * ~a") cstr))
-  desc)
-
-(define-foreign cstring-null?
-  (cstring_nullp ((C "const char * ~a") cstr))
-  bool)
-
-(define-foreign %copy-c-string&free
-  (c2scheme_strcpy_free (string-desc sstr) ((C char*) cstr))
-  bool)
-
-(define-foreign %copy-c-string
-  (c2scheme_strcpy (string-desc sstr) ((C char*) cstr))
-  bool)
-
-(define (C->scheme-string cstr)
-  (cond ((%cstring-length-or-false cstr)
-	 => (lambda (strlen)
-	      (let ((str (make-string strlen)))
-		(%copy-c-string&free str cstr)
-		str)))
-	(else #f)))
-
-(define (C->scheme-string-w/len cstr len)
-  (and (integer? len)
-       (let ((str (make-string len)))
-	 (%copy-c-string&free str cstr)
-	 str)))
-
-(define (C->scheme-string-w/len-no-free cstr len)
-  (and (integer? len)
-       (let ((str (make-string len)))
-	 (%copy-c-string str cstr)
-	 str)))
-
-(define (string-carrier->string carrier)
-  (C->scheme-string-w/len (car carrier) (cdr carrier)))
-
-(define (string-carrier->string-no-free carrier)
-  (C->scheme-string-w/len-no-free (car carrier) (cdr carrier)))
-
-;;; Return the length of a null-terminated C word vector. 
-;;; Does not count the null word as part of the length.
-;;; If vector is NULL, returns #f.
-
-(define-foreign %c-veclen-or-false
-  (c_veclen ((C long*) c-vec))
-  desc) ; integer or #f if arg is NULL.
-
-;;; CVEC is a C vector of char* strings, length VECLEN.
-;;; This procedure converts a C vector of strings into a Scheme vector of 
-;;; strings. The C vector and its strings are all assumed to come from
-;;; the malloc heap; they are returned to the heap when the rep-conversion
-;;; is done.
-;;;
-;;; Hack: if VECLEN is #f, CVEC is assumed to be NULL terminated, and
-;;; its length is calculated thusly.
-
-(define (C-string-vec->Scheme&free cvec veclen)
-  (let ((vec (make-vector (or veclen (%c-veclen-or-false cvec) 0))))
-    (mapv! (lambda (ignore) (make-string-carrier)) vec)
-    (%set-string-vector-carriers! vec cvec)
-    (C-free cvec)
-    (mapv! string-carrier->string vec)))
-
-(define (C-string-vec->Scheme cvec veclen) ; No free.
-  (let ((vec (make-vector (or veclen (%c-veclen-or-false cvec) 0))))
-    (mapv! (lambda (ignore) (make-string-carrier)) vec)
-    (%set-string-vector-carriers! vec cvec)
-    (mapv! string-carrier->string-no-free vec)))
-
-
-(define-foreign C-free (free ((C void*) ptr)) no-declare ; for SunOS 4.x 
-  ignore)
-
-(define-foreign %set-string-vector-carriers!
-  (set_strvec_carriers (vector-desc svec) ((C char**) cvec))
-  ignore)
-
-)) ; egakcap
-
-
-
-
-

cig/libcig1.c

@@ -1,163 +0,0 @@
-/* Generic routines for Scheme48/C interfacing -- mostly for converting
-** strings and null-terminated vectors back and forth.
-** Copyright (c) 1993 by Olin Shivers.
-*/
-
-#include "libcig.h"
-#include <string.h>
-#include <stddef.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <errno.h>
-
-#define Malloc(type,n)	((type *) malloc(sizeof(type)*(n)))
-#define Free(p)		(free((char *)(p)))
-
-/* (c2scheme_strcpy dest_scheme_string source_C_string)
-** Copies C string's chars into Scheme string. Return #t.
-** If C string is NULL, do nothing and return #f.
-*/
-
-int c2scheme_strcpy(s48_value sstr, const char *cstr)
-{
-    if( cstr ) {
-	strncpy( (char*) StobData(sstr), cstr, S48_STRING_LENGTH(sstr) );
-	return 1;
-	}
-    else return 0;
-    }
-
-
-/* Same as above, but free the C string when we are done. */
-int c2scheme_strcpy_free(s48_value sstr, const char *cstr)
-{
-    if( cstr ) {
-	strncpy( (char*) StobData(sstr), cstr, S48_STRING_LENGTH(sstr) );
-	Free(cstr);
-	return 1;
-	}
-    else return 0;
-    }
-
-char *scheme2c_strcpy(s48_value sstr)
-{
-    char *result;
-    int slen;
-
-    slen = S48_STRING_LENGTH(sstr);
-    result = Malloc(char, slen+1);
-
-    if( result == NULL ) {
-        fprintf(stderr,
-		"Fatal error: C stub tried to copy Scheme string,\n"
-		"but malloc failed on arg 0x%x, errno %d.\n",
-		sstr, errno);
-	exit(-1);
-	}
-
-    memcpy(result, cig_string_body(sstr), slen);
-    result[slen] = '\000';
-    return result;
-    }
-
-
-/*  One arg, a zero-terminated C word vec. Returns length.
-**  The terminating null is not counted. Returns #f on NULL.
-*/
-
-s48_value c_veclen(const long *vec)
-{
-    const long *vptr = vec;
-    if( !vptr ) return S48_FALSE;
-    while( *vptr ) vptr++;
-    return s48_enter_fixnum(vptr - vec);
-    }
-    
-
-/* Copy string from into string to. If to is NULL, malloc a fresh string
-** (if the malloc loses, return NULL).
-** If from is NULL, then
-** - if to is NULL, do nothing and return NULL.
-** - Otherwise, deposit a single nul byte.
-** Under normal conditions, this routine returns the destination string.
-**
-** The little boundary cases of this procedure are a study in obfuscation
-** because C doesn't have a reasonable string data type. Give me a break.
-*/
-char *copystring(char *to, const char *from)
-{
-    if( from ) {
-	int slen = strlen(from)+1;
-	if( !to && !(to = Malloc(char, slen)) ) return NULL;
-	else return memcpy(to, from, slen);
-	}
-
-    else
-	return to ? *to = '\000', to : NULL;
-    }
-
-/* As in copystring, but if malloc loses, print out an error msg and croak. */
-char *copystring_or_die(const char *str ) /* Note: NULL -> NULL. */
-{
-    if( str ) {
-	int len = strlen(str)+1;
-	char *new_str = Malloc(char, len);
-	if( ! new_str ) {
-	    fprintf(stderr, "copystring: Malloc failed.\n");
-	    exit(-1);
-	    }
-	return memcpy(new_str, str, len);
-	}
-    else return NULL;
-    }
-
-int cstring_nullp( const char *s ) { return ! s; }
-
-s48_value strlen_or_false(const char *s)
-{ return s ?  s48_enter_fixnum(strlen(s)) : S48_FALSE; }
-
-
-
-/* svec is a Scheme vector of C string carriers. Scan over the C strings
-** in cvec, and initialise the corresponding string carriers in svec.
-*/
-void set_strvec_carriers(s48_value svec, char const * const * cvec)
-{
-    int svec_len = S48_VECTOR_LENGTH(svec);
-    char const * const * cv = cvec;
-    int i = 0;
-       
-    /* JMG: now using normal array access, instead of pointer++ on a s48_value */
-    for(; svec_len > 0; i++, cv++, svec_len-- ) {
-      s48_value carrier, alien;
-      int strl;
-   
-	/* *sv is a (cons (make-alien <c-string>) <string-length>). */
-	carrier = S48_VECTOR_REF(svec,i);
-	alien = S48_CAR(carrier);
-	strl = strlen(*cv);
-	S48_SET_CDR(carrier, s48_enter_fixnum(strl));
-	SetAlienVal(alien, (long) *cv);
-    }
-}
-
-/* Helper function for arg checking. Why bother, actually? */
-void cig_check_nargs(int arity, int nargs, const char *fn)
-{
-   if( arity != nargs ) {
-       fprintf(stderr,
-	       "Cig fatal error (%s) -- C stub expected %d arg%s, "
-	       "but got %d.\n",
-	       fn, arity, (arity == 1) ? "" : "s", nargs);
-       exit(-1);
-       }
-   }
-/* void ciginit(){ */
-/*   S48_EXPORT_FUNCTION (df_strlen_or_false); */
-/*   S48_EXPORT_FUNCTION (df_c_veclen); */
-/*   S48_EXPORT_FUNCTION (df_set_strvec_carriers); */
-/*   S48_EXPORT_FUNCTION (df_c2scheme_strcpy_free); */
-/*   S48_EXPORT_FUNCTION (df_cstring_nullp); */
-/*   S48_EXPORT_FUNCTION (df_free); */
-/*   S48_EXPORT_FUNCTION (df_c2scheme_strcpy); */
-/* } */

config.sub

@@ -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)

configure.in

@@ -3,27 +3,7 @@ dnl
 dnl We might want AC_WORDS_BIGENDIAN in the future.
 dnl We might want AC_CHAR_UNSIGNED in the future.
 dnl
-dnl The -cckr (K&R) flag is for the IRIX C compiler.  If this is left
-dnl out, scheme48vm.c breaks because the rather pedantic SGI compiler
-dnl decides that a char is not the same thing as an unsigned char.
-dnl - Bryan O'Sullivan 3/94
-dnl Note, this test didn't work correctly on Sun's which take -cckr as a
-dnl synonym for -c. (HCC)
 
-define(S48_CFLAG_CKR, [dnl
-	if test "z$GCC" = z; then
-		AC_MSG_CHECKING([-cckr])
-		oldCFLAGS="$CFLAGS"
-		CFLAGS="$CFLAGS -cckr"
-		AC_TRY_RUN([int main() { return 0;}],
-			[AC_MSG_RESULT(yes)],
-			[AC_MSG_RESULT(no)
-				CFLAGS="$oldCFLAGS"],
-			[AC_MSG_RESULT(no)
-				CFLAGS="$oldCFLAGS"])
-	fi
-])dnl
-dnl
 define(S48_POSIX_LIBC, [dnl
 echo checking for RISC/OS POSIX library lossage
 if test -f /usr/posix/usr/lib/libc.a; then
@@ -53,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"])
@@ -79,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)])
@@ -100,15 +109,13 @@ 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])	
-  ${CC} -o scsh_aux scsh/scsh_aux.c
+  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])
   AC_DEFINE_UNQUOTED(SIGNR_2, `./scsh_aux 2`, [scsh interrupt for signal 2])
   AC_DEFINE_UNQUOTED(SIGNR_3, `./scsh_aux 3`, [scsh interrupt for signal 3])
@@ -140,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, [
@@ -165,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)])
@@ -191,16 +198,23 @@ AC_DEFUN(SCSH_SOCKLEN_T,[
                    AC_DEFINE(socklen_t,int)])])
 ])
 dnl -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
+define(SCSH_CREATE_BUILD_DIRS, [dnl
+	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])
-     S48_CFLAG_CKR
      AC_PROG_INSTALL
      AC_PROG_RANLIB
      AC_C_CONST
@@ -217,24 +231,21 @@ AC_INIT(c/scheme48vm.c)
      case "$host" in
   ## CX/UX
   m88k-harris-cxux* )
-    dir=cxux
+    machine=cxux
     CC="cc -Xa"
     CFLAGS="-O"
     LDFLAGS="-O -Wl,-Bexport"
     AC_DEFINE(HAVE_HARRIS, 1, [Define to 1 on m88k-harris-cxux])
   ;;
-    
+
   ## DEC Ultrix
   mips-dec-ultrix* )
-    dir=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
   hppa*-hp-hpux* )
-    dir=hpux
+    machine=hpux
     LDFLAGS="-Wl,-E"
     if test ${CC} = cc; then
       CFLAGS="-Ae -O +Obb1800"
@@ -243,10 +254,10 @@ 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* )
-     dir=aix
+     machine=aix
      LDFLAGS="-O"
      if test ${CC} = gcc; then
        LDFLAGS_AIX="-Xlinker -bexport:exportlist.aix"
@@ -259,7 +270,7 @@ AC_INIT(c/scheme48vm.c)
 
   ## Linux
   *-*-linux* )
-  dir=linux
+  machine=linux
   # gross, but needed for some older a.out systems for 0.4.x
   LIBS=-lc
   SCSH_ELF
@@ -267,52 +278,58 @@ AC_INIT(c/scheme48vm.c)
 
   ## NetBSD and FreeBSD ( and maybe 386BSD also)
   *-*-*bsd*|*-*-darwin* )
-  dir=bsd
+  machine=bsd
   SCSH_ELF
   ;;
 
   ## NeXT
   *-next-* )
-    dir=next
+    machine=next
     CC="$CC -posix"
     AC_DEFINE(HAVE_SIGACTION)
   ;;
-  
+
   ## SGI IRIX
   mips-sgi-irix* )
-    dir=irix
+    machine=irix
     S48_CFLAG_CKR
     INSTALL='$(srcdir)/install-sh'
   ;;
 
   ## SunOS
   sparc*-sun-sunos* )
-   dir=sunos
+   machine=sunos
   ;;
-  
+
   ## Solaris - Sparc and i386
     *-*-solaris* )
-    dir=solaris
+    machine=solaris
     AC_DEFINE(HAVE_NLIST)
     ;;
-  
+
   ## NT - cygwin32
   *-*-cygwin* )
     AC_DEFINE(CYGWIN, 1, [Define to 1 on cygwin])
-    dir=cygwin32
+    machine=cygwin32
     EXEEXT=".exe"
   ;;
-  
+
+  ## The GNU Hurd
+  *-*-gnu* )
+  machine=gnu
+  SCSH_ELF
+  ;;
+
   ## Generic Configuration
   * )
-  dir=generic
+  machine=generic
   echo "WARNING: "
   echo "WARNING: Using generic configuration."
   echo "WARNING: See doc/porting.txt for more information."
   echo "WARNING: "
   ;;
 esac
-     (cd $srcdir/scsh &&  rm -rf machine && ln -s $dir machine)
+     (mkdir -p ./scsh/$machine scsh/rx c/unix c/srfi)
 
      AC_CHECK_LIB(m, main)
      AC_CHECK_LIB(dl, main)
@@ -329,28 +346,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.")])])
 
 
@@ -370,17 +389,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)
@@ -388,14 +458,14 @@ fail
      AC_SUBST(CFLAGS)
      AC_SUBST(CFLAGS1)
      AC_SUBST(EXEEXT)
-     AC_SUBST(ENDIAN)
+     AC_SUBST(ENDIAN) #does currently not occur
      AC_SUBST(LDFLAGS)
      AC_SUBST(LDFLAGS_AIX)
      AC_SUBST(LIBS)
      AC_SUBST(TMPDIR)
+     AC_SUBST(machine)
 
-    
-AC_CONFIG_FILES(Makefile scsh/endian.scm scsh-config)
+AC_CONFIG_FILES(Makefile scsh-config)
 AC_CONFIG_COMMANDS([scsh-config+x],[chmod +x scsh-config])
 AC_OUTPUT
 

doc/scsh-manual/Makefile

@@ -1,28 +1,26 @@
-.SUFFIXES: .idx .ind .tex .dvi .ps .pdf $(.SUFFIXES)
+.SUFFIXES: .tex .dvi .ps .pdf $(.SUFFIXES)
 
 TEX=	front.tex intro.tex procnotation.tex syscalls.tex network.tex \
 	strings.tex awk.tex miscprocs.tex running.tex
 
 TEX2PAGE=tex2page
 
-man.dvi: $(TEX) man.ind
-man.ind: man.idx
-man.pdf: $(TEX) man.ind
+man.dvi: $(TEX)
+man.pdf: $(TEX)
 
 .dvi.ps:
 	dvips -j0 -o $@ $<
 
 .tex.dvi:
 	latex $< && latex $<
+	makeindex $(<:.tex=.idx)
 	rm $*.log
 
 .tex.pdf:
 	pdflatex $< && thumbpdf $@ && pdflatex $<
+	makeindex $(<:.tex=.idx)
 	rm $*.log
 
-.idx.ind:
-	makeindex $<
-
 clean:
 	-rm -f *.log *.png man.out man.dvi man.ps man.pdf thumb*.png
 	rm -rf html

doc/scsh-manual/awk.tex

@@ -42,7 +42,7 @@ characters.
     procedure is invoked as follows:
     %
     \codex{(\var{reader} \var{[port]}) $\longrightarrow$ 
-	   \textrm{\textit{{\str} or eof}}}
+           \textrm{\textit{{\str} or eof}}}
     %
     A record is a sequence of characters terminated by one of the characters
     in \var{delims} or eof. If \var{elide-delims?} is true, then a contiguous
@@ -58,16 +58,16 @@ characters.
 
     The \var{handle-delim} argument controls what is done with the record's
     terminating delimiter.
-	\begin{inset}
-	\begin{tabular}{lp{0.6\linewidth}}
-	\ex{'trim} & Delimiters are trimmed. (The default)\\
-	\ex{'split}& Reader returns delimiter string as a second argument.
-		If record is terminated by EOF, then the eof object is 
-		returned as this second argument. \\
-	\ex{'concat} & The record and its delimiter are returned as
-		       a single string.
-	\end{tabular}
-	\end{inset}
+        \begin{inset}
+        \begin{tabular}{lp{0.6\linewidth}}
+        \ex{'trim} & Delimiters are trimmed. (The default)\\
+        \ex{'split}& Reader returns delimiter string as a second argument.
+                If record is terminated by EOF, then the eof object is 
+                returned as this second argument. \\
+        \ex{'concat} & The record and its delimiter are returned as
+                       a single string.
+        \end{tabular}
+        \end{inset}
 
     The reader procedure returned takes one optional argument, the port
     from which to read, which defaults to the current input port. It returns
@@ -85,21 +85,21 @@ characters.
 \begin{desc}
 These functions return a parser function that can be used as follows:
 \codex{(\var{parser} \var{string} \var{[start]}) $\longrightarrow$
-	\var{string-list}}
+        \var{string-list}}
 
     The returned parsers split strings into fields defined
     by regular expressions.  You can parse by specifying a pattern that
     \emph{separates} fields, a pattern that \emph{terminates} fields, or
     a pattern that \emph{matches} fields:
-	\begin{inset}
-	\begin{tabular}{l@{\qquad}l}	
-    	Procedure &			Pattern \\ \hline
-    	\ex{field-splitter} &    	matches fields	\\
-    	\ex{infix-splitter} &		separates fields \\
-    	\ex{suffix-splitter}&		terminates fields \\
-	\ex{sloppy-suffix-splitter} &	terminates fields
-	\end{tabular}
-	\end{inset}
+        \begin{inset}
+        \begin{tabular}{l@{\qquad}l}    
+        Procedure &                     Pattern \\ \hline
+        \ex{field-splitter} &           matches fields  \\
+        \ex{infix-splitter} &           separates fields \\
+        \ex{suffix-splitter}&           terminates fields \\
+        \ex{sloppy-suffix-splitter} &   terminates fields
+        \end{tabular}
+        \end{inset}
     
     These parser generators are controlled by a range of options, so that you
     can precisely specify what kind of parsing you want. However, these
@@ -109,7 +109,7 @@ These functions return a parser function that can be used as follows:
 \begin{tightinset}
 \begin{tabular}{l@{\quad=\quad }ll}
  \var{delim} & \ex{(rx (| (+ white) eos))}    & (suffix delimiter: white space or eos) \\
- \multicolumn{1}{l}{}   	     & \ex{(rx (+ white))}   & (infix  delimiter: white space) \\
+ \multicolumn{1}{l}{}                & \ex{(rx (+ white))}   & (infix  delimiter: white space) \\
 
  \var{field}    & \verb|(rx (+ (~ white)))|   & (non-white-space) \\
     
@@ -147,10 +147,10 @@ These functions return a parser function that can be used as follows:
 
     The boolean \var{handle-delim} determines what to do with delimiters.
     \begin{tightinset}\begin{tabular}{ll}
-    \ex{'trim} &	Delimiters are thrown away after parsing. (default) \\
-    \ex{'concat} &	Delimiters are appended to the field preceding them. \\
-    \ex{'split} &	Delimiters are returned as separate elements in
-			the field list.
+    \ex{'trim} &        Delimiters are thrown away after parsing. (default) \\
+    \ex{'concat} &      Delimiters are appended to the field preceding them. \\
+    \ex{'split} &       Delimiters are returned as separate elements in
+                        the field list.
     \end{tabular}
     \end{tightinset}
 
@@ -165,10 +165,10 @@ These functions return a parser function that can be used as follows:
     
     The field parser produced is a procedure that can be employed as
     follows:
-	\codex{(\var{parse} \var{string} \var{[start]}) \evalto \var{string-list}}
+        \codex{(\var{parse} \var{string} \var{[start]}) \evalto \var{string-list}}
     The optional \var{start} argument (default 0) specifies where in the string
     to begin the parse. It is an error if
-    	$\var{start} > \ex{(string-length \var{string})}$.
+        $\var{start} > \ex{(string-length \var{string})}$.
     
     The parsers returned by the four parser generators implement different
     kinds of field parsing:
@@ -184,13 +184,13 @@ These functions return a parser function that can be used as follows:
     \ex{("foo")}, and \ex{"foo"} is an error.
 
     The syntax of suffix-delimited records is:
-	\begin{inset}
-	\begin{tabular}{lcll}
-	\synvar{record} & ::=  & \ex{""} \qquad (Empty record) \\
-	                &  $|$ & \synvar{element} \synvar{delim} 
+        \begin{inset}
+        \begin{tabular}{lcll}
+        \synvar{record} & ::=  & \ex{""} \qquad (Empty record) \\
+                        &  $|$ & \synvar{element} \synvar{delim} 
                                  \synvar{record}
-	\end{tabular}
-	\end{inset}
+        \end{tabular}
+        \end{inset}
 
     It is an error if a non-empty record does not end with a delimiter.
     To make the last delimiter optional, make sure the delimiter regexp
@@ -202,16 +202,16 @@ These functions return a parser function that can be used as follows:
     record \ex{("foo" "")}.
 
     The syntax of infix-delimited records is:
-	\begin{inset}
-	\begin{tabular}{lcll}
-	\synvar{record} & ::=  & \ex{""} \qquad (Forced to be empty record) \\
-		        &  $|$ & \synvar{real-infix-record} \\
+        \begin{inset}
+        \begin{tabular}{lcll}
+        \synvar{record} & ::=  & \ex{""} \qquad (Forced to be empty record) \\
+                        &  $|$ & \synvar{real-infix-record} \\
         \\
-	\synvar{real-infix-record} & ::=  & \synvar{element} \synvar{delim}
+        \synvar{real-infix-record} & ::=  & \synvar{element} \synvar{delim}
                                             \synvar{real-infix-record} \\
                                     & $|$ & \synvar{element}
-	\end{tabular}
-	\end{inset}
+        \end{tabular}
+        \end{inset}
 
     Note that separator semantics doesn't really allow for empty 
     records---the straightforward grammar (\ie, \synvar{real-infix-record}) 
@@ -221,7 +221,7 @@ These functions return a parser function that can be used as follows:
     and \ex{append} isomorphic. For example,
         \codex{((infix-splitter ":") (string-append \var{x} ":" \var{y}))}
     doesn't always equal
-\begin{code}	
+\begin{code}    
 (append ((infix-splitter ":") \var{x})
         ((infix-splitter ":") \var{y}))\end{code}
     It fails when \var{x} or \var{y} are the empty string. 
@@ -252,9 +252,9 @@ These functions return a parser function that can be used as follows:
 \begin{tabular}{lllll}
 Record & : suffix & \verb!:|$! suffix & : infix & non-: field \\
 \hline
-\ex{""} &	\ex{()} &	\ex{()} &	\ex{()} &	\ex{()} \\
-\ex{":"} &	\ex{("")} &	\ex{("")} &	\ex{("" "")} &	\ex{()} \\
-\ex{"foo:"} & \ex{("foo")} &	\ex{("foo")} &	\ex{("foo" "")} & \ex{("foo")} \\
+\ex{""} &       \ex{()} &       \ex{()} &       \ex{()} &       \ex{()} \\
+\ex{":"} &      \ex{("")} &     \ex{("")} &     \ex{("" "")} &  \ex{()} \\
+\ex{"foo:"} & \ex{("foo")} &    \ex{("foo")} &  \ex{("foo" "")} & \ex{("foo")} \\
 \ex{":foo"}& \emph{error} & \ex{("" "foo")}& \ex{("" "foo")}& \ex{("foo")} \\
 \ex{"foo:bar"} & \emph{error} & \ex{("foo" "bar")} & \ex{("foo" "bar")} & \ex{("foo" "bar")}
 \end{tabular}
@@ -294,7 +294,7 @@ Record & : suffix & \verb!:|$! suffix & : infix & non-: field \\
     This utility returns a procedure that reads records with field structure 
     from a port.
     The reader's interface is designed to make it useful in the \ex{awk}
-	    loop macro (section~\ref{sec:awk}).
+            loop macro (section~\ref{sec:awk}).
     The reader is used as follows:
     \codex{(\var{reader} \var{[port]}) {\evalto} \var{[raw-record parsed-record]} or \var{[eof ()]}}
     
@@ -313,7 +313,7 @@ Record & : suffix & \verb!:|$! suffix & : infix & non-: field \\
     parsed value on eof is hardwired into the field reader.
 
     For example, if port \ex{p} is open on \ex{/etc/passwd}, then
-	\codex{((field-reader (infix-splitter ":" 7)) p)}
+        \codex{((field-reader (infix-splitter ":" 7)) p)}
     returns two values:
 {\small
 \begin{widecode}
@@ -463,7 +463,7 @@ the entire line read, and a seven-element list of the split-out fields.
 So if the \synvar{next-record} form in an \ex{awk} expression is 
 \ex{(read-passwd)}, then \synvar{record\&field-vars} must be a list of
 two variables, \eg,
-			  \codex{(record field-vec)}
+                          \codex{(record field-vec)}
 since \ex{read-passwd} returns two values.
 
 Note that \ex{awk} allows us to use \emph{any} record reader we want in the
@@ -491,81 +491,81 @@ it checks them all.
 \begin{itemize}
 
     \itum{\ex{(\var{test} \vari{body}1 \vari{body}2 \ldots)}}
-	If \var{test} is true, execute the body forms. The last body form
+        If \var{test} is true, execute the body forms. The last body form
         is the value of the clause. The test and body forms are evaluated
-	in the scope of the record and state variables.
+        in the scope of the record and state variables.
 
-    	The \var{test} form can be one of:
-	\begin{inset}
+        The \var{test} form can be one of:
+        \begin{inset}
         \begin{tabular}{lp{0.6\linewidth}}
-    	  \var{integer}: &	The test is true for that iteration of the loop.
+          \var{integer}: &      The test is true for that iteration of the loop.
                         The first iteration is \#1. \\
     
-    	  \var{sre}: &	A regular expression, in SRE notation 
+          \var{sre}: &  A regular expression, in SRE notation 
                         (see chapter~\ref{chapt:sre}) can be used as
-			a test. The test is successful if the pattern
+                        a test. The test is successful if the pattern
                         matches the record.
                         In particular, note that any string is an SRE. \\
     
-	  \ex{(when \var{expr})}: &
-			The body of a \ex{when} test is evaluated as a
-			Scheme boolean expression in the inner scope of the
-			\ex{awk} form. \\
+          \ex{(when \var{expr})}: &
+                        The body of a \ex{when} test is evaluated as a
+                        Scheme boolean expression in the inner scope of the
+                        \ex{awk} form. \\
 
-	  \var{expr}: & If the form is none of the above, it is treated as
-    	    	    	a Scheme expression---in practice, the \ex{when}
-			keyword is only needed in cases where SRE/Scheme
-			expression ambiguity might occur.
-	\end{tabular}
-	\end{inset}
+          \var{expr}: & If the form is none of the above, it is treated as
+                        a Scheme expression---in practice, the \ex{when}
+                        keyword is only needed in cases where SRE/Scheme
+                        expression ambiguity might occur.
+        \end{tabular}
+        \end{inset}
 
 
     \itum{\begin{tabular}[t]{l}
-\ex{(range\ \ \ \var{start-test} \var{stop-test}  \vari{body}1 \ldots)}	\\
-\ex{(:range\ \ \var{start-test} \var{stop-test}  \vari{body}1 \ldots)}	\\
-\ex{(range:\ \ \var{start-test} \var{stop-test}  \vari{body}1 \ldots)}	\\
-\ex{(:range:\ \var{start-test} \var{stop-test}  \vari{body}1 \ldots)}	
-	  \end{tabular}}
+\ex{(range\ \ \ \var{start-test} \var{stop-test}  \vari{body}1 \ldots)} \\
+\ex{(:range\ \ \var{start-test} \var{stop-test}  \vari{body}1 \ldots)}  \\
+\ex{(range:\ \ \var{start-test} \var{stop-test}  \vari{body}1 \ldots)}  \\
+\ex{(:range:\ \var{start-test} \var{stop-test}  \vari{body}1 \ldots)}   
+          \end{tabular}}
 %
-    	These clauses become activated when \var{start-test} is true; 
+        These clauses become activated when \var{start-test} is true; 
         they stay active on all further iterations until \var{stop-test}
         is true.
 
-    	So, to print out the first ten lines of a file, we use the clause:
-		\codex{(:range: 1 10 (display record))}
+        So, to print out the first ten lines of a file, we use the clause:
+                \codex{(:range: 1 10 (display record))}
 
-	The colons control whether or not the start and stop lines
-	are processed by the clause. For example:
-	\begin{inset}\begin{tabular}{l@{\qquad}l}
-	    \ex{(range\ \ \ 1 5\ \ \ldots)} &	Lines \phantom{1} 2 3 4	\\
-	    \ex{(:range\ \ 1 5\ \ \ldots)}  &	Lines 1 2 3 4 		\\
-	    \ex{(range:\ \ 1 5\ \ \ldots)}  &	Lines \phantom{1} 2 3 4 5 \\
-	    \ex{(:range: 1 5\ \ \ldots)}    &	Lines 1 2 3 4 5
- 	\end{tabular}
-	\end{inset}
+        The colons control whether or not the start and stop lines
+        are processed by the clause. For example:
+        \begin{inset}\begin{tabular}{l@{\qquad}l}
+            \ex{(range\ \ \ 1 5\ \ \ldots)} &   Lines \phantom{1} 2 3 4 \\
+            \ex{(:range\ \ 1 5\ \ \ldots)}  &   Lines 1 2 3 4           \\
+            \ex{(range:\ \ 1 5\ \ \ldots)}  &   Lines \phantom{1} 2 3 4 5 \\
+            \ex{(:range: 1 5\ \ \ldots)}    &   Lines 1 2 3 4 5
+        \end{tabular}
+        \end{inset}
 
-    	A line can trigger both tests, either simultaneously starting and
+        A line can trigger both tests, either simultaneously starting and
         stopping an active region, or simultaneously stopping one and starting
-    	a new one, so ranges can abut seamlessly.
+        a new one, so ranges can abut seamlessly.
 
     \itum{\ex{(else \vari{body}1 \vari{body}2 \ldots)}}
         If no other clause has executed since the top of the loop, or
         since the last \ex{else} clause, this clause executes.
 
     \itum{\ex{(\var{test} => \var{exp})}}
-	If evaluating \ex{test} produces a true value, 
+        If evaluating \ex{test} produces a true value, 
         apply \var{exp} to that value.
-	If \var{test} is a regular expression, then \var{exp} is applied
-    	to the match data structure returned by the regexp match routine.
+        If \var{test} is a regular expression, then \var{exp} is applied
+        to the match data structure returned by the regexp match routine.
 
     \itum{\ex{(after \vari{body}1 \ldots)}}
-    	This clause executes when the loop encounters EOF. The body forms
-    	execute in the scope of the state vars and the record-count var,
+        This clause executes when the loop encounters EOF. The body forms
+        execute in the scope of the state vars and the record-count var,
         if there are any. The value of the last body form is the value
-    	of the entire awk form.
+        of the entire awk form.
 
-    	If there is no \ex{after} clause, \ex{awk} returns the loop's state
-    	variables as multiple values.
+        If there is no \ex{after} clause, \ex{awk} returns the loop's state
+        variables as multiple values.
 \end{itemize}
 
 \subsection{Examples}
@@ -573,7 +573,7 @@ Here are some examples of \ex{awk} being used to process various types
 of input stream.
 
 \begin{code}
-(define $ nth)	; Saves typing.
+(define $ list-ref)     ; Saves typing.
 
 ;;; Print out the name and home-directory of everyone in /etc/passwd:
 (let ((read-passwd (field-reader (infix-splitter ":" 7))))

doc/scsh-manual/front.tex

@@ -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
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

doc/scsh-manual/man.t2p

@@ -86,7 +86,7 @@
   \def\TEMP{#1}%
   \ifx\TEMP\empty\else\ \fi}
 
-\def\dfnix#1#2#3#4{\leftline{{\tt(#1\spaceifnotempty{#2}{\it#2})} \quad $\longrightarrow$ \quad {\it #3} \qquad (#4)} \index}
+\def\dfnix#1#2#3#4#5{\index{#5}\leftline{{\tt(#1\spaceifnotempty{#2}{\it#2})} \quad $\longrightarrow$ \quad {\it #3} \qquad (#4)}}
 
 %\def\ex#1{{\tt #1}}
 %\let\ex\texttt

doc/scsh-manual/man.tex

@@ -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
 

doc/scsh-manual/miscprocs.tex

@@ -17,20 +17,6 @@
     A left shift is $j > 0$; a right shift is $j < 0$.
 \end{desc}
 
-\section{List procedures}
-\dfn{nth}{list i}{object}{procedure \textbf{(obsolete)}}
-\begin{desc}
-Returns the $i^{\mathrm th}$ element of \var{list}.
-The first element (the car) is \ex{(nth \var{list} 0)},
-the second element is \ex{(nth \var{list} 1)}, and so on.
-
-This procedure is provided as it is useful for accessing elements
-from the lists returned by the field-readers (chapter~\ref{chapt:fr-awk}).
-
-The functionality of \ex{nth} is equivalent to that of \RnRS{}'s
-\ex{list-ref}.  Therefore, \ex{nth} will go away in a future release.
-\end{desc}
-
 \section{Password encryption}
 
 \defun {crypt} {key salt} {encrypted value}
@@ -406,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"

doc/scsh-manual/procnotation.tex

@@ -510,7 +510,7 @@ These forms allow conditional execution of a sequence of processes.
 These procedures are useful for forking off processes to filter
 text streams.
 
-\begin{defundesc}{char-filter}{filter}{\proc}
+\begin{defundesc}{make-char-port-filter}{filter}{\proc}
     The \var{filter} argument is a character$\rightarrow$character procedure.
     Returns a procedure that when called, repeatedly reads a character
     from the current input port, applies \var{filter} to the character,
@@ -529,7 +529,7 @@ text streams.
      (> spell-errors.txt))\end{code}
 \end{defundesc}
 
-\begin{defundesc}{string-filter}{filter [buflen]}{\proc}
+\begin{defundesc}{make-string-port-filter}{filter [buflen]}{\proc}
     The \var{filter} argument is a string$\rightarrow$string procedure.
     Returns a procedure that when called, repeatedly reads a string
     from the current input port, applies \var{filter} to the string,

doc/scsh-manual/rdelim.tex

@@ -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: 

doc/scsh-manual/running.tex

@@ -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
@@ -818,13 +902,13 @@ or \ex{--} flags.
 \subsection{Stripped image}
 
 Besides the standard image \ex{scsh.image} scsh also ships with the
-much smaller image \ex{stripped-scsh.image}. This image contains
-the same code as the standard image but has almost all debugging
-information removed. \ex{stripped-scsh.image} is intended to be
-used with standalone programs where startup time and memory
-consumption count but debugging an errors the scheme code is not that
-important. To use the image the VM has to be called directly and the
-path to the image must be given after the \ex{-i} argument.
+much smaller image \ex{stripped-scsh.image}. This image contains the
+same code as the standard image but has almost all debugging
+information removed. \ex{stripped-scsh.image} is intended to be used
+with standalone programs where startup time and memory consumption
+count but debugging the scheme code is not that important. To use the
+image the VM has to be called directly and the path to the image must
+be given after the \ex{-i} argument.
 
 \subsection{Inserting interpreter triggers into heap images}
 {\scm}'s heap image format allows for an informational header:

doc/scsh-manual/sre.tex

@@ -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}
 

doc/scsh-manual/syscalls.tex

@@ -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
 

doc/scsh-manual/threads.tex

@@ -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: 

emacs/cmulisp.el

@@ -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

emacs/cmuscheme.el

@@ -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)
 ;;;

emacs/cmushell.el

@@ -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.
 

emacs/comint.el

@@ -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.
 

ps-compiler/compile-gc.scm

@@ -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!)))))

scheme/bcomp/comp-prim.scm

@@ -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)

scheme/bcomp/mtype.scm

@@ -1,4 +1,4 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
 
 ; Type lattice.
 ; Sorry this is so hairy, but before it was written, type checking 
@@ -619,6 +619,8 @@
 	      (reduce join-type (car l) (cdr l))))
 	   ((mask->type)
 	    (mask->type (cadr x)))
+           ((variable)
+            (variable-type (sexp->type (cadr x) r?)))
 	   (else (error "unrecognized type" x))))
 	(else (error "unrecognized type" x))))
 
@@ -641,18 +643,20 @@
 ; Convert type to S-expression
 
 (define (type->sexp t r?)
-  (if (> (bitwise-and (type-mask t) mask/&rest) 0)
-      (if (same-type? t any-values-type)
-	  ':values
-	  `(some-values ,@(rail-type->sexp t r?)))
-      (let ((j (disjoin-type t)))
-	(cond ((null? j) ':error)
-	      ((null? (cdr j))
-	       (atomic-type->sexp (car j) r?))
-	      (else
-	       `(join ,@(map (lambda (t)
-			       (atomic-type->sexp t r?))
-			     j)))))))
+  (if (variable-type? t)
+      `(variable ,(type->sexp (variable-value-type t) r?))
+      (if (> (bitwise-and (type-mask t) mask/&rest) 0)
+          (if (same-type? t any-values-type)
+              ':values
+              `(some-values ,@(rail-type->sexp t r?)))
+          (let ((j (disjoin-type t)))
+            (cond ((null? j) ':error)
+                  ((null? (cdr j))
+                   (atomic-type->sexp (car j) r?))
+                  (else
+                   `(join ,@(map (lambda (t)
+                                   (atomic-type->sexp t r?))
+                                 j))))))))
 	 
 (define (atomic-type->sexp t r?)
   (let ((m (type-mask t)))

scheme/big/sort.scm

@@ -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)))))

scheme/infix/packages.scm

@@ -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))

scheme/infix/pratt.scm

@@ -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)

scheme/infix/sgol-runtime.scm

@@ -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)))

scheme/infix/sgol.scm

@@ -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)))))

scheme/infix/tokenize.scm

@@ -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)))))

scheme/link/generate-c-header.scm

@@ -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))"

scheme/misc/annotate.scm

@@ -7,7 +7,7 @@
 
 (define annotate-procedure
   (lap annotate-procedure ()
-       0 (check-nargs= 2)
+       0 (protocol 2)
        2 (make-env 2)
        4 (local0 2)
        6 (stored-object-ref closure 0)
@@ -24,7 +24,7 @@
 
 (define procedure-annotation
   (lap procedure-anotation ()
-       0 (check-nargs= 1)
+       0 (protocol 1)
        2 (make-env 1)
        4 (literal '2)
        6 (push)

scheme/more-interfaces.scm

@@ -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)))

scheme/more-packages.scm

@@ -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

scheme/opt/flatten.scm

@@ -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)

scheme/opt/inline.scm

@@ -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)

scheme/opt/usage.scm

@@ -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.

scheme/rts/numio.scm

@@ -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)

scheme/rts/xnum.scm

@@ -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.
 

scheme/sort/delndups.scm

@@ -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.
+
+

scheme/sort/interfaces.scm

@@ -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)))))

scheme/sort/lmsort.scm

@@ -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.

scheme/sort/packages.scm

@@ -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))

scheme/sort/sort.scm

@@ -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!)
+

scheme/sort/sortp.scm

@@ -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.

scheme/sort/test.scm

@@ -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)))))

scheme/sort/vbinsearch.scm

@@ -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))))))))

scheme/sort/vector-util.scm

@@ -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)))

scheme/sort/vhsort.scm

@@ -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.

scheme/sort/visort.scm

@@ -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.

scheme/sort/vmsort.scm

@@ -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.

scheme/srfi/srfi-1.scm

@@ -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
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

scheme/srfi/srfi-13.scm

@@ -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
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

scheme/srfi/srfi-14.scm

@@ -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.

scheme/srfi/srfi-19.scm

@@ -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)))))
-

scheme/srfi/srfi-42.scm

@@ -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) )))
+

scheme/vm/prim-io.scm

@@ -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)

scsh/aix/sysdep.h

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

scsh/bsd/time_dep1.c

@@ -1,39 +0,0 @@
-/* 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;
-
-}

scsh/command-line.scm

@@ -0,0 +1,31 @@
+;;; Command-line argument access
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Some globals.
+(define %command-line '())		; Includes program.
+(define command-line-arguments #f)	; Doesn't include program.
+
+(define (set-command-line-args! args)
+  (set! %command-line args)
+  (set! command-line-arguments (append (cdr args) '())))
+
+(define (arg* arglist n . maybe-default-thunk)
+  (let ((oops (lambda () (error "argument out of bounds" arglist n))))
+    (if (< n 1) (oops)
+	(let lp ((al arglist) (n n))
+	  (if (pair? al)
+	      (if (= n 1) (car al)
+		  (lp (cdr al) (- n 1)))
+	      (if (and (pair? maybe-default-thunk)
+		       (null? (cdr maybe-default-thunk)))
+		  ((car maybe-default-thunk))
+		  (oops)))))))
+
+(define (arg arglist n . maybe-default)
+  (if maybe-default (arg* arglist n (lambda () (car maybe-default)))
+      (arg* arglist n)))
+
+(define (argv n . maybe-default)
+  (apply arg %command-line (+ n 1) maybe-default))
+
+(define (command-line) (append %command-line '()))

scsh/configure.scm.in

@@ -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: 

scsh/continuation.scm

@@ -0,0 +1,21 @@
+;;; Move this to somewhere else as soon as Marc has published his SRFI
+(define (continuation-capture receiver)
+  ((call-with-current-continuation
+    (lambda (cont)
+      (lambda () (receiver cont))))))
+
+(define (continuation-graft cont thunk)
+  (cont thunk))
+
+(define (continuation-return cont . returned-values)
+  (continuation-graft
+   cont
+   (lambda () (apply values returned-values))))
+
+;;; Call THUNK, then die.
+
+(define (call-terminally thunk)
+  (with-continuation null-continuation thunk))
+
+;; from shift-reset.scm:
+(define null-continuation #f)

scsh/crypt.scm

@@ -0,0 +1,10 @@
+(import-os-error-syscall %crypt (key salt) "scm_crypt")
+
+(define (crypt key salt)
+  (let* ((allowed-char-set  (rx (| alpha digit "." "/")))
+	 (salt-regexp  (rx (: ,allowed-char-set ,allowed-char-set))))
+    (if (not (= (string-length salt) 2)) (error "salt must have length 2"))
+    (if (not (regexp-search? salt-regexp salt))
+	(error "illegal char in salt " salt))
+    (if (> (string-length key) 8) (error "key too long "  (string-length key)))
+    (%crypt key salt)))

scsh/cstuff.c

@@ -14,3 +14,39 @@ s48_value char_pp_2_string_list(char **vec){
     S48_GC_UNPROTECT();
     return list;
 }
+
+char *scheme2c_strcpy(s48_value sstr)
+{
+    char *result;
+    int slen;
+
+    slen = S48_STRING_LENGTH(sstr);
+    result = Malloc(char, slen+1);
+
+    if( result == NULL ) {
+        fprintf(stderr,
+                "Fatal error: C stub tried to copy Scheme string,\n"
+                "but malloc failed on arg 0x%x, errno %d.\n",
+                sstr, errno);
+        exit(-1);
+        }
+
+    memcpy(result, s48_extract_string(sstr), slen);
+    result[slen] = '\000';
+    return result;
+}
+
+s48_value strlen_or_false(const char *s)
+{ return s ?  s48_enter_fixnum(strlen(s)) : S48_FALSE; }
+
+/* Helper function for arg checking. Why bother, actually? */
+void cig_check_nargs(int arity, int nargs, const char *fn)
+{
+   if( arity != nargs ) {
+       fprintf(stderr,
+	       "Cig fatal error (%s) -- C stub expected %d arg%s, "
+	       "but got %d.\n",
+	       fn, arity, (arity == 1) ? "" : "s", nargs);
+       exit(-1);
+   }
+}

scsh/cstuff.h

@@ -1,4 +1,10 @@
-#include "libcig.h"
+#include <string.h>
+#include <stddef.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <errno.h>
+
+#include "scheme48.h"
 #define Alloc(type) 	((type *) malloc(sizeof(type)))
 #define Malloc(type,n)	((type *) malloc(sizeof(type)*(n)))
 #define Free(p)		(free((char *)(p)))
@@ -8,3 +14,8 @@
 #define streq(a,b) (!strcmp((a),(b)))
 
 s48_value char_pp_2_string_list(char **);
+char *scheme2c_strcpy(s48_value sstr);
+
+/* The rest is needed by dbm.c and ndbm.c only */
+s48_value strlen_or_false(const char *s);
+void cig_check_nargs(int arity, int nargs, const char *fn);

scsh/cygwin32/sysdep.h

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

scsh/cygwin32/time_dep1.c

@@ -1,39 +0,0 @@
-/* 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;
-
-}

scsh/db.c

@@ -12,7 +12,7 @@
 
 extern int errno;
 
-#define errno_or_false(x) (((x) == -1) ? s48_enter_fixnum(errno) : S48_FALSE)
+#define errno_or_false(x) (((x) == -1) ? s48_enter_integer(errno) : S48_FALSE)
 
 s48_value df_db_open(s48_value g1, s48_value g2, s48_value g3, s48_value g4, s48_value mv_vec)
 {

scsh/db.scm

@@ -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.
 
@@ -76,7 +73,7 @@
   ""
   "extern int errno;"
   ""
-  "#define errno_or_false(x) (((x) == -1) ? s48_enter_fixnum(errno) : S48_FALSE)"
+  "#define errno_or_false(x) (((x) == -1) ? s48_enter_integer(errno) : S48_FALSE)"
   "" "")
 
 (define-foreign %db-open (db_open (string file)

scsh/dbm.c

@@ -13,7 +13,7 @@
 
 extern int errno;
 
-#define errno_or_false(x) (((x) == -1) ? s48_enter_fixnum(errno) : S48_FALSE)
+#define errno_or_false(x) (((x) == -1) ? s48_enter_integer(errno) : S48_FALSE)
 
 s48_value df_db_check(long nargs, s48_value *args)
 {