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

Compare commits

base: scsh-conservatory:main
Branches Tags
scsh-conservatory:main
scsh-conservatory:r0-6-stable
scsh-conservatory:r0-6-stable_bp
scsh-conservatory:release-0-6-4
scsh-conservatory:release-0-6-3
scsh-conservatory:release-0-6-2
scsh-conservatory:release-0-6-1
scsh-conservatory:import-1.1.1
..
compare: scsh-conservatory:release-0-6-4
Branches Tags
scsh-conservatory:main
scsh-conservatory:r0-6-stable
scsh-conservatory:r0-6-stable_bp
scsh-conservatory:release-0-6-4
scsh-conservatory:release-0-6-3
scsh-conservatory:release-0-6-2
scsh-conservatory:release-0-6-1
scsh-conservatory:import-1.1.1

1 Commits
main ... release-0-

Author SHA1 Message Date
cvs-fast-export 07c6d70d30 Synthetic commit for incomplete tag release-0-6-4 2003-04-14 11:06:55 +00:00
224 changed files with 10985 additions and 15367 deletions
Show Stats Expand all files Collapse all files

11
.gitignore vendored
View File

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

8
COPYING
View File

@ -1,7 +1,7 @@
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.
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.
All rights reserved.

2
CVS_README
View File

@ -25,7 +25,7 @@ To build Scsh, proceed as follows:
1.) You must have a working version of Scheme 48, version 0.53. Nothing
older, nothing newer. Just 0.53. If you don't have, get it from
http://www.s48.org/0.53/scheme48-0.53.tgz and install Scheme
48. Change the value of the variable BUILD_RUNNABLE in Makefile.in
48. Change to 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

330
Makefile.in
View File

@ -14,7 +14,7 @@ INSTALL = @INSTALL@
INSTALL_PROGRAM = @INSTALL_PROGRAM@
INSTALL_DATA = @INSTALL_DATA@
LDFLAGS = @LDFLAGS@
LDFLAGS = -g @LDFLAGS@
LIBOBJS = @LIBOBJS@
RM = rm -f
@ -29,12 +29,7 @@ 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
@ -46,16 +41,13 @@ htmldir = $(libdir)/scsh/doc/scsh-manual/html
# Ultrix
# LDFLAGS = -N
.SUFFIXES:
.SUFFIXES: .c .o
.c.o:
$(CC) -g -c $(DEFS) -I ./c -I$(srcdir)/c $(CPPFLAGS) $(CFLAGS) -o $@ $<
$(CC) -g -c $(DEFS) -I$(srcdir)/c -I$(srcdir)/cig $(CPPFLAGS) $(CFLAGS) -o $@ $<
# BUILD_RUNNABLE has to be Scheme 48 0.53. This is used for builds directly
# BUILD_RUNNABLE has to be Scheme 48 0.53. This is used for builds directly
# out of the CVS repository.
# We cannot use Scsh here since -i is not understood.
BUILD_RUNNABLE = /Users/jao/Library/Scheme/s48/bin/scheme48
BUILD_RUNNABLE = /afs/wsi/i386_fbsd32/bin/scheme48
RUNNABLE = scsh
MANPAGE = $(RUNNABLE).$(manext)
LIB = $(libdir)/$(RUNNABLE)
@ -109,23 +101,27 @@ START_LINKER = echo ',batch' && echo ',bench on'
# Targets:
IMAGE = scheme48.image
INITIAL = $(srcdir)/build/initial.image
INITIAL = 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 \
@ -143,7 +139,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_libscsh s48_init_md5
s48_init_cig 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
@ -151,8 +147,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) $(SCSHOBJS) \
S48OBJS = c/scheme48vm.o c/scheme48heap.o c/extension.o c/external.o
OBJS = scsh/process_args.o c/init.o $(S48OBJS) $(CIGOBJS) $(SCSHOBJS) \
$(SCSHVMHACKS) $(SRFI_OBJS)
FAKEHS = c/fake/dlfcn.h c/fake/sigact.h c/fake/strerror.h \
@ -167,14 +163,7 @@ CONFIG_FILES = scheme/interfaces.scm scheme/low-packages.scm \
# The following is the first rule and therefore the "make" command's
# default target.
enough: $(VM) $(IMAGE) go scsh $(LIBSCSH) $(LIBSCSHVM)
# 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"))
enough: $(VM) $(IMAGE) go $(LIBCIG) scsh $(LIBSCSH) $(LIBSCSHVM)
# --------------------
# External code to include in the VM
@ -185,6 +174,7 @@ EXTERNAL_FLAGS = $(SOCKET_FLAGS)
EXTERNAL_INITIALIZERS = $(ADDITIONAL_INITIALIZER) $(SOCKET_INITIALIZERS) \
$(LOOKUP_INITIALIZERS) \
$(SCSH_INITIALIZERS) $(SRFI_INITIALIZERS) \
s48_init_cig
# Rules for any external code.
@ -220,11 +210,16 @@ 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.
@ -241,13 +236,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 && \
$(srcdir)/build/build-external-modules /tmp/s48_external_$$$$.c \
build/build-external-modules /tmp/s48_external_$$$$.c \
$(EXTERNAL_INITIALIZERS) && \
$(CC) $(LDFLAGS) $(CFLAGS) -o $@ c/main.o $(OBJS) $(UNIX_OBJS) \
/tmp/s48_external_$$$$.c \
@ -258,6 +253,13 @@ $(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)
@ -266,24 +268,24 @@ $(LIBSCSHVM): c/smain.o $(OBJS)
$(LIBSCSH): $(OBJS) $(UNIX_OBJS) $(LIBOBJS) $(EXTERNAL_OBJECTS)
$(RM) $@ \
rm -f /tmp/s48_external_$$$$.c && \
$(srcdir)/build/build-external-modules /tmp/s48_external_$$$$.c \
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) $(srcdir)/c/main.c
$(CPPFLAGS) $(DEFS) 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) $(srcdir)/c/init.c
$(CPPFLAGS) $(DEFS) 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
@ -310,8 +312,8 @@ c/fake/strerror.o: c/fake/strerror.h
$(IMAGE): $(VM) scheme/env/init-defpackage.scm scheme/more-interfaces.scm \
scheme/link-packages.scm scheme/more-packages.scm \
$(usual-files) build/initial.debug build/build-usual-image
$(srcdir)/build/build-usual-image $(srcdir) "$(srcdir)/scheme" '$(IMAGE)' './$(VM)' \
'$(srcdir)/$(INITIAL)'
build/build-usual-image . "`pwd`/scheme" '$(IMAGE)' './$(VM)' \
'$(INITIAL)'
### Fake targets: all clean install man dist
@ -319,14 +321,14 @@ install: enough dirs inst-script inst-vm inst-misc inst-man inst-inc \
inst-doc install-scsh
inst-vm: $(VM)
$(INSTALL_PROGRAM) $(VM) $(DESTDIR)$(LIB)
$(INSTALL_PROGRAM) $(VM) $(LIB)
inst-man:
if [ -d $(DESTDIR)$(mandir) -a -w $(DESTDIR)$(mandir) ]; then \
if [ -d $(mandir) -a -w $(mandir) ]; then \
sed 's=LBIN=$(bindir)=g' doc/scsh.man | \
sed 's=LLIB=$(LIB)=g' | \
sed 's=LSCSH=$(RUNNABLE)=g' >$(MANPAGE) && \
$(INSTALL_DATA) $(MANPAGE) $(DESTDIR)$(mandir) && \
$(INSTALL_DATA) $(MANPAGE) $(mandir) && \
$(RM) $(MANPAGE); \
else \
echo "$(mandir) not writable dir, not installing man page" \
@ -334,61 +336,67 @@ inst-man:
fi
inst-inc:
$(INSTALL_DATA) $(srcdir)/c/scheme48.h $(DESTDIR)$(incdir)
$(INSTALL_DATA) $(srcdir)/c/write-barrier.h $(DESTDIR)$(incdir)
$(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
inst-misc:
for stub in env big opt misc link srfi; do \
for f in $(srcdir)/scheme/$$stub/*.scm; do \
$(INSTALL_DATA) $$f $(DESTDIR)$(LIB)/$$stub || exit 1; \
for f in scheme/$$stub/*.scm; do \
$(INSTALL_DATA) $$f $(LIB)/$$stub || exit 1; \
done; \
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
for f in scheme/rts/*num.scm scheme/rts/jar-defrecord.scm; do \
$(INSTALL_DATA) $$f $(LIB)/rts || exit 1; \
done
inst-doc:
for f in $(srcdir)/doc/*.txt $(srcdir)/doc/*.ps; do \
$(INSTALL_DATA) $$f $(DESTDIR)$(LIB)/doc/; \
$(INSTALL_DATA) $$f $(LIB)/doc/; \
done && \
for f in $(srcdir)/doc/src/*.tex \
$(srcdir)/doc/src/*.dvi \
$(srcdir)/doc/src/*.ps; \
do $(INSTALL_DATA) $$f $(DESTDIR)$(LIB)/doc/s48-manual/; \
do $(INSTALL_DATA) $$f $(LIB)/doc/s48-manual/; \
done && \
for f in $(srcdir)/doc/src/manual/*.html; \
do $(INSTALL_DATA) $$f $(DESTDIR)$(LIB)/doc/s48-manual/html/; \
do $(INSTALL_DATA) $$f $(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 $(DESTDIR)$(LIB)/doc/scsh-manual/; \
do $(INSTALL_DATA) $$f $(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 $(DESTDIR)$(htmldir)/; \
do $(INSTALL_DATA) $$f $(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 $(DESTDIR)$(LIB)/doc/scsh-paper/; \
do $(INSTALL_DATA) $$f $(LIB)/doc/scsh-paper/; \
done && \
for f in $(srcdir)/doc/scsh-paper/html/*.html \
$(srcdir)/doc/scsh-paper/html/*.css; \
do $(INSTALL_DATA) $$f $(DESTDIR)$(LIB)/doc/scsh-paper/html; \
do $(INSTALL_DATA) $$f $(LIB)/doc/scsh-paper/html; \
done
inst-script:
script=$(DESTDIR)$(bindir)/$(RUNNABLE) && \
script=$(bindir)/$(RUNNABLE) && \
echo '#!/bin/sh' >$$script && \
echo >>$$script && \
echo 'lib=$(LIB)' >>$$script && \
echo 'exec $$lib/$(VM) -i $$lib/$(IMAGE) "$$@"' \
echo 'exec $$lib/$(VM) -o $$lib/$(VM) -i $$lib/$(IMAGE) "$$@"' \
>>$$script && \
chmod +x $$script
@ -397,22 +405,22 @@ go:
echo '#!/bin/sh' >$@ && \
echo >>$@ && \
echo "lib=`pwd`" >>$@ && \
echo 'exec $$lib/$(VM) -i $$lib/scsh/scsh.image "$$@"' \
echo 'exec $$lib/$(VM) -o $$lib/$(VM) -i $$lib/scsh/scsh.image "$$@"' \
>>$@ && \
chmod +x $@
dirs:
for dir in $(libdir) $(bindir) $(incdir) $(LIB) $(mandir) $(htmldir); do\
{ mkdir -p $(DESTDIR)$$dir && [ -w $(DESTDIR)$$dir ]; } || { \
echo "$(DESTDIR)$$dir not a writable directory" >&2; \
{ mkdir -p $$dir && [ -w $$dir ]; } || { \
echo "$$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 $(DESTDIR)$(LIB)/$$dir && [ -w $(DESTDIR)$(LIB)/$$dir ]; } || { \
echo "$(DESTDIR)$(LIB)/$$dir not a writable directory" >&2; \
{ mkdir -p $(LIB)/$$dir && [ -w $(LIB)/$$dir ]; } || { \
echo "$(LIB)/$$dir not a writable directory" >&2; \
exit 1; \
}; \
done
@ -420,27 +428,24 @@ dirs:
configure: configure.in
autoheader && autoconf
clean: clean-scsh
$(RM) $(VM) *.o c/*/*.o c/*.o \
clean: clean-cig clean-scsh
-rm -f $(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)
distclean: clean
$(RM) Makefile config.log config.status c/sysdep.h config.cache \
scsh/endian.scm \
exportlist.aix scsh-config
rmdir scsh/machine
$(RM) a.exe $(VM).base $(VM).def $(VM).exp
-find . -name '*~' -o -name '#*' -o -name core -exec rm {} \;
clean-cig:
-rm -f cig/*.o $(CIG) $(CIG).image $(LIBCIG)
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}
distclean: clean
rm -f Makefile config.log config.status c/sysdep.h config.cache \
scsh/machine \
scsh/endian.scm \
exportlist.aix
$(RM) a.exe $(VM).base $(VM).def $(VM).exp
-find . -name '*~' -o -name '#*' -o -name core -exec rm {} \;
check: $(VM) $(IMAGE) scheme/debug/check.scm
( \
@ -492,7 +497,8 @@ 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/*.scm.in scsh/*/Makefile.inc \
cig/*.scm cig/*.[ch] \
doc/scsh.man \
doc/scsh-manual/*.tex doc/scsh-manual/*.sty \
doc/scsh-manual/man.ps doc/scsh-manual/man.pdf \
@ -506,9 +512,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 $(srcdir)/build/minor-version-number`
distname = $(RUNNABLE)-0.`cat build/minor-version-number`
dist: build/initial.image distclean
dist: build/initial.image
(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 && \
@ -532,8 +538,7 @@ dist: build/initial.image distclean
else \
echo "Can't write $$distfile" >&2; \
exit 1; \
fi && \
echo "Hope you already called ./autogen..."
fi
# Increment the minor version number
inc:
@ -610,7 +615,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")'; \
@ -688,7 +693,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 $(srcdir)/scheme/link/generate-c-header.scm'; \
echo ',load scheme/link/generate-c-header.scm'; \
echo "(make-c-header-file \"$@\" \
\"$(srcdir)/c/scheme48.h.in\" \
\"$(srcdir)/scheme/vm/arch.scm\" \
@ -726,80 +731,94 @@ 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 \
scsh/command-line.scm \
scsh/continuation.scm \
scsh/crypt.scm \
scsh/configure.scm \
SCHEME =scsh/awk.scm \
scsh/defrec.scm \
scsh/directory.scm \
scsh/dot-locking.scm \
scsh/endian.scm \
scsh/enumconst.scm \
scsh/environment.scm \
scsh/event.scm \
scsh/fcntl.scm \
scsh/fd-syscalls.scm \
scsh/low-interrupt.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/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/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/system.scm \
scsh/temp-file.scm \
scsh/syscalls.scm \
scsh/time.scm \
scsh/top.scm \
scsh/tty.scm \
scsh/user-group.scm \
scsh/utilities.scm \
scsh/weaktables.scm \
scsh/rx/packages.scm \
@ -822,14 +841,23 @@ SCHEME = \
# 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
loads = $(srcdir)/scsh/let-opt.scm $(srcdir)/scsh/scsh-interfaces.scm \
$(srcdir)/scsh/@machine@/packages.scm \
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 \
$(srcdir)/scsh/rx/packages.scm \
$(srcdir)/scsh/scsh-package.scm \
$(srcdir)/scsh/lib/ccp-pack.scm \
@ -838,19 +866,14 @@ loads = $(srcdir)/scsh/let-opt.scm $(srcdir)/scsh/scsh-interfaces.scm \
opens = floatnums scsh ccp-lib scsh-top-package scsh-here-string-hax \
srfi-1 srfi-13 srfi-14 # srfi-14 is also exported by scsh
# Doing ,load-package scheme-with-scsh here gives us much better start-up times
scsh/scsh.image: $(VM) $(SCHEME) $(IMAGE)
(echo ",translate =scheme48/ `(cd $(srcdir) && echo $$PWD)`/scheme/"; \
echo ",translate $(srcdir)/scsh/machine/ $(srcdir)/scsh/@machine@/"; \
echo ",translate $(srcdir)/scsh/endian.scm `pwd`/scsh/endian.scm"; \
echo ",translate $(srcdir)/scsh/configure.scm `pwd`/scsh/configure.scm"; \
(echo ",translate =scheme48/ `pwd`/scheme/"; \
echo ",batch on"; \
echo ",config ,load $(loads)"; \
echo ",open $(opens)"; \
echo ",load-package scheme-with-scsh"; \
echo "(dump-scsh \"$@\")"; \
) \
| ./$(VM) -i $(IMAGE) -h 10000000
| ./$(VM) -o ./$(VM) -i $(IMAGE) -h 10000000
# ,flush files => 0k
# ,flush names => -= 17k
@ -859,63 +882,38 @@ scsh/scsh.image: $(VM) $(SCHEME) $(IMAGE)
# ,flush => 550k
scsh/stripped-scsh.image: $(VM) $(SCHEME) $(IMAGE)
(echo ",flush maps source";\
echo ",translate =scheme48/ `(cd $(srcdir) && echo $$PWD)`/scheme/"; \
echo ",translate $(srcdir)/scsh/machine/ $(srcdir)/scsh/@machine@/"; \
echo ",translate $(srcdir)/scsh/endian.scm `pwd`/scsh/endian.scm"; \
echo ",translate $(srcdir)/scsh/configure.scm `pwd`/scsh/configure.scm"; \
echo ",translate =scheme48/ `pwd`/scheme/"; \
echo ",batch on"; \
echo ",config ,load $(loads)"; \
echo ",open $(opens)"; \
echo ",load-package scheme-with-scsh"; \
echo ",flush"; \
echo "(dump-scsh \"$@\")";) \
| ./$(VM) -i $(IMAGE) -h 10000000
| ./$(VM) -o ./$(VM) -i $(IMAGE) -h 10000000
install-scsh: scsh install-scsh-image install-stripped-scsh-image
$(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)
$(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)
for f in $(srcdir)/scsh/*.scm $(srcdir)/scsh/*/*.scm; \
do $(INSTALL_DATA) $$f $(DESTDIR)$(LIB)/scsh/; done
do $(INSTALL_DATA) $$f $(LIB)/scsh/; done
install-scsh-image: $(VM) scsh/scsh.image
( echo ',translate =scheme48 $(LIB)'; \
echo ",translate $(srcdir)/scsh/machine/ $(srcdir)/scsh/@machine@/"; \
echo ',in lib-dirs (set-default-lib-dirs! (quote $(lib_dirs_list)))'; \
echo '(dump-scsh "$(DESTDIR)$(LIB)/scsh.image")'; \
echo '(dump-scsh "$(LIB)/scsh.image")'; \
echo ',exit'; \
) | ./$(VM) -i scsh/scsh.image
) | ./$(VM) -i scsh/scsh.image
install-stripped-scsh-image: $(VM) scsh/stripped-scsh.image
( echo ',translate =scheme48 $(LIB)'; \
echo ",translate $(srcdir)/scsh/machine/ $(srcdir)/scsh/@machine@/"; \
echo ',in lib-dirs (set-default-lib-dirs! (quote $(lib_dirs_list)))'; \
echo '(dump-scsh "$(DESTDIR)$(LIB)/stripped-scsh.image")'; \
echo '(dump-scsh "$(LIB)/stripped-scsh.image")'; \
echo ',exit'; \
) | ./$(VM) -i scsh/stripped-scsh.image
clean-scsh:
$(RM) scsh/*.o scsh/rx/*.o scsh/*/*.o
$(RM) scsh/*.image
$(RM) scsh/configure.scm
$(RM) scsh/*.o scsh/rx/*.o scsh/machine/*.o
$(RM) scsh/*.image
$(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 > $@

4
README
View File

@ -3,7 +3,7 @@
Copyright (c) 1994 Brian D. Carlstrom
See file COPYING for copying information.
Please report bugs to scsh-users@scsh.net, and include
Please report bugs to scsh-bugs@zurich.ai.mit.edu, 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-users-request@scsh.net to be put on a
Send mail to scsh-request@zurich.ai.mit.edu to be put on a
mailing list for announcements, discussion, bug reports, and bug
fixes.

182
RELEASE
View File

@ -1,10 +1,12 @@
Scsh 0.6.7 Release notes -*- outline -*-
Scsh 0.6.4 Release notes -*- outline -*-
We are pleased to release scsh version 0.6.7.
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.
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.7. (Emacs should display this document is in outline mode. Say
release 0.6.3. (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).)
@ -18,9 +20,9 @@ Obtaining and installing scsh
Getting in touch
The World-Wide What?
New in this release
New in 0.6.6
New in 0.6.5
New in 0.6.4
Switches to load exec scripts
Bug fixes
API changes
New in 0.6.3
New in 0.6.2
New in 0.6.1
@ -103,9 +105,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.
@ -138,26 +140,23 @@ 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.
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
Bugs can be reported to
scsh-bugs@zurich.ai.mit.edu
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:
@ -168,145 +167,10 @@ 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
@ -320,7 +184,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-port-filter and char-filter to
- Renamed string-filter to make-string-filter and char-filter to
make-char-port-filter
** API changes

7
Thanks
View File

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

6
autogen.sh
View File

@ -1,11 +1,11 @@
#! /bin/sh
#! /bin/sh
autoheader &&
autoconf &&
./configure &&
touch scsh/*.c &&
touch build/filenames.scm &&
rm -f scheme48.image scsh/scsh.image &&
rm -f scheme48.image cig/cig.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

6
build/build-usual-image
View File

@ -9,13 +9,11 @@ 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
,load =scheme48/sort/interfaces.scm
,load =scheme48/link-packages.scm
,load =scheme48/more-interfaces.scm =scheme48/link-packages.scm
,load =scheme48/more-packages.scm
(ensure-loaded command-processor)
(ensure-loaded usual-commands)

BIN
build/initial.image
View File

Binary file not shown.

2
build/minor-version-number
View File

@ -1 +1 @@
6.7
6.4

75
c/external.c
View File

@ -500,130 +500,71 @@ s48_raise_closed_channel_error() {
void
s48_raise_os_error(int the_errno) {
s48_raise_scheme_exception(S48_EXCEPTION_OS_ERROR, 2,
s48_enter_integer(the_errno),
s48_enter_fixnum(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,
sch_errno,
s48_enter_fixnum(the_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,
sch_errno,
s48_enter_fixnum(the_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,
sch_errno,
s48_enter_fixnum(the_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,
sch_errno,
s48_enter_fixnum(the_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,
sch_errno,
s48_enter_fixnum(the_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,
sch_errno,
s48_enter_fixnum(the_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,
sch_errno,
s48_enter_fixnum(the_errno),
s48_enter_string(strerror(the_errno)),
arg1, arg2, arg3, arg4, arg5, arg6, arg7);
S48_GC_UNPROTECT();
}
void

7
c/init.c
View File

@ -15,6 +15,8 @@ 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,
@ -28,12 +30,12 @@ int s48_main (long heap_size, long stack_size,
}
int
internal_s48_main(long heap_size, long stack_size,
internal_s48_main(long heap_size, long stack_size, char * _prog_name,
char* object_file, char *image_name, int argc, char** argv)
{
long return_value;
long required_heap_size;
int warn_undefined_imported_bindings_p = 0;
int warn_undefined_imported_bindings_p = 1;
#if defined(STATIC_AREAS)
extern long static_entry;
@ -43,6 +45,7 @@ internal_s48_main(long heap_size, long stack_size,
extern long i_count, *i_areas[], i_sizes[];
#endif
prog_name = _prog_name;
s48_object_file = object_file;
s48_reloc_file = NULL;

31
c/main.c
View File

@ -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 "scsh.image"
#define DEFAULT_IMAGE_NAME "scheme48.image"
#endif
#endif /* STATIC_AREAS */
void process_args(char **argv,
long *heap_size,
long *stack_size,
char **object_file,
char **image_name);
char ** 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* 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,
int argc, char** argv);
int
@ -62,13 +62,12 @@ main(argc, argv)
#endif
long vm_argc = 0;
prog_name = *argv++;/* Save program name. */
char *me = *argv; /* Save program name. */
prog_name = *argv++;
process_args(argv,
&heap_size, &stack_size,
&object_file, &image_name);
argv--;
argv[0] = prog_name;
argv=process_args(argv,
&heap_size, &stack_size,
&object_file, &image_name);
for(argc=0, argp=argv; *argp; argc++, argp++); /* Recompute argc. */
return internal_s48_main(heap_size, stack_size, object_file, image_name, argc, argv);
return internal_s48_main(heap_size, stack_size, prog_name, object_file, image_name, argc, argv);
}

2
c/scheme48.h
View File

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

1
c/scheme48heap.c
View File

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

1
c/scheme48vm-prelude.h
View File

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

8
c/scheme48vm.c
View File

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

12
c/srfi/srfi-27.c
View File

@ -117,9 +117,6 @@ 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)))
@ -133,8 +130,6 @@ 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);
@ -142,12 +137,9 @@ s48_value mrg32k3a_pack_state1(s48_value state) {
}
s48_value mrg32k3a_unpack_state1(s48_value state) {
s48_value result = S48_UNSPECIFIC;
s48_value result;
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);
@ -169,8 +161,6 @@ s48_value mrg32k3a_unpack_state1(s48_value state) {
#undef SET
S48_GC_UNPROTECT();
return result;
}

2
c/unix/event.c
View File

@ -1,7 +1,6 @@
/* 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>
@ -10,6 +9,7 @@
#include <sys/time.h>
#include <sys/times.h>
#include <errno.h> /* for errno, (POSIX?/ANSI) */
#include "sysdep.h"
#include "c-mods.h"
#include "scheme48vm.h"
#include "event.h"

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

@ -1,7 +1,6 @@
/* 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>
@ -9,6 +8,7 @@
#include <fcntl.h>
#include <sys/time.h>
#include <errno.h> /* for errno, (POSIX?/ANSI) */
#include "sysdep.h"
#include "c-mods.h"
#include "scheme48vm.h"
#include "event.h"

38
c/unix/io.c
View File

@ -146,6 +146,26 @@ 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)
{
@ -162,24 +182,6 @@ 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)
{

35
c/unix/socket.c
View File

@ -381,38 +381,11 @@ s48_close_socket_half(s48_value channel, s48_value input_p)
static s48_value
s48_get_host_name(void)
{
char *mbuff = NULL;
size_t mbuff_len = 0;
int status = 0;
s48_value name;
char mbuff[MAXHOSTNAMELEN];
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);
if (gethostname(mbuff, sizeof(mbuff)) < 0)
s48_raise_os_error(errno);
}
name = s48_enter_string(mbuff);
free(mbuff);
return name;
return s48_enter_string(mbuff);
}

3
cig/.gitignore vendored Normal file
View File

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

1171
cig/cig.scm Normal file
View File

File diff suppressed because it is too large Load Diff

48
cig/image2script Executable file
View File

@ -0,0 +1,48 @@
#!/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

117
cig/libcig.c Normal file
View File

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

32
cig/libcig.h Normal file
View File

@ -0,0 +1,32 @@
#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);

139
cig/libcig.scm Normal file
View File

@ -0,0 +1,139 @@
;;; (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

163
cig/libcig1.c Normal file
View File

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

1123
config.guess vendored
View File

File diff suppressed because it is too large Load Diff

483
config.sub vendored
View File

@ -1,9 +1,9 @@
#! /bin/sh
# Configuration validation subroutine script.
# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
# 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
# Free Software Foundation, Inc.
timestamp='2005-07-08'
timestamp='2001-03-09'
# This file is (in principle) common to ALL GNU software.
# The presence of a machine in this file suggests that SOME GNU software
@ -21,17 +21,15 @@ timestamp='2005-07-08'
#
# 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., 51 Franklin Street - Fifth Floor, Boston, MA
# 02110-1301, USA.
#
# Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, 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>. Submit a context
# diff and a properly formatted ChangeLog entry.
# Please send patches to <config-patches@gnu.org>.
#
# Configuration subroutine to validate and canonicalize a configuration type.
# Supply the specified configuration type as an argument.
@ -71,7 +69,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, 2002, 2003, 2004, 2005
Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
Free Software Foundation, Inc.
This is free software; see the source for copying conditions. There is NO
@ -84,11 +82,11 @@ Try \`$me --help' for more information."
while test $# -gt 0 ; do
case $1 in
--time-stamp | --time* | -t )
echo "$timestamp" ; exit ;;
echo "$timestamp" ; exit 0 ;;
--version | -v )
echo "$version" ; exit ;;
echo "$version" ; exit 0 ;;
--help | --h* | -h )
echo "$usage"; exit ;;
echo "$usage"; exit 0 ;;
-- ) # Stop option processing
shift; break ;;
- ) # Use stdin as input.
@ -100,7 +98,7 @@ while test $# -gt 0 ; do
*local*)
# First pass through any local machine types.
echo $1
exit ;;
exit 0;;
* )
break ;;
@ -119,8 +117,7 @@ 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* | linux-dietlibc | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | \
kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* | storm-chaos* | os2-emx* | rtmk-nova*)
nto-qnx* | linux-gnu* | storm-chaos* | os2-emx*)
os=-$maybe_os
basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`
;;
@ -146,7 +143,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 | -knuth | -cray)
-apple | -axis)
os=
basic_machine=$1
;;
@ -160,14 +157,6 @@ case $os in
os=-vxworks
basic_machine=$1
;;
-chorusos*)
os=-chorusos
basic_machine=$1
;;
-chorusrdb)
os=-chorusrdb
basic_machine=$1
;;
-hiux*)
os=-hiuxwe2
;;
@ -226,57 +215,24 @@ esac
case $basic_machine in
# Recognize the basic CPU types without company name.
# Some are omitted here because they have special meanings below.
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)
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)
basic_machine=$basic_machine-unknown
;;
m6811 | m68hc11 | m6812 | m68hc12)
@ -284,13 +240,13 @@ case $basic_machine in
basic_machine=$basic_machine-unknown
os=-none
;;
m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k)
m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | z8k | v70 | h8500 | w65 | pj | pjl)
;;
# 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*86 | x86_64)
i[234567]86 | x86_64)
basic_machine=$basic_machine-pc
;;
# Object if more than one company name word.
@ -299,67 +255,30 @@ case $basic_machine in
exit 1
;;
# Recognize the basic CPU types with company name.
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-*)
# 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-*)
;;
# Recognize the various machine names and aliases which stand
# for a CPU type and a company and sometimes even an OS.
@ -377,9 +296,6 @@ case $basic_machine in
basic_machine=a29k-amd
os=-udi
;;
abacus)
basic_machine=abacus-unknown
;;
adobe68k)
basic_machine=m68010-adobe
os=-scout
@ -394,12 +310,6 @@ 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
@ -431,10 +341,6 @@ 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
@ -455,45 +361,30 @@ case $basic_machine in
basic_machine=c38-convex
os=-bsd
;;
cray | j90)
basic_machine=j90-cray
cray | ymp)
basic_machine=ymp-cray
os=-unicos
;;
craynv)
basic_machine=craynv-cray
os=-unicosmp
cray2)
basic_machine=cray2-cray
os=-unicos
;;
cr16c)
basic_machine=cr16c-unknown
os=-elf
[cjt]90)
basic_machine=${basic_machine}-cray
os=-unicos
;;
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
@ -502,10 +393,6 @@ 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
@ -618,19 +505,19 @@ case $basic_machine in
basic_machine=i370-ibm
;;
# I'm not sure what "Sysv32" means. Should this be sysv3.2?
i*86v32)
i[34567]86v32)
basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
os=-sysv32
;;
i*86v4*)
i[34567]86v4*)
basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
os=-sysv4
;;
i*86v)
i[34567]86v)
basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
os=-sysv
;;
i*86sol2)
i[34567]86sol2)
basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
os=-solaris2
;;
@ -678,20 +565,28 @@ 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
@ -771,13 +666,6 @@ 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
@ -800,58 +688,42 @@ case $basic_machine in
pbb)
basic_machine=m68k-tti
;;
pc532 | pc532-*)
pc532 | pc532-*)
basic_machine=ns32k-pc532
;;
pentium | p5 | k5 | k6 | nexgen | viac3)
pentium | p5 | k5 | k6 | nexgen)
basic_machine=i586-pc
;;
pentiumpro | p6 | 6x86 | athlon | athlon_*)
pentiumpro | p6 | 6x86 | athlon)
basic_machine=i686-pc
;;
pentiumii | pentium2 | pentiumiii | pentium3)
pentiumii | pentium2)
basic_machine=i686-pc
;;
pentium4)
basic_machine=i786-pc
;;
pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*)
pentium-* | p5-* | k5-* | k6-* | nexgen-*)
basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
pentiumpro-* | p6-* | 6x86-* | athlon-*)
basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*)
pentiumii-* | pentium2-*)
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
;;
@ -869,26 +741,10 @@ 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
;;
@ -896,10 +752,7 @@ case $basic_machine in
basic_machine=sh-hitachi
os=-hms
;;
sh64)
basic_machine=sh64-unknown
;;
sparclite-wrs | simso-wrs)
sparclite-wrs)
basic_machine=sparclite-wrs
os=-vxworks
;;
@ -966,42 +819,22 @@ case $basic_machine in
os=-dynix
;;
t3e)
basic_machine=alphaev5-cray
os=-unicos
;;
t90)
basic_machine=t90-cray
basic_machine=t3e-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
@ -1023,8 +856,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
@ -1045,17 +878,13 @@ case $basic_machine in
basic_machine=hppa1.1-winbond
os=-proelf
;;
xbox)
basic_machine=i686-pc
os=-mingw32
;;
xps | xps100)
basic_machine=xps100-honeywell
;;
ymp)
basic_machine=ymp-cray
xmp)
basic_machine=xmp-cray
os=-unicos
;;
xps | xps100)
basic_machine=xps100-honeywell
;;
z8k-*-coff)
basic_machine=z8k-unknown
os=-sim
@ -1076,12 +905,16 @@ 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
;;
@ -1098,13 +931,13 @@ case $basic_machine in
we32k)
basic_machine=we32k-att
;;
sh[1234] | sh[24]a | sh[34]eb | sh[1234]le | sh[23]ele)
sh3 | sh4)
basic_machine=sh-unknown
;;
sparc | sparcv8 | sparcv9 | sparcv9b)
sparc | sparcv9)
basic_machine=sparc-sun
;;
cydra)
cydra)
basic_machine=cydra-cydrome
;;
orion)
@ -1119,8 +952,9 @@ case $basic_machine in
pmac | pmac-mpw)
basic_machine=powerpc-apple
;;
*-unknown)
# Make sure to match an already-canonicalized machine name.
c4x*)
basic_machine=c4x-none
os=-coff
;;
*)
echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
@ -1174,47 +1008,36 @@ case $os in
| -aos* \
| -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \
| -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \
| -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* | -openbsd* \
| -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \
| -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \
| -hiux* | -386bsd* | -netbsd* | -openbsd* | -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* | -linux-uclibc* | -uxpv* | -beos* | -mpeix* | -udk* \
| -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \
| -mingw32* | -linux-gnu* | -uxpv* | -beos* | -mpeix* | -udk* \
| -interix* | -uwin* | -rhapsody* | -darwin* | -opened* \
| -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \
| -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*)
| -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* | -os2*)
# Remember, each alternative MUST END IN *, to match a version number.
;;
-qnx*)
case $basic_machine in
x86-* | i*86-*)
x86-* | i[34567]86-*)
;;
*)
os=-nto$os
;;
esac
;;
-nto-qnx*)
;;
-nto*)
os=`echo $os | sed -e 's|nto|nto-qnx|'`
os=-nto-qnx
;;
-sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \
| -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \
| -windows* | -osx | -abug | -netware* | -os9* | -beos* \
| -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|'`
;;
@ -1227,9 +1050,6 @@ case $os in
-opened*)
os=-openedition
;;
-os400*)
os=-os400
;;
-wince*)
os=-wince
;;
@ -1248,23 +1068,14 @@ 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
@ -1276,9 +1087,6 @@ case $os in
-sinix*)
os=-sysv4
;;
-tpf*)
os=-tpf
;;
-triton*)
os=-sysv3
;;
@ -1306,17 +1114,8 @@ case $os in
-xenix)
os=-xenix
;;
-*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*)
os=-mint
;;
-aros*)
os=-aros
;;
-kaos*)
os=-kaos
;;
-zvmoe)
os=-zvmoe
-*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*)
os=-mint
;;
-none)
;;
@ -1349,14 +1148,10 @@ 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-*)
@ -1383,9 +1178,6 @@ case $basic_machine in
mips*-*)
os=-elf
;;
or32-*)
os=-coff
;;
*-tti) # must be before sparc entry or we get the wrong os.
os=-sysv3
;;
@ -1395,15 +1187,9 @@ case $basic_machine in
*-be)
os=-beos
;;
*-haiku)
os=-haiku
;;
*-ibm)
os=-aix
;;
*-knuth)
os=-mmixware
;;
*-wec)
os=-proelf
;;
@ -1455,19 +1241,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)
@ -1536,16 +1322,10 @@ case $basic_machine in
-mvs* | -opened*)
vendor=ibm
;;
-os400*)
vendor=ibm
;;
-ptx*)
vendor=sequent
;;
-tpf*)
vendor=ibm
;;
-vxsim* | -vxworks* | -windiss*)
-vxsim* | -vxworks*)
vendor=wrs
;;
-aux*)
@ -1560,16 +1340,13 @@ 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
exit 0
# Local variables:
# eval: (add-hook 'write-file-hooks 'time-stamp)

218
configure.in
View File

@ -3,7 +3,27 @@ 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
@ -33,39 +53,10 @@ 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_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_TRY_COMPILE([],
[#if defined(__linux__) && defined(__ELF__)
this must not compile
#endif],
[AC_MSG_RESULT(no)],
[AC_MSG_RESULT(yes)
LDFLAGS="$LDFLAGS -rdynamic"])
@ -88,7 +79,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)])
@ -109,13 +100,15 @@ 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])
mkdir -p scsh
${CC} -o scsh_aux $srcdir/scsh/scsh_aux.c
AC_MSG_RESULT([defining signal constants])
${CC} -o scsh_aux 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])
@ -147,7 +140,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, [
@ -172,7 +165,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)])
@ -198,23 +191,16 @@ 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
@ -231,21 +217,24 @@ AC_INIT(c/scheme48vm.c)
case "$host" in
## CX/UX
m88k-harris-cxux* )
machine=cxux
dir=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* )
AC_MSG_ERROR("Ultrix is not supported.")
dir=ultrix
if test ${CC} = cc; then
LDFLAGS=-N
fi
;;
## HP 9000 series 700 and 800, running HP/UX
hppa*-hp-hpux* )
machine=hpux
dir=hpux
LDFLAGS="-Wl,-E"
if test ${CC} = cc; then
CFLAGS="-Ae -O +Obb1800"
@ -254,10 +243,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* )
machine=aix
dir=aix
LDFLAGS="-O"
if test ${CC} = gcc; then
LDFLAGS_AIX="-Xlinker -bexport:exportlist.aix"
@ -270,7 +259,7 @@ AC_INIT(c/scheme48vm.c)
## Linux
*-*-linux* )
machine=linux
dir=linux
# gross, but needed for some older a.out systems for 0.4.x
LIBS=-lc
SCSH_ELF
@ -278,58 +267,52 @@ AC_INIT(c/scheme48vm.c)
## NetBSD and FreeBSD ( and maybe 386BSD also)
*-*-*bsd*|*-*-darwin* )
machine=bsd
dir=bsd
SCSH_ELF
;;
## NeXT
*-next-* )
machine=next
dir=next
CC="$CC -posix"
AC_DEFINE(HAVE_SIGACTION)
;;
## SGI IRIX
mips-sgi-irix* )
machine=irix
dir=irix
S48_CFLAG_CKR
INSTALL='$(srcdir)/install-sh'
;;
## SunOS
sparc*-sun-sunos* )
machine=sunos
dir=sunos
;;
## Solaris - Sparc and i386
*-*-solaris* )
machine=solaris
dir=solaris
AC_DEFINE(HAVE_NLIST)
;;
## NT - cygwin32
*-*-cygwin* )
AC_DEFINE(CYGWIN, 1, [Define to 1 on cygwin])
machine=cygwin32
dir=cygwin32
EXEEXT=".exe"
;;
## The GNU Hurd
*-*-gnu* )
machine=gnu
SCSH_ELF
;;
## Generic Configuration
* )
machine=generic
dir=generic
echo "WARNING: "
echo "WARNING: Using generic configuration."
echo "WARNING: See doc/porting.txt for more information."
echo "WARNING: "
;;
esac
(mkdir -p ./scsh/$machine scsh/rx c/unix c/srfi)
(cd $srcdir/scsh && rm -rf machine && ln -s $dir machine)
AC_CHECK_LIB(m, main)
AC_CHECK_LIB(dl, main)
@ -346,30 +329,28 @@ 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])
have_dlopen="yes"],
SCSH_SOCKLEN_T
AC_CHECK_FUNC(dlopen, [AC_DEFINE(HAVE_DLOPEN,
1, [Define to 1 if the interface to the dynamic linker exists])],
[AC_CHECK_FUNC(nlist, [AC_LIBOBJ([c/fake/libdl1])],
[AC_LIBOBJ([c/fake/libdl2])])
have_dlopen="no"])
[AC_LIBOBJ([c/fake/libdl2])])])
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.")])])
@ -389,68 +370,17 @@ fail
AC_MSG_RESULT([yes]),
AC_MSG_RESULT([no]))
S48_USCORE
if test $have_dlopen = yes; then
S48_RDYNAMIC
fi
S48_RDYNAMIC
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]))
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
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)
@ -458,14 +388,14 @@ AC_CHECK_FUNCS(isastream)
AC_SUBST(CFLAGS)
AC_SUBST(CFLAGS1)
AC_SUBST(EXEEXT)
AC_SUBST(ENDIAN) #does currently not occur
AC_SUBST(ENDIAN)
AC_SUBST(LDFLAGS)
AC_SUBST(LDFLAGS_AIX)
AC_SUBST(LIBS)
AC_SUBST(TMPDIR)
AC_SUBST(machine)
AC_CONFIG_FILES(Makefile scsh-config)
AC_CONFIG_FILES(Makefile scsh/endian.scm scsh-config)
AC_CONFIG_COMMANDS([scsh-config+x],[chmod +x scsh-config])
AC_OUTPUT

12
doc/scsh-manual/Makefile
View File

@ -1,26 +1,28 @@
.SUFFIXES: .tex .dvi .ps .pdf $(.SUFFIXES)
.SUFFIXES: .idx .ind .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.pdf: $(TEX)
man.dvi: $(TEX) man.ind
man.ind: man.idx
man.pdf: $(TEX) man.ind
.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

186
doc/scsh-manual/awk.tex
View File

@ -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 $ list-ref) ; Saves typing.
(define $ nth) ; Saves typing.
;;; Print out the name and home-directory of everyone in /etc/passwd:
(let ((read-passwd (field-reader (infix-splitter ":" 7))))

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

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

2
doc/scsh-manual/man.t2p
View File

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

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

@ -13,7 +13,7 @@
\input{pdfcond}
\ifpdf
\usepackage[pdftex,hyperindex,
pdftitle={scsh manual, release 0.6.7},
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,
@ -22,7 +22,11 @@
\usepackage{tocbibind}
\else
\usepackage[dvipdfm,hyperindex,hypertex,
colorlinks=true,linkcolor=blue,pagecolor=blue,urlcolor=blue]{hyperref}
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}
\fi
\endtexonly

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

@ -17,6 +17,20 @@
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}
@ -392,65 +406,6 @@ 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"

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

@ -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}{make-char-port-filter}{filter}{\proc}
\begin{defundesc}{char-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}{make-string-port-filter}{filter [buflen]}{\proc}
\begin{defundesc}{string-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,

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

@ -72,8 +72,8 @@ See section~\ref{sec:char-sets} for information on character set manipulation.
The \var{handle-delim} parameter determines how the terminating character
is handled. It is described above, and defaults to \ex{'trim}.
The \var{char-set} argument may be a charset, a string, or a
character; it is coerced to a charset.
The \var{char-set} argument may be a charset, a string, a character, or a
character predicate; 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, or a
character; it is coerced to a charset.
The \var{skip-chars} argument may be a charset, a string, a character, or a
character predicate; it is coerced to a charset.
\end{defundesc}
%%% Local Variables:

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

@ -176,111 +176,9 @@ 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]}
@ -316,8 +214,6 @@ 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}
@ -510,50 +406,70 @@ 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 (see Section \ref{sec:lib-dirs})
for the file to load.
library-directory path list 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. Scsh uses the
procedure \var{find-library-file} from Section \ref{sec:lib-dirs}
to perform the search.
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}
\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.
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{+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. These switches correspond to the procedures
\ex{lib-dirs-prepend!} and \ex{lib-dirs-append!} from Section
\ref{sec:lib-dirs}.
otherwise processed.
\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. These switches correspond to
the procedures \ex{clear-lib-dirs!} and \ex{reset-lib-dirs!} from Section
\ref{sec:lib-dirs}.
the system default, respectively.
The two switches are useful if you would like to protect your
These 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
@ -902,13 +818,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 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 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.
\subsection{Inserting interpreter triggers into heap images}
{\scm}'s heap image format allows for an informational header:

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

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

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

@ -572,7 +572,6 @@ 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}
@ -1695,7 +1694,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}
@ -1824,7 +1823,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
@ -1881,7 +1880,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
@ -2565,9 +2564,11 @@ or integer process ids.
\begin{desc}
Schedules a timer interrupt in \var{secs} seconds.
\end{desc}
\note{As the thread system needs the timer interrupt for its own purpose,
\begin{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.}
handler for \ex{interrupt/alrm} after the specified time.
\end{note}
\defun{process-sleep}{secs} \undefined
\defunx{process-sleep-until}{time}\undefined
@ -2583,7 +2584,6 @@ 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,11 +2670,17 @@ 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 error is signaled.
If the signal does not have a defined {\scm} interrupt, an errror is signaled.
\end{defundesc}
@ -2716,7 +2722,6 @@ 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.
@ -2736,10 +2741,6 @@ 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}
@ -2749,28 +2750,6 @@ A handler is either \ex{\#f} (ignore), \ex{\#t} (default), or a
procedure taking an integer argument.
\end{defundesc}
Note that scsh does \emph{not} support interrupt handlers for
``synchronous'' {\Unix} signals, such as \ex{signal/ill} or
\ex{signal/pipe} (see table~\ref{table:uncatchable-signals}).
Synchronous occurrences of these signals are better handled by raising
a Scheme exception. There are, however, some rare situtations where it
is necessary to ignore the occurrence of a synchronous signal. For
this case, the following procedures exist:
\defun{ignore-signal}{\integer}{\undefined}
\defunx{handle-signal-default}{\integer}{\undefined}
\begin{desc}
The procedure \ex{ignore-signal} tells the process to ignore the
given signal. The procedure \ex{handle-signal-default} resets the
signal handler to the default handler.
These procedures manipulate the raw signal handler of the scsh
process and therfore undermine the signal handling facility of the
VM. They are intended to be used for igoring synchronous signals if
system calls cannot succeed otherwise. Do not use these procedures
for asynchronous signals!
\end{desc}
% %set-unix-signal-handler
% %unix-signal-handler

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

@ -191,15 +191,6 @@ 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}
@ -248,7 +239,4 @@ Therefore they remain global process state: If a thread changes one of
these values, all other threads see the new value. Consequently, scsh
does not provide \texttt{with-uid} and friends.
%%% Local Variables:
%%% mode: latex
%%% TeX-master: "man"
%%% End:

5
emacs/cmulisp.el
View File

@ -1,6 +1,9 @@
;;; -*-Emacs-Lisp-*- cmulisp.el
;;; Copyright Olin Shivers (1988).
;;; See file COPYING
;;; 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.
;;; This replaces the standard inferior-lisp mode.
;;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88

5
emacs/cmuscheme.el
View File

@ -1,6 +1,9 @@
;;; cmuscheme.el -- Scheme process in a buffer. Adapted from tea.el.
;;; Copyright Olin Shivers (1988)
;;; See file COPYING
;;; 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.
;;;
;;; This is a customisation of comint-mode (see comint.el)
;;;

5
emacs/cmushell.el
View File

@ -1,6 +1,9 @@
;;; -*-Emacs-Lisp-*- General command interpreter in a window stuff
;;; Copyright Olin Shivers (1988).
;;; See file COPYING
;;; 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.
;;; The changelog is at the end of file.

5
emacs/comint.el
View File

@ -1,6 +1,9 @@
;;; -*-Emacs-Lisp-*- General command interpreter in a window stuff
;;; Copyright Olin Shivers (1988).
;;; See file COPYING
;;; 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.
;;; The changelog is at the end of this file.

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

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

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

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

30
scheme/bcomp/mtype.scm
View File

@ -1,4 +1,4 @@
; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Type lattice.
; Sorry this is so hairy, but before it was written, type checking
@ -619,8 +619,6 @@
(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))))
@ -643,20 +641,18 @@
; Convert type to S-expression
(define (type->sexp t r?)
(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))))))))
(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)))

151
scheme/big/sort.scm Normal file
View File

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

29
scheme/infix/packages.scm Normal file
View File

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

308
scheme/infix/pratt.scm Normal file
View File

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

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

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

213
scheme/infix/sgol.scm Normal file
View File

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

154
scheme/infix/tokenize.scm Normal file
View File

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

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

@ -174,7 +174,7 @@
type index))
'("VECTOR" "RECORD")
'("(i)" "(i) + 1"))
(c-define "S48_RECORD_TYPE(x) (s48_stob_ref((x), S48_STOBTYPE_RECORD, 0))")
(c-define "S48_RECORD_TYPE(x) (s48_stob_ref((x), S48_STOBTYPE_RECORD))")
(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))"

4
scheme/misc/annotate.scm
View File

@ -7,7 +7,7 @@
(define annotate-procedure
(lap annotate-procedure ()
0 (protocol 2)
0 (check-nargs= 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 (protocol 1)
0 (check-nargs= 1)
2 (make-env 1)
4 (literal '2)
6 (push)

20
scheme/more-interfaces.scm
View File

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

114
scheme/more-packages.scm
View File

@ -415,7 +415,6 @@
(files (big placeholder))
(optimize auto-integrate))
;----------------
; Big Scheme
@ -424,6 +423,10 @@
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
@ -492,87 +495,6 @@
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
@ -773,7 +695,7 @@
; SRFI-4 - needs hacks to the reader
(define-structure srfi-5 (export (let :syntax))
(open (modify scheme-level-2 (rename (let standard-let))))
(open (modify scheme-level-2 (hide let)))
(files (srfi srfi-5)))
(define-structure srfi-6 (export open-input-string
@ -807,9 +729,8 @@
(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-42))
srfi-25 srfi-26 srfi-27 srfi-28 srfi-30 srfi-31
srfi-37))
; Some SRFI's redefine Scheme variables.
(define shadowed
@ -892,8 +813,8 @@
(subset srfi-1 (reverse!))
srfi-6
srfi-8
srfi-9
srfi-23)
signals
srfi-9)
(files (srfi srfi-19))))
; SRFI-20 - withdrawn
@ -952,12 +873,6 @@
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
@ -1020,17 +935,7 @@
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
@ -1055,7 +960,6 @@
srfi-11 srfi-13 srfi-14 srfi-16 srfi-17
srfi-23 srfi-25 srfi-26 srfi-27 srfi-28
srfi-31 srfi-37
srfi-42
)
:structure)
make-srfi-19

2
scheme/opt/flatten.scm
View File

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

4
scheme/opt/inline.scm
View File

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

4
scheme/opt/usage.scm
View File

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

8
scheme/rts/numio.scm
View File

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

3
scheme/rts/xnum.scm
View File

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

185
scheme/sort/delndups.scm
View File

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

199
scheme/sort/interfaces.scm
View File

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

386
scheme/sort/lmsort.scm
View File

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

70
scheme/sort/packages.scm
View File

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

26
scheme/sort/sort.scm
View File

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

1056
scheme/sort/sort.txt
View File

File diff suppressed because it is too large Load Diff

35
scheme/sort/sortp.scm
View File

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

65
scheme/sort/test.scm
View File

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

34
scheme/sort/vbinsearch.scm
View File

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

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

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

117
scheme/sort/vhsort.scm
View File

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

76
scheme/sort/visort.scm
View File

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

238
scheme/sort/vmsort.scm
View File

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

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

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

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

@ -1365,38 +1365,30 @@
;;; comparison testing with fancier implementations.
;;; See below for fast KMP version.
(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 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 text pattern . maybe-starts+ends)
(let-string-start+end2 (t-start t-end p-start p-end)
string-contains text pattern maybe-starts+ends
(%string-contains text pattern t-start t-end p-start p-end string=)))
(%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
(%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)))
(%kmp-search pattern text char-ci=? p-start p-end t-start t-end)))
;;; Knuth-Morris-Pratt string searching
@ -1713,7 +1705,7 @@
;; string starts.
(let lp ((len 0) (nzlist #f) (lis string-list))
(if (pair? lis)
(let ((slen (string-length (car lis))))
(let ((slen (string-length (car string-list))))
(lp (+ len slen)
(if (or nzlist (zero? slen)) nzlist lis)
(cdr lis)))
@ -2053,36 +2045,36 @@
;;; details.
;;; -Olin Shivers
;;; 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:
;;; 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.
;;;
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 1. Any copy made of this software must include this copyright notice
;;; in full.
;;;
;;; 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.
;;; 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.
;;;
;;; 3. The name of the author may not be used to endorse or promote
;;; products derived from this software without specific prior
;;; written permission.
;;; 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.
;;;
;;; 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.
;;; 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.
;;; Scsh copyright terms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

@ -10,22 +10,6 @@
;;; 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<=
@ -532,7 +516,7 @@
base-cs)
;;; {string, char, char-set} -> char-set
;;; {string, char, char-set, char predicate} -> char-set
(define (x->char-set x)
(cond ((char-set? x) x)
@ -883,34 +867,35 @@
;;; save calling overhead and enable procedure integration -- but they
;;; are not appropriate for exported routines.
;;; The MIT Scheme project gave Olin Shivers the permission to use the
;;; code from this SRFI under the following license:
;;; Copyright notice
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Copyright (c) 1988-1995 Massachusetts Institute of Technology
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions are
;;; met:
;;; 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.
;;;
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 1. Any copy made of this software must include this copyright notice
;;; in full.
;;;
;;; 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.
;;; 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.
;;;
;;; 3. The name of the author may not be used to endorse or promote
;;; products derived from this software without specific prior
;;; written permission.
;;; 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.
;;;
;;; 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.
;;; 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.

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

@ -145,9 +145,9 @@
(define (tm:time-error caller type value)
(if (member type tm:time-error-types)
(if value
(error caller "TIME-ERROR type" type value)
(error caller "TIME-ERROR type" type))
(error caller "TIME-ERROR unsupported error type" type)))
(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)))
;; 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,9 +302,14 @@
(define (tm:current-time-thread)
(tm:time-error 'current-time 'unsupported-clock-type 'time-thread))
;; Scheme48 portability: no process time in Scheme48 (regeression from SCSH)
;; SCSH portability: use cpu-ticks/sec
(define (tm:current-time-process)
(tm:time-error 'current-time 'unsupported-clock-type 'time-gc))
(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)))))
;; SCSH portability: GC time not available in scsh
(define (tm:current-time-gc)
@ -627,17 +632,16 @@
(else
(tm:char-pos char str (+ index 1) len))))
;; 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)))))))
(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))))))
;; gives the seconds/date/month/year
(define (tm:decode-julian-day-number jdn)
@ -663,7 +667,7 @@
;; SCSH portability: use scsh's DATE procedure
(define (tm:local-tz-offset)
0) ;; FIXME: quick hack
(date:tz-secs (date)))
;; special thing -- ignores nanos
(define (tm:time->julian-day-number seconds tz-offset)
@ -818,21 +822,22 @@
(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)
(+ (/ (+ (* hour 60 60)
(* minute 60)
second
(/ nanosecond tm:nano)
(- offset))
tm:sid)))))
;; SCSH portability: use binary /
(+ (/ (/ (+ (* hour 60 60)
(* minute 60)
second
(/ nanosecond tm:nano))
tm:sid)
(- offset))))))
(define (date->modified-julian-day date)
(- (date->julian-day date)
@ -1041,11 +1046,17 @@
(display (tm:padding (date-second date)
pad-with 2)
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))))))
(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)))))))
(cons #\h (lambda (date pad-with port)
(display (date->string date "~b") port)))
(cons #\H (lambda (date pad-with port)
@ -1475,3 +1486,4 @@
(if (tm:date-ok? newdate)
newdate
(tm:time-error 'string->date 'bad-date-format-string (list "Incomplete date read. " newdate template-string)))))

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

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

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

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

4
scsh/aix/sysdep.h Normal file
View File

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

0
scsh/gnu/time_dep1.c → scsh/aix/time_dep1.c
View File

0
scsh/bsd/sysdep.h Normal file
View File

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

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

31
scsh/command-line.scm
View File

@ -1,31 +0,0 @@
;;; 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 '()))

53
scsh/configure.scm.in
View File

@ -1,53 +0,0 @@
(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:

21
scsh/continuation.scm
View File

@ -1,21 +0,0 @@
;;; 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)

10
scsh/crypt.scm
View File

@ -1,10 +0,0 @@
(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)))

36
scsh/cstuff.c
View File

@ -14,39 +14,3 @@ 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);
}
}

13
scsh/cstuff.h
View File

@ -1,10 +1,4 @@
#include <string.h>
#include <stddef.h>
#include <stdio.h>
#include <stdlib.h>
#include <errno.h>
#include "scheme48.h"
#include "libcig.h"
#define Alloc(type) ((type *) malloc(sizeof(type)))
#define Malloc(type,n) ((type *) malloc(sizeof(type)*(n)))
#define Free(p) (free((char *)(p)))
@ -14,8 +8,3 @@
#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);

2
scsh/cygwin32/sysdep.h Normal file
View File

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

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

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

2
scsh/db.c
View File

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

7
scsh/db.scm
View File

@ -1,7 +1,10 @@
;;; Very vanilla DBM processing code
;;; Copyright (c) 1995 by David Albertz (dalbertz@clark.lcs.mit.edu).
;;; See file COPYING
;;; This code is freely available for use by anyone for any purpose,
;;; so long as you don't charge money for it, remove this notice, or
;;; hold us liable for any results of its use. --enjoy.
;;; This is just a straight translation of the UNIX freebie NDBM code.
@ -73,7 +76,7 @@
""
"extern int errno;"
""
"#define errno_or_false(x) (((x) == -1) ? s48_enter_integer(errno) : S48_FALSE)"
"#define errno_or_false(x) (((x) == -1) ? s48_enter_fixnum(errno) : S48_FALSE)"
"" "")
(define-foreign %db-open (db_open (string file)

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