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

*** empty log message ***

This commit is contained in:
marting 1999-09-14 12:45:02 +00:00
commit 606245fc41
513 changed files with 115190 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
.gitignore vendored Normal file
View File

@ -0,0 +1,28 @@
# CVS default ignores begin
tags
TAGS
.make.state
.nse_depinfo
*~
\#*
.#*
,*
_$*
*$
*.old
*.bak
*.BAK
*.orig
*.rej
.del-*
*.a
*.olb
*.o
*.obj
*.so
*.exe
*.Z
*.elc
*.ln
core
# CVS default ignores end

46
COPYING Normal file
View File

@ -0,0 +1,46 @@
Copyright (c) 1993-1999 Richard Kelsey and Jonathan Rees
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. The name of the authors may not be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.
Distributing Autoconf Output
****************************
[excerpt from autoconf documentation]
The configuration scripts that Autoconf produces are covered by the
GNU General Public License. This is because they consist almost
entirely of parts of Autoconf itself, rearranged somewhat, and Autoconf
is distributed under the terms of the GPL. As applied to Autoconf, the
GPL just means that you need to distribute `configure.in' along with
`configure'.
Programs that use Autoconf scripts to configure themselves do not
automatically come under the GPL. Distributing an Autoconf
configuration script as part of a program is considered to be *mere
aggregation* of that work with the Autoconf script. Such programs are
not derivative works based on Autoconf; only their configuration scripts
are. We still encourage software authors to distribute their work under
terms like those of the GPL, but doing so is not required to use
Autoconf.

120
INSTALL Normal file
View File

@ -0,0 +1,120 @@
This is a generic INSTALL file for utilities distributions.
If this package does not come with, e.g., installable documentation or
data files, please ignore the references to them below.
[For information specific to Scheme 48, see doc/install.txt.]
The `configure' shell script attempts to guess correct values for
various system-dependent variables used during compilation, and
creates the Makefile(s) (one in each subdirectory of the source
directory). In some packages it creates a C header file containing
system-dependent definitions. It also creates a file `config.status'
that you can run in the future to recreate the current configuration.
To compile this package:
1. Configure the package for your system.
Normally, you just `cd' to the directory containing the package's
source code and type `./configure'. If you're using `csh' on an old
version of System V, you might need to type `sh configure' instead to
prevent `csh' from trying to execute `configure' itself.
Running `configure' takes a minute or two. While it is running, it
prints some messages that tell what it is doing. If you don't want to
see the messages, run `configure' with its standard output redirected
to `/dev/null'; for example, `./configure >/dev/null'.
To compile the package in a different directory from the one
containing the source code, you must use a version of `make' that
supports the `VPATH' variable, such as GNU `make'. `cd' to the
directory where you want the object files and executables to go and run
the `configure' script. `configure' automatically checks for the
source code in the directory that `configure' is in and in `..'. If
for some reason `configure' is not in the source code directory that
you are configuring, then it will report that it can't find the source
code. In that case, run `configure' with the option `--srcdir=DIR',
where DIR is the directory that contains the source code.
By default, `make install' will install the package's files in
`/usr/local/bin', `/usr/local/man', etc. You can specify an
installation prefix other than `/usr/local' by giving `configure' the
option `--prefix=PATH'. Alternately, you can do so by consistently
giving a value for the `prefix' variable when you run `make', e.g.,
make prefix=/usr/gnu
make prefix=/usr/gnu install
You can specify separate installation prefixes for
architecture-specific files and architecture-independent files. If you
give `configure' the option `--exec-prefix=PATH' or set the `make'
variable `exec_prefix' to PATH, the package will use PATH as the prefix
for installing programs and libraries. Data files and documentation
will still use the regular prefix. Normally, all files are installed
using the same prefix.
Some packages pay attention to `--with-PACKAGE' options to
`configure', where PACKAGE is something like `gnu-as' or `x' (for the X
Window System). The README should mention any `--with-' options that
the package recognizes.
`configure' ignores any other arguments that you give it.
On systems that require unusual options for compilation or linking
that the package's `configure' script does not know about, you can give
`configure' initial values for variables by setting them in the
environment. In Bourne-compatible shells, you can do that on the
command line like this:
CC='gcc -traditional' LIBS=-lposix ./configure
Here are the `make' variables that you might want to override with
environment variables when running `configure'.
For these variables, any value given in the environment overrides the
value that `configure' would choose:
- Variable: CC
C compiler program. The default is `cc'.
- Variable: INSTALL
Program to use to install files. The default is `install' if you
have it, `cp' otherwise.
For these variables, any value given in the environment is added to
the value that `configure' chooses:
- Variable: DEFS
Configuration options, in the form `-Dfoo -Dbar...'. Do not use
this variable in packages that create a configuration header file.
- Variable: LIBS
Libraries to link with, in the form `-lfoo -lbar...'.
If you need to do unusual things to compile the package, we encourage
you to figure out how `configure' could check whether to do them, and
mail diffs or instructions to the address given in the README so we
can include them in the next release.
2. Type `make' to compile the package. If you want, you can override
the `make' variables CFLAGS and LDFLAGS like this:
make CFLAGS=-O2 LDFLAGS=-s
3. If the package comes with self-tests and you want to run them,
type `make check'. If you're not sure whether there are any, try it;
if `make' responds with something like
make: *** No way to make target `check'. Stop.
then the package does not come with self-tests.
4. Type `make install' to install programs, data files, and
documentation.
5. You can remove the program binaries and object files from the
source directory by typing `make clean'. To also remove the
Makefile(s), the header file containing system-dependent definitions
(if the package uses one), and `config.status' (all the files that
`configure' created), type `make distclean'.
The file `configure.in' is used to create `configure' by a program
called `autoconf'. You only need it if you want to regenerate
`configure' using a newer version of `autoconf'.

535
Makefile.in Normal file
View File

@ -0,0 +1,535 @@
# Scheme 48 Makefile
# Documentation in files INSTALL and doc/install.txt
SHELL = /bin/sh
### Filled in by `configure' ###
srcdir = @srcdir@
VPATH = @srcdir@
CC = @CC@
DEFS = @DEFS@
LIBS = @LIBS@
CFLAGS = @CFLAGS@
INSTALL = @INSTALL@
INSTALL_PROGRAM = @INSTALL_PROGRAM@
INSTALL_DATA = @INSTALL_DATA@
LDFLAGS = @LDFLAGS@
LIBOBJS = @LIBOBJS@
prefix = @prefix@
exec_prefix = @exec_prefix@
### End of `configure' section###
bindir = $(exec_prefix)/bin
libdir = $(exec_prefix)/lib
incdir = $(exec_prefix)/include
manext = 1
mandir = $(prefix)/man/man$(manext)
# HP 9000 series, if you don't have gcc
# CC = cc
# CFLAGS = -Aa -O +Obb1800
# DEFS = -D_HPUX_SOURCE -Dhpux
# Ultrix
# LDFLAGS = -N
.c.o:
$(CC) -c $(CPPFLAGS) $(DEFS) -I$(srcdir)/c $(CFLAGS) -o $@ $<
# You might want to change RUNNABLE to "s48"
RUNNABLE = scheme48
MANPAGE = $(RUNNABLE).$(manext)
LIB = $(libdir)/$(RUNNABLE)
distdir = /tmp
# If make barfs on this include line, just comment it out. It's only
# really needed if you want to build the linker or rebuild initial.image.
include $(srcdir)/build/filenames.make
#
#NetBSD make wants to see this instead:
#.include "$(srcdir)/build/filenames.make"
# Static linker:
#
# You only need the linker if you're going to make changes to the
# things that go into the initial.image, which in general means the
# files in rts/. If you decide you need to use the linker, then you
# gots your choice; it can run in just about any version of Scheme 48
# or Pseudoscheme. (It has also been made to run in Scheme->C.) It
# doesn't matter a whole lot which Scheme you use as long as it's not
# broken or unavailable. The two best choices are:
# 1. As below: build the linker on the scheme48vm and scheme48.image
# that are in the current directory.
# 2. LINKER_VM = $(RUNNABLE) $(BIG_HEAP)
# LINKER_RUNNABLE = $(RUNNABLE)
# These settings requires you to already have a $(RUNNABLE)
# command. This is desirable if you are making changes to the
# system that might break scheme48vm and/or scheme48.image. But it
# requires you to have squirreled away a previous working version
# of scheme48.
BIG_HEAP = -h 5000000
LINKER_VM = ./$(VM) $(BIG_HEAP)
LINKER_RUNNABLE = $(LINKER_VM) -i $(IMAGE)
LINKER_IMAGE = build/linker.image
LINKER = $(LINKER_VM) -i $(LINKER_IMAGE)
START_LINKER = echo ',batch' && echo ',bench on'
# --------------------
# You shouldn't have to change anything below this point, except for possibly
# the external code rules.
# Targets:
IMAGE = scheme48.image
INITIAL = build/initial.image
VM = scheme48vm
UNIX_OBJS = c/unix/misc.o c/unix/io.o c/unix/fd-io.o c/unix/event.o
OBJS = c/scheme48vm.o c/scheme48heap.o c/extension.o c/external.o
FAKEHS = c/fake/dlfcn.h c/fake/sigact.h c/fake/strerror.h \
c/fake/sys-select.h
# Sources:
CONFIG_FILES = scheme/interfaces.scm scheme/low-packages.scm \
scheme/rts-packages.scm scheme/comp-packages.scm
# Rules:
# The following is the first rule and therefore the "make" command's
# default target.
enough: $(VM) $(IMAGE) go .notify
# --------------------
# External code to include in the VM
# After changing any of these you should delete `scheme48vm' and remake it.
EXTERNAL_OBJECTS = $(SOCKET_OBJECTS) $(LOOKUP_OBJECTS)
EXTERNAL_FLAGS = $(SOCKET_FLAGS)
EXTERNAL_INITIALIZERS = $(SOCKET_INITIALIZERS) $(LOOKUP_INITIALIZERS)
# Rules for any external code.
# Socket rules
c/unix/socket.o: c/scheme48.h c/fd-io.h c/event.h
SOCKET_OBJECTS = c/unix/socket.o
SOCKET_LD_FLAGS =
SOCKET_INITIALIZERS = s48_init_socket
# End of socket rules
# Lookup rules (this is just for compatibility with old code)
c/unix/dynamo.o: c/scheme48.h
LOOKUP_OBJECTS = c/unix/dynamo.o
LOOKUP_INITIALIZERS = s48_init_external_lookup
# End of lookup rules
# End of external rules
# --------------------
# The developers are curious to know. Don't be concerned if this fails.
.notify: build/minor-version-number
touch .notify
-echo Another 0.`cat $(srcdir)/build/minor-version-number` \
installation. \
| mail scheme-48-notifications@martigny.ai.mit.edu
$(VM): c/main.o $(OBJS) $(UNIX_OBJS) $(LIBOBJS) $(EXTERNAL_OBJECTS)
rm -f /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 \
$(LIBOBJS) $(LIBS) \
$(EXTERNAL_OBJECTS) $(EXTERNAL_LD_FLAGS) && \
rm -f /tmp/s48_external_$$$$.c
c/main.o: c/main.c c/scheme48vm.h c/scheme48heap.h
$(CC) -c $(CFLAGS) -o $@ \
-DDEFAULT_IMAGE_NAME=\"$(LIB)/$(IMAGE)\" \
$(CPPFLAGS) $(DEFS) c/main.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
c/scheme48heap.o: c/prescheme.h c/scheme48vm.h c/scheme48heap.h c/event.h \
c/io.h c/fd-io.h
c/extension.o: c/sysdep.h $(FAKEHS) c/scheme48.h c/scheme48vm.h
c/external.o: c/sysdep.h $(FAKEHS) c/scheme48.h
c/unix/event.o: c/sysdep.h $(FAKEHS) c/scheme48vm.h c/scheme48heap.h \
c/event.h c/fd-io.h
c/unix/fd-io.o: c/sysdep.h $(FAKEHS) c/scheme48vm.h c/scheme48heap.h \
c/event.h c/fd-io.h
c/unix/misc.o: c/sysdep.h $(FAKEHS)
c/unix/io.o: c/io.h
c/fake/libdl1.o: c/fake/dlfcn.h
c/fake/libdl2.o: c/fake/dlfcn.h
c/fake/strerror.o: c/fake/strerror.h
# --------------------
# Make scheme48.image from initial.image and library .scm files.
#
# For bootstrap reasons, initial.image is *not* listed as a source,
# even though it really is.
$(IMAGE): $(VM) scheme/env/init-defpackage.scm scheme/more-interfaces.scm \
scheme/link-packages.scm scheme/more-packages.scm \
$(usual-files) build/initial.debug build/build-usual-image
build/build-usual-image . "`pwd`/scheme" '$(IMAGE)' './$(VM)' \
'$(INITIAL)'
### Fake targets: all clean install man dist
install: enough dirs inst-script inst-vm inst-misc inst-man inst-inc inst-image
inst-vm:
$(INSTALL_PROGRAM) $(VM) $(LIB)
inst-image:
rm -f '/tmp/$(IMAGE)' && \
build/build-usual-image . '$(LIB)' '/tmp/$(IMAGE)' './$(VM)' \
'$(INITIAL)' && \
$(INSTALL_DATA) /tmp/$(IMAGE) $(LIB) && \
rm /tmp/$(IMAGE)
inst-man:
if [ -d $(mandir) -a -w $(mandir) ]; then \
sed 's=LBIN=$(bindir)=g' doc/scheme48.man | \
sed 's=LLIB=$(LIB)=g' | \
sed 's=LS48=$(RUNNABLE)=g' >$(MANPAGE) && \
$(INSTALL_DATA) $(MANPAGE) $(mandir) && \
rm $(MANPAGE); \
else \
echo "$(mandir) not writable dir, not installing man page" \
>&2; \
fi
inst-inc:
$(INSTALL_DATA) c/scheme48.h $(incdir)
inst-misc:
for stub in env big opt misc link; do \
for f in scheme/$$stub/*.scm; do \
$(INSTALL_DATA) $$f $(LIB)/$$stub || exit 1; \
done; \
done && \
for f in scheme/rts/*num.scm scheme/rts/jar-defrecord.scm; do \
$(INSTALL_DATA) $$f $(LIB)/rts || exit 1; \
done
inst-script:
script=$(bindir)/$(RUNNABLE) && \
echo '#!/bin/sh' >$$script && \
echo >>$$script && \
echo 'lib=$(LIB)' >>$$script && \
echo 'exec $$lib/$(VM) -o $$lib/$(VM) -i $$lib/$(IMAGE) "$$@"' \
>>$$script && \
chmod +x $$script
# Script to run scheme48 in this directory.
go:
echo '#!/bin/sh' >$@ && \
echo >>$@ && \
echo "lib=`pwd`" >>$@ && \
echo 'exec $$lib/$(VM) -o $$lib/$(VM) -i $$lib/$(IMAGE) "$$@"' \
>>$@ && \
chmod +x $@
dirs:
for dir in $(libdir) $(bindir) $(incdir); do \
[ -d $$dir -a -w $$dir ] || { \
echo "$$dir not a writable directory" >&2; \
exit 1; \
}; \
done
{ mkdir -p $(LIB) && [ -w $(LIB) ]; } || { \
echo "$(LIB) not a writable directory" >&2; \
exit 1; \
}
for dir in rts env big opt misc link; do \
{ mkdir -p $(LIB)/$$dir && [ -w $(LIB)/$$dir ]; } || { \
echo "$(LIB)/$$dir not a writable directory" >&2; \
exit 1; \
}; \
done
configure: configure.in
autoheader && autoconf
clean:
-rm -f $(VM) *.o c/unix/*.o c/*.o c/fake/*.o \
TAGS $(IMAGE) \
build/*.tmp $(MANPAGE) build/linker.image \
scheme/debug/*.image scheme/debug/*.debug config.cache \
scheme/vm/scheme48vm.c scheme/vm/scheme48heap.c \
go $(distname)
distclean: clean
rm -f Makefile config.log config.status c/sysdep.h
check: $(VM) $(IMAGE) scheme/debug/check.scm
( \
echo ',batch'; \
echo ',translate =scheme48 scheme'; \
echo ',config ,load scheme/debug/test.scm'; \
echo ',exec ,load scheme/debug/check.scm'; \
echo ',exec (done)' \
) | ./$(VM) -i $(IMAGE)
# --------------------
# Rules from here on down are not essential for the basic installation
# procedure, and are not expected to work when srcdir is not the
# distribution directory.
all: vm linker
$(MAKE) image
vm: $(VM)
linker: $(LINKER_IMAGE)
image: $(INITIAL)
$(MAKE) $(IMAGE)
tags:
etags scheme/vm/arch.scm scheme/rts/*.scm scheme/bcomp/*.scm \
scheme/*.scm scheme/env/*.scm scheme/big/*.scm scheme/link/*.scm \
scheme/opt/*.scm scheme/debug/*.scm scheme/misc/*.scm
# --------------------
# Distribution...
# DISTFILES should include all sources.
DISTFILES = README COPYING INSTALL configure \
acconfig.h configure.in Makefile.in install-sh \
doc/*.ps doc/*.txt doc/html/*.html doc/scheme48.man \
doc/src/*.tex doc/src/*.sty \
emacs/README build/*-version-number build/*.exec \
build/*.lisp build/build-usual-image build/filenames.make \
build/filenames.scm build/initial.debug \
build/initial.image build/initial.scm \
build/build-external-modules \
c/*.[ch] c/*/*.[ch] c/scheme48.h.in \
emacs/*.el gdbinit \
scheme/*.scm scheme/*/*.scm \
ps-compiler \
c/sysdep.h.in
distname = $(RUNNABLE)-0.`cat build/minor-version-number`
dist: build/initial.image
distname=$(distname) && \
distfile=$(distdir)/$$distname.tgz && \
if [ -d $(distdir) ] && \
[ -w $$distfile -o -w $(distdir) ]; then \
rm -f $$distname && \
ln -s . $$distname && \
files='' && \
for i in $(DISTFILES); do \
if [ "$$i" != "c/sysdep.h" ]; then \
files="$$files $$distname/$$i"; \
fi \
done && \
tar -cf - $$files | \
gzip --best >$$distfile && \
rm $$distname; \
else \
echo "Can't write $$distfile" >&2; \
exit 1; \
fi
# Increment the minor version number
inc:
f=build/minor-version-number && \
expr `cat $$f` + 1 >$$f.tmp && \
mv $$f.tmp $$f && \
echo '(define version-info "0.'`cat $$f`'")' \
>scheme/env/version-info.scm
# --------------------
# Generate build/filenames.make from *packages.scm
#
# This hack traces the module dependencies described in the
# various configuration files and converts them into dependency lists
# that "make" can use for its purposes.
#
# Since the distribution comes with a filenames.make, this rule
# shouldn't be invoked for simple installations. But it will be used
# if you change any of the *-packages.scm files.
#
# You can actually run the forms in filenames.scm in any Scheme
# implementation that has syntax-rules and explicit-renaming low-level
# macros (e.g., most versions of Scheme 48 and Pseudoscheme).
# If there are errors running this script, and you need to debug,
# don't use the initial.image, use something that has a reasonable
# environment.
#
# If this fails and you don't feel like debugging or fixing the problem,
# try "touch filenames.make" and hope for the best.
PACKAGES=scheme/packages.scm scheme/rts-packages.scm scheme/alt-packages.scm \
scheme/comp-packages.scm scheme/initial-packages.scm \
scheme/link-packages.scm scheme/more-packages.scm \
build/filenames.scm
build/filenames.make: $(PACKAGES)
$(MAKE) $(VM) PACKAGES=
./$(VM) -i $(srcdir)/$(INITIAL) -a batch <build/filenames.scm
# or: $(RUNNABLE) -a batch <build/filenames.scm
# --------------------
# Static linker
#
# The linker is capable of rebuilding an image from sources, even
# across an incompatible change in VM data representations.
build/linker.image: $(linker-files) scheme/alt/init-defpackage.scm
(echo ',batch'; \
echo ',bench on'; \
echo ',open signals handle features'; \
echo ',open bitwise ascii code-vectors record'; \
echo ',load $(linker-files)'; \
echo ',load scheme/alt/init-defpackage.scm'; \
echo ',dump build/linker.image' \
) | $(LINKER_RUNNABLE)
# Or, to bootstrap from Lucid Common Lisp: (last tested with
# Pseudoscheme 2.9 and Scheme 48 version 0.19)
PSEUDODIR = ../pseudo
link/linker-in-lucid: build/lucid-script.lisp $(linker-files) \
scheme/alt/pseudoscheme-features.scm \
scheme/alt/pseudoscheme-record.scm
(echo \(defvar pseudoscheme-directory \"$(PSEUDODIR)/\"\); \
cat build/lucid-script.lisp; \
echo \(dump-linker\) \(lcl:quit\)) \
| lisp
# --------------------
# Initial image
#
# The initial.image is built by the static linker. The image contains
# Scheme, the byte-code compiler, and a minimal command processor, but
# no debugging environment to speak of.
$(INITIAL): $(LINKER_IMAGE) $(CONFIG_FILES) build/initial.scm $(initial-files)
($(START_LINKER); \
echo '(load-configuration "scheme/interfaces.scm")'; \
echo '(load-configuration "scheme/packages.scm")'; \
echo '(flatload initial-structures)'; \
echo '(load "build/initial.scm")'; \
echo '(link-initial-system)' \
) | $(LINKER)
# --------------------
# Various small images for debugging low-level changes
LOAD_DEBUG = \
$(START_LINKER); \
echo \(load-configuration \"scheme/interfaces.scm\"\); \
echo \(load-configuration \"scheme/packages.scm\"\); \
echo \(flatload debug-structures\)
scheme/debug/tiny.image: $(LINKER_IMAGE) scheme/debug/tiny-packages.scm \
scheme/debug/tiny.scm
($(START_LINKER); \
echo \(load-configuration \"scheme/debug/tiny-packages.scm\"\); \
echo \(link-simple-system \'\(scheme/debug tiny\) \'start tiny-system\)) \
| $(LINKER)
scheme/debug/low-test.image: $(LINKER_IMAGE) scheme/debug/low-test-packages.scm \
scheme/debug/low-test.scm
($(START_LINKER); \
echo \(load-configuration \"scheme/debug/low-test-packages.scm\"\); \
echo \(link-simple-system \'\(scheme/debug low-test\) \'start low-test-system\)) \
| $(LINKER)
scheme/debug/little.image: $(LINKER_IMAGE) $(CONFIG_FILES) scheme/debug-packages.scm
($(LOAD_DEBUG); echo \(link-little-system\)) \
| time $(LINKER)
scheme/debug/mini.image: $(LINKER_IMAGE) $(CONFIG_FILES)
($(LOAD_DEBUG); echo \(link-mini-system\)) \
| $(LINKER)
scheme/debug/medium.image: $(LINKER_IMAGE) $(CONFIG_FILES)
($(LOAD_DEBUG); echo \(flatload compiler-structures\); \
echo \(link-medium-system\)) \
| $(LINKER)
# The following have not been updated for the new directory organization
c/smain.o: c/main.c
$(CC) -c $(CPPFLAGS) $(DEFS) $(CFLAGS) -DSTATIC_AREAS -o $@ c/main.c
mini: mini-heap.o smain.o
$(CC) $(LDFLAGS) $(CFLAGS) -o $@ c/smain.o mini-heap.o $(OBJS) $(LIBS)
mini-heap.o: mini-heap.c
$(CC) -c $(CPPFLAGS) $(DEFS) $(CFLAGS) -o $@ $(srcdir)/mini-heap.c
mini-heap.c: scheme/debug/mini1.image
(echo ,exec ,load misc/load-static.scm; \
echo \(do-it 150000 \"$(srcdir)/scheme/debug/mini1.image\" \"$@\"\)) \
| $(RUNNABLE) -h 3000000 -a batch
scheme/debug/mini1.image: $(VM) scheme/debug/mini.image
echo "(write-image \"scheme/debug/mini1.image\" \
(usual-resumer (lambda (args) \
(command-processor #f args))) \
\"foo\")" \
| ./$(VM) -i scheme/debug/mini.image -a batch
# --------------------
# Generate scheme48.h from VM sources
c/scheme48.h: c/scheme48.h.in scheme/vm/arch.scm scheme/vm/data.scm \
scheme/link/generate-c-header.scm
(echo ',bench'; \
echo ',batch'; \
echo ',load-package big-scheme'; \
echo ',open big-scheme'; \
echo ',load scheme/link/generate-c-header.scm'; \
echo "(make-c-header-file \"$@\" \
\"$(srcdir)/c/scheme48.h.in\" \
\"$(srcdir)/scheme/vm/arch.scm\" \
\"$(srcdir)/scheme/vm/data.scm\" \
\"$(srcdir)/scheme/rts/record.scm\")" \
) | $(RUNNABLE)
# An old version of the above for legacy code.
c/old-scheme48.h: scheme/vm/arch.scm scheme/vm/data.scm \
scheme/link/generate-old-c-header.scm
(echo ',bench'; \
echo ',batch'; \
echo ',load-package big-scheme'; \
echo ',open big-scheme'; \
echo ',load scheme/link/generate-old-c-header.scm'; \
echo "(make-c-header-file \"$@\" \
\"$(srcdir)/scheme/vm/arch.scm\" \
\"$(srcdir)/scheme/vm/data.scm\")" \
) | $(RUNNABLE)
# Generate vm (scheme48vm.c and scheme48heap.c) from VM sources.
# Never called automatically. Do not use unless you are sure you
# know what you are doing.
# Afterwards, you should probably make c/scheme48.h.
i-know-what-i-am-doing:
cd ps-compiler && \
(echo ',batch'; \
echo ',config ,load ../scheme/prescheme/interface.scm'; \
echo ',config ,load ../scheme/prescheme/package-defs.scm'; \
echo ',exec ,load load-ps-compiler.scm'; \
echo ',exec ,load compile-vm-no-gc.scm'; \
echo ',exec ,load compile-gc.scm'; \
echo ',exit' \
) | $(RUNNABLE) -h 8000000 && \
mv ../scheme/vm/scheme48vm.c ../scheme/vm/scheme48heap.c ../c

93
README Normal file
View File

@ -0,0 +1,93 @@
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
Please report bugs to scheme-48-bugs@martigny.ai.mit.edu, and include
the version number in your message.
Installation instructions in file INSTALL.
A user's guide is in file doc/user-guide.txt.
Recent changes are listed in file doc/news.txt.
Known bugs and things to do in the future are listed in doc/todo.txt.
Send mail to scheme-48-request@martigny.ai.mit.edu to be put on a
mailing list for announcements, discussion, bug reports, and bug
fixes.
-----
When running "make", don't worry if the ".notify" target fails. Its
only purpose is to send an email message to
scheme-48-notifications@martigny.ai.mit.edu, so that we can get a
rough idea of how much Scheme 48 is being used and by whom. We
promise not to use your name or email address for any commercial
purpose. If you don't want us to know, just do "make -t .notify"
first (after running "configure").
-----
The Scheme 48 root directory is organized as follows (not all files are
listed here):
README this file
INSTALL installation instructions
COPYING copyright notice
configure configuration script
Makefile.in input to configure
doc/ some documentation
scheme48.man a Unix-style manual page
user-guide.txt general guide to using Scheme 48
todo.txt list of improvements we hope to make someday
news.txt list of improvements we have already made
module.ps description of Scheme 48's module system
big-scheme.txt extensions to Scheme
threads.txt multiprocessing
io.txt how the I/O system works
scheme/ scheme source files
packages.scm meta-module definitions
interfaces.scm system interface definitions
more-interfaces.scm system interface definitions
*-packages.scm module definitions
bcomp/ the byte-code compiler
vm/ virtual machine sources (written in Pre-Scheme)
rts/ run-time system sources
link/ static linker
env/ development environment modules (debugger, etc.)
big/ useful Scheme libraries and extensions ("Big Scheme")
alt/ portable implementations of some Scheme 48 features
opt/ optional code optimizer for the byte-code compiler
prescheme/ code for running the VM using Scheme 48
debug/ debugging utilities, tests, etc.
misc/ very miscellaneous things (e.g. AMB operator)
posix/ unfinished interface to POSIX system calls
ps-compiler/ Pre-Scheme -> C compiler
c/ c source files
sysdep.h.in input to configure
scheme48vm.c most of the VM (generated by Pre-Scheme compiler)
scheme48vm.h extern declarations for scheme48vm.c
scheme48heap.c storage management (generated by Pre-Scheme compiler)
scheme48heap.h extern declarations for scheme48heap.c
main.c entry point for the VM
prescheme.h part of the VM
extension.c default definition of vm_extension()
scheme48.h C declarations and macros for Scheme 48 data structures
old-scheme48.h old version, included for compatibility
c-mods.h minor additions to the C language
event.h header file for OS interface
io.h ditto
fd-io.h ditto
socket.c socket support
dynamo.c dynamic loading support
unix/ Unix-specific source files
posix/ C half of an unfinished interface to POSIX system calls
fake/ C files for insufficiently POSIX-compliant systems
build/ code for building the system
filenames.make included by Makefile, generated automatically
filenames.scm code for generating filenames.make
initial.image an image file containing a minimal Scheme system
initial.debug debugging database for same
initial.scm script for creating initial.image
build-usual-image script for creating scheme48.image
build-external-modules script for creating external-module initializer
emacs/ gnu emacs support

32
acconfig.h Normal file
View File

@ -0,0 +1,32 @@
/*
* HAVE_SIGACTION is defined iff sigaction() is available.
*/
#undef HAVE_SIGACTION
/*
* HAVE_STRERROR is defined iff the standard libraries provide strerror().
*/
#undef HAVE_STRERROR
/*
* NLIST_HAS_N_NAME is defined iff a struct nlist has an n_name member.
* If it doesn't then we assume it has an n_un member which, in turn,
* has an n_name member.
*/
#undef NLIST_HAS_N_NAME
/*
* HAVE_SYS_SELECT_H is defined iff we have the include file sys/select.h.
*/
#undef HAVE_SYS_SELECT_H
/*
* USCORE is defined iff C externals are prepended with an underscore.
*/
#undef USCORE
@BOTTOM@
#include "fake/sigact.h"
#include "fake/strerror.h"
#include "fake/sys-select.h"

28
build/build-external-modules Executable file
View File

@ -0,0 +1,28 @@
#!/bin/sh
# Build external-modules.c.
target="$1"
shift
(
cat <<!
!
for i in "s48_initialize_external" "$@"; do
cat <<!
extern void $i(void);
!
done
cat <<!
void s48_initialize_external_modules (void) {
!
for i in "s48_initialize_external" "$@"; do
cat <<!
$i();
!
done
cat <<!
};
!
) >"$target"

33
build/build-usual-image Executable file
View File

@ -0,0 +1,33 @@
#!/bin/sh
# Build the usual development environment image.
date=`date`
srcdir=$1
lib=$2
image=$3
vm=$4
initial=$5
USER=${USER-`logname 2>/dev/null || echo '*GOK*'`}
$vm -i $initial -a batch <<EOF
,load $srcdir/scheme/env/init-defpackage.scm
((*structure-ref filenames 'set-translation!)
"=scheme48/" "$srcdir/scheme/")
,load =scheme48/more-interfaces.scm =scheme48/link-packages.scm
,load =scheme48/more-packages.scm
(ensure-loaded command-processor)
(ensure-loaded usual-commands)
,go ((*structure-ref command 'command-processor)
(structure-package usual-commands)
(list "batch"))
(ensure-loaded usual-features)
,structure more-structures more-structures-interface
,in debuginfo (read-debug-info "$srcdir/build/initial.debug")
,keep maps source files
,translate =scheme48/ $lib/
,build ((*structure-ref package-commands-internal
'new-command-processor)
"(made by $USER on $date)"
usual-commands
built-in-structures more-structures) $image
EOF

7
build/filenames.make Normal file
View File

@ -0,0 +1,7 @@
#### This file was generated automatically. ####
initial-files = scheme/rts/low.scm scheme/rts/signal.scm scheme/rts/base.scm scheme/rts/util.scm scheme/rts/number.scm scheme/rts/lize.scm scheme/rts/record.scm scheme/rts/jar-defrecord.scm scheme/rts/method.scm scheme/rts/numio.scm scheme/rts/fluid.scm scheme/rts/defenum.scm scheme/vm/arch.scm scheme/big/queue.scm scheme/rts/condition.scm scheme/rts/session.scm scheme/rts/interrupt.scm scheme/rts/wind.scm scheme/rts/template.scm scheme/rts/continuation.scm scheme/rts/exception.scm scheme/rts/thread.scm scheme/rts/sleep.scm scheme/rts/lock.scm scheme/rts/port.scm scheme/rts/current-port.scm scheme/rts/write.scm scheme/rts/read.scm scheme/rts/channel.scm scheme/rts/channel-port.scm scheme/rts/channel-io.scm scheme/big/general-table.scm scheme/rts/population.scm scheme/bcomp/mtype.scm scheme/bcomp/interface.scm scheme/bcomp/binding.scm scheme/bcomp/name.scm scheme/bcomp/transform.scm scheme/bcomp/cenv.scm scheme/bcomp/thingie.scm scheme/bcomp/package.scm scheme/bcomp/package-undef.scm scheme/rts/env.scm scheme/big/filename.scm scheme/bcomp/read-form.scm scheme/bcomp/node.scm scheme/bcomp/schemify.scm scheme/bcomp/var-util.scm scheme/bcomp/syntax.scm scheme/bcomp/primop.scm scheme/bcomp/ddata.scm scheme/bcomp/stack-check.scm scheme/bcomp/state.scm scheme/bcomp/segment.scm scheme/bcomp/recon.scm scheme/bcomp/comp-exp.scm scheme/bcomp/comp-prim.scm scheme/bcomp/comp.scm scheme/rts/eval.scm scheme/env/dispcond.scm scheme/debug/mini-command.scm scheme/rts/scheduler.scm scheme/rts/root-scheduler.scm scheme/rts/init.scm scheme/env/start.scm scheme/bcomp/usual.scm scheme/bcomp/rules.scm scheme/bcomp/type.scm scheme/bcomp/module-language.scm scheme/bcomp/config.scm scheme/bcomp/scan-package.scm scheme/bcomp/optimize.scm scheme/bcomp/comp-package.scm scheme/env/load-package.scm scheme/big/strong.scm scheme/opt/usage.scm scheme/opt/sort.scm scheme/opt/inline.scm scheme/bcomp/for-reify.scm
usual-files = scheme/opt/analyze.scm scheme/env/disclosers.scm scheme/env/command-level.scm scheme/env/version-info.scm scheme/env/command.scm scheme/env/read-command.scm scheme/env/debuginfo.scm scheme/rts/xnum.scm scheme/rts/bignum.scm scheme/rts/ratnum.scm scheme/rts/recnum.scm scheme/rts/innum.scm scheme/env/basic-command.scm scheme/env/build.scm scheme/env/shadow.scm scheme/env/pedit.scm scheme/env/pacman.scm scheme/rts/time.scm scheme/env/debug.scm scheme/env/inspect.scm scheme/env/disasm.scm
linker-files = scheme/rts/util.scm scheme/alt/fluid.scm scheme/rts/defenum.scm scheme/vm/arch.scm scheme/alt/jar-defrecord.scm scheme/big/general-table.scm scheme/bcomp/mtype.scm scheme/alt/locations.scm scheme/bcomp/binding.scm scheme/bcomp/name.scm scheme/bcomp/transform.scm scheme/bcomp/node.scm scheme/bcomp/schemify.scm scheme/bcomp/var-util.scm scheme/bcomp/primop.scm scheme/alt/template.scm scheme/rts/template.scm scheme/bcomp/ddata.scm scheme/bcomp/thingie.scm scheme/bcomp/stack-check.scm scheme/bcomp/state.scm scheme/bcomp/segment.scm scheme/bcomp/recon.scm scheme/bcomp/comp-exp.scm scheme/bcomp/comp-prim.scm scheme/bcomp/comp.scm scheme/alt/closure.scm scheme/link/data.scm scheme/link/transport.scm scheme/link/write-image.scm scheme/alt/weak.scm scheme/rts/population.scm scheme/bcomp/interface.scm scheme/bcomp/cenv.scm scheme/bcomp/package.scm scheme/bcomp/package-undef.scm scheme/bcomp/syntax.scm scheme/env/debuginfo.scm scheme/big/filename.scm scheme/bcomp/read-form.scm scheme/bcomp/scan-package.scm scheme/bcomp/optimize.scm scheme/bcomp/usual.scm scheme/bcomp/rules.scm scheme/bcomp/comp-package.scm scheme/big/strong.scm scheme/opt/usage.scm scheme/opt/sort.scm scheme/opt/inline.scm scheme/link/reify.scm scheme/link/link.scm scheme/alt/loophole.scm scheme/bcomp/type.scm scheme/alt/low.scm scheme/bcomp/module-language.scm scheme/bcomp/config.scm scheme/opt/analyze.scm scheme/alt/environments.scm scheme/link/loadc.scm scheme/env/flatload.scm

47
build/filenames.scm Normal file
View File

@ -0,0 +1,47 @@
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Generate filenames.make from *-packages.scm.
; Define DEFINE-STRUCTURE and friends
(for-each load
'("scheme/bcomp/module-language.scm"
"scheme/alt/config.scm"
"scheme/env/flatload.scm"))
(load-configuration "scheme/packages.scm")
; The following defines are unnecessary; they only serve to suppress
; annoying "undefined" warnings for some forward references.
(define methods 0)
(define tables 0)
(flatload linker-structures)
(define q-f (all-file-names link-config))
; (display "Initial structures") (newline)
(flatload initial-structures)
(define scheme (make-scheme environments evaluation))
(define initial-system
(structure (export)
(open ;; Cf. initial.scm
(make-initial-system scheme (make-mini-command scheme))
module-system
ensures-loaded
for-reification))) ;foo...
(define i-f (all-file-names initial-system))
; (display "Usual structures") (newline)
(flatload usual-structures)
(define u-f (all-file-names usual-features initial-system))
(write-file-names "build/filenames.make"
'initial-files i-f
'usual-files u-f
'linker-files q-f)

6351
build/initial.debug Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
build/initial.image Normal file
View File

Binary file not shown.

58
build/initial.scm Normal file
View File

@ -0,0 +1,58 @@
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Link script.
(define (link-initial-system)
(let ((structures-to-open ;Structures to open for the initial
(struct-list scheme ;system's read-eval-print loop.
environments
module-system
ensures-loaded
packages
packages-internal))) ; package-for-syntax
(link-reified-system (append (desirable-structures)
structures-to-open)
'(build initial)
;; The expression that evaluates to the
;; procedure that maps the reified-structure alist
;; to the startup procedure:
`(start ',(map car structures-to-open))
;; Structures to open for evaluating that
;; expression and the expression that
;; evaluates to the reified-structure alist:
initial-system
for-reification
;; scheme-level-1
)))
(define (desirable-structures)
(let ((env (interaction-environment))
(l '()))
(for-each (lambda (int)
(for-each-declaration
(lambda (name type)
(if (not (assq name l))
(let ((s (eval name env)))
(if (structure? s)
(set! l (cons (cons name s) l))))))
int))
(list low-structures-interface
run-time-structures-interface
features-structures-interface
run-time-internals-structures-interface
compiler-structures-interface
initial-structures-interface))
(reverse l)))
; Your choice of evaluators:
(define scheme (make-scheme environments evaluation))
; (define scheme (make-scheme mini-environments mini-eval))
; (define scheme (make-scheme environments run))
; etc.
; Your choice of command processors.
(define initial-system
(make-initial-system scheme (make-mini-command scheme)))

90
build/load-linker.exec Normal file
View File

@ -0,0 +1,90 @@
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Load the linker. -*- Mode: Scheme; -*-
; Run this script with ,exec ,load l.exec.
; After the script is loaded, you can, in principle, do whatever
; you might do in the usual linker image. For example, you might do
; (this is from the Makefile)
;
; ,in link-config
; (load-configuration "interfaces.scm")
; (load-configuration "packages.scm")
; (flatload initial-structures)
; (load "initial.scm")
; (link-initial-system)
;
; This is intended to be used to debug new versions of the compiler or
; static linker.
(config '(run (define :arguments :values))) ;temporary hack
(translate "=scheme48/" "./")
(load-package 'flatloading)
(open 'flatloading)
(define (r x) (config `(run ,x)))
(r '(define-structure source-file-names (export (%file-name% :syntax))
(open scheme-level-1
syntactic
fluids)
(begin (define-syntax %file-name%
(syntax-rules ()
((%file-name%) (fluid $source-file-name)))))))
(r '(define-structure enumerated enumerated-interface
(open scheme-level-1 signals)
(files (rts defenum scm))))
(r '(define-structure architecture architecture-interface
(open scheme-level-1 signals enumerated)
(files (rts arch))))
(config '(structure reflective-tower-maker
(export-reflective-tower-maker)))
; Make the new linker obtain its table, record, etc. structures from
; the currently running Scheme.
(config '(load "packages.scm"))
(config '(structure %run-time-structures run-time-structures-interface))
(config '(structure %features-structures features-structures-interface))
(r
'(define-structure %linker-structures
(make-linker-structures %run-time-structures
%features-structures
(make-compiler-structures %run-time-structures
%features-structures))))
; Load the linker's interface and structure definitions.
(config '(load "interfaces.scm" "more-interfaces.scm"))
(let ((z (config '(run %linker-structures)))
(env (config interaction-environment)))
(config (lambda () (flatload z env))))
; Load the linker.
(load-package 'link-config)
; Initialize
(in 'link-config
'(open scheme packages packages-internal
reflective-tower-maker))
(in 'linker '(run (set! *debug-linker?* #t)))
(in 'link-config '(open flatloading)) ; A different one.
; ,open debuginfo packages-internal compiler scan syntactic meta-types
; (in 'link-config '(dump "l.image"))
; ,exec (usual-stuff)
(define (usual-stuff)
(in 'link-config)
(run '(begin (load-configuration "interfaces.scm")
(load-configuration "packages.scm")
(flatload initial-structures)))
(load "initial.scm"))

82
build/lucid-script.lisp Normal file
View File

@ -0,0 +1,82 @@
; Script to load the Scheme 48 linker into Common Lisp.
; Requires Pseudoscheme 2.11.
(defvar pseudoscheme-directory "../pseudo/")
(load (concatenate 'string pseudoscheme-directory "loadit.lisp"))
; or perhaps (load (merge-pathnames "loadit.lisp" pseudoscheme-directory))
(load-pseudoscheme pseudoscheme-directory)
(progn (revised^4-scheme::define-sharp-macro #\.
#'(lambda (c port)
(read-char port)
(eval (let ((*readtable* ps::scheme-readtable))
(read port)))))
(values))
(ps:scheme)
;--------------------
; Scheme forms
(benchmark-mode)
(define config-env ; (interaction-environment) would also work here.
(#.'scheme-translator:make-program-env
'%config
(list #.'scheme-translator:revised^4-scheme-structure)))
(load "bcomp/module-language" config-env)
(load "alt/config" config-env)
(load "env/flatload" config-env)
(eval '(set! *load-file-type* #f) config-env)
(define load-config
(let ((load-config (eval 'load-configuration config-env)))
(lambda (filename)
(load-config filename config-env))))
(load-config "packages")
(define flatload-package (eval 'flatload config-env))
(flatload-package (eval 'linker-structures config-env) config-env)
(let ((#.'clever-load:*compile-if-necessary-p* #t))
(let ((#.'ps:*scheme-read* #.'#'ps::scheme-read-using-commonlisp-reader))
(load "alt/pseudoscheme-record")
(load "alt/pseudoscheme-features")))
(let ((#.'clever-load:*compile-if-necessary-p* #t))
(flatload-package (eval 'link-config config-env)))
(load "alt/init-defpackage.scm")
(define-syntax struct-list ;not in link.sbin
(syntax-rules ()
((struct-list ?name ...) (list (cons '?name ?name) ...))))
;--------------------
(quit)
#+Lucid
(defun disksave-restart-function ()
(format t "~&Scheme 48 linker.~2%")
;; (hax:init-interrupt-delivery) - for threads
(ps:scheme)
(terpri))
#+Lucid
(defun dump-linker ()
(lcl:disksave "link/linker-in-lucid" :gc t :full-gc t :verbose t
:restart-function #'disksave-restart-function))
;(dump-linker)
;(lcl:quit)
; Debugging hacks
;(defun enable-lisp-packages ()
; (setq *readtable* ps:scheme-readtable)
; (values))
;(defun disable-lisp-packages ()
; (setq *readtable* ps::roadblock-readtable)
; (values))

1
build/minor-version-number Normal file
View File

@ -0,0 +1 @@
53

4
c/c-mods.h Normal file
View File

@ -0,0 +1,4 @@
#define TRUE (0 == 0)
#define FALSE (0 == 1)
#define bool char /* boolean type */

33
c/event.h Normal file
View File

@ -0,0 +1,33 @@
enum event_enum { KEYBOARD_INTERRUPT_EVENT, IO_COMPLETION_EVENT, ALARM_EVENT,
OS_SIGNAL_EVENT, ERROR_EVENT, NO_EVENT };
extern bool s48_add_pending_fd(int fd, bool is_input);
extern bool s48_remove_fd(int fd);
extern long s48_schedule_alarm_interrupt(long delta);
extern void s48_start_alarm_interrupts(void);
extern void s48_stop_alarm_interrupts(void);
extern long s48_run_time(long *mseconds);
extern long s48_real_time(long *mseconds);
extern int s48_wait_for_event(long max_wait, bool is_minutes);
extern int s48_get_next_event(long *ready_fd, long *status);
/* these are here only for the CHEAP_TIME() macro */
#define TICKS_PER_SECOND 1000 /* clock resolution */
#define POLLS_PER_SECOND 20 /* how often we poll */
#define TICKS_PER_POLL (TICKS_PER_SECOND / POLLS_PER_SECOND)
extern long s48_current_time;
#define CHEAP_TIME() (s48_current_time * TICKS_PER_POLL)
/*
* Fix (HCC) NOTE_EVENT so that it will act like a single
* statement.
*/
#define NOTE_EVENT \
do { \
s48_Spending_eventsPS = 1; \
s48_Spending_interruptPS = 1; \
} while (0)

236
c/extension.c Normal file
View File

@ -0,0 +1,236 @@
/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
See file COPYING. */
/* Implementation of the vm-extension opcode. This is completely
optional; nothing in the standard system uses these features.
If you have ANSI C but not POSIX support, try compiling with -DPOSIX=0.
The vm-extension opcode is being phased out. New code should use the
external-call opcode to call C procedures.
floating point: POSIX.1, ANSI C (should we be linking with -lM or -lm?)
sprintf: POSIX.1, ANSI C
atof: POSIX.1, ANSI C
*/
#ifndef POSIX
# define POSIX 2
#endif
#include <stdio.h>
#include "sysdep.h"
#include "scheme48.h"
#include <string.h>
#include <stdlib.h>
#include <math.h>
#include <signal.h>
#include <unistd.h> /* setuid & setgid */
#include <errno.h>
#include <netdb.h> /* gethostbyname */ /* Kali code */
#include <sys/types.h>
#include <sys/wait.h>
#define GREATEST_FIXNUM_VALUE ((1 << 29) - 1)
#define LEAST_FIXNUM_VALUE (-1 << 29)
#define CHANNEL_INDEX(x) EXTRACT_FIXNUM(STOB_REF(x, 1))
#define FOR_INPUT 1
#define FOR_OUTPUT 2
typedef struct {
char b[sizeof(double)];
} unaligned_double;
typedef union {
double f;
unaligned_double b;
} float_or_bytes;
extern long s48_Sextension_valueS; /* how values are returned */
/* return status values */
#define EXT_ST_OKAY 0
#define EXT_ST_EXCEPTION 1
#define EXT_RETURN(value) {s48_Sextension_valueS = (value); return EXT_ST_OKAY; }
#define EXT_EXCEPTION return EXT_ST_EXCEPTION
/******************************************/
s48_value
s48_extended_vm (long key, s48_value value)
{
double x, y;
switch (key) {
/* Cases 0 through 19 are reserved for the mobot system. */
case 0: /* read jumpers on 68000 board */
EXT_RETURN(S48_UNSAFE_ENTER_FIXNUM(0));
/* Floating point */
#define FLOP 100
#define FLOP2(i) case FLOP+(i): \
if (!S48_STOB_P(value) || S48_STOB_DESCRIPTOR_LENGTH(value) != 2) \
EXT_EXCEPTION;
#define FLOP3(i) case FLOP+(i): \
if (!S48_STOB_P(value) || S48_STOB_DESCRIPTOR_LENGTH(value) != 3) \
EXT_EXCEPTION;
#define get_arg(args,i) S48_STOB_REF(args,(i))
#define get_string_arg(args,i) (S48_UNSAFE_EXTRACT_STRING(get_arg(args,i)))
#define get_float_arg(args, i, var) EXTRACT_FLOAT(get_arg(args, i), var)
#define set_float_arg(args, i, val) SET_FLOAT(get_arg(args, i), val)
#define EXTRACT_FLOAT(stob, var) \
{ s48_value temp_ = (stob); \
float_or_bytes loser_; \
if (!S48_STOB_P(temp_)) EXT_EXCEPTION; \
loser_.b = *(unaligned_double*)(&S48_STOB_REF(temp_, 0)); \
(var) = loser_.f; }
#define SET_FLOAT(stob, val) \
{ s48_value temp_ = (stob); \
float_or_bytes loser_; \
if (!S48_STOB_P(temp_)) EXT_EXCEPTION; \
loser_.f = (double)(val); \
*(unaligned_double*)(&S48_STOB_REF(temp_, 0)) = loser_.b; }
FLOP3(0) {
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
set_float_arg(value, 2, x + y);
EXT_RETURN(S48_UNSPECIFIC);}
FLOP3(1) {
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
set_float_arg(value, 2, x - y);
EXT_RETURN(S48_UNSPECIFIC);}
FLOP3(2) {
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
set_float_arg(value, 2, x * y);
EXT_RETURN(S48_UNSPECIFIC);}
FLOP3(3) {
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
if (y == 0.0) EXT_EXCEPTION;
set_float_arg(value, 2, x / y);
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(4) {
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
EXT_RETURN(S48_ENTER_BOOLEAN(x == y));}
FLOP2(5) {
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
EXT_RETURN(S48_ENTER_BOOLEAN(x < y));}
FLOP2(6) { /* fixnum->float */
s48_value arg = get_arg(value, 0);
if (!S48_FIXNUM_P(arg)) EXT_RETURN(S48_FALSE);
set_float_arg(value, 1, S48_UNSAFE_EXTRACT_FIXNUM(arg));
EXT_RETURN(S48_TRUE);}
FLOP2(7) { /* string->float */
char *str = get_string_arg(value, 0);
set_float_arg(value, 1, atof(str));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(8) { /* float->string */
size_t len;
char *str = get_string_arg(value,1);
get_float_arg(value, 0, x);
sprintf(str, "%g", x);
len = strlen(str);
if (len > S48_UNSAFE_STRING_LENGTH(get_arg(value,1)))
/* unlikely but catastrophic */
fprintf(stderr, "printing float: output too long: %s\n",
str);
EXT_RETURN(S48_UNSAFE_ENTER_FIXNUM(len));}
/* exp log sin cos tan asin acos atan sqrt */
FLOP2(9) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, exp(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(10) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, log(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(11) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, sin(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(12) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, cos(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(13) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, tan(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(14) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, asin(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(15) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, acos(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP3(16) { /* atan */
get_float_arg(value, 0, y);
get_float_arg(value, 1, x);
set_float_arg(value, 2, atan2(y, x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(17) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, sqrt(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(18) { /* floor */
get_float_arg(value, 0, x);
set_float_arg(value, 1, floor(x));
EXT_RETURN(S48_UNSPECIFIC);}
case FLOP+19: { /* integer? */
EXTRACT_FLOAT(value, x);
EXT_RETURN(S48_ENTER_BOOLEAN(fmod(x, 1.0) == 0.0)); }
case FLOP+20: { /* float->fixnum */
EXTRACT_FLOAT(value, x);
if (x <= (double)GREATEST_FIXNUM_VALUE
&& x >= (double)LEAST_FIXNUM_VALUE)
{
EXT_RETURN(S48_UNSAFE_ENTER_FIXNUM((long)x)); }
else
EXT_RETURN(S48_FALSE);}
FLOP3(21) { /* quotient */
double z;
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
if (fmod(x, 1.0) != 0.0 || fmod(y, 1.0) != 0.0) EXT_EXCEPTION;
if (y == 0.0) EXT_EXCEPTION;
z = x / y;
set_float_arg(value, 2, z < 0.0 ? ceil(z) : floor(z));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP3(22) { /* remainder */
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
if (fmod(x, 1.0) != 0.0 || fmod(y, 1.0) != 0.0) EXT_EXCEPTION;
if (y == 0.0) EXT_EXCEPTION;
/* "fmod(double x, double y) returns the floating-point remainder
(f) of the division of x by y, where f has the same sign as x,
such that x=iy+f for some integer i, and |f| < |y|." */
set_float_arg(value, 2, fmod(x, y));
EXT_RETURN(S48_UNSPECIFIC);}
default:
EXT_EXCEPTION;
}
}

947
c/external.c Normal file
View File

@ -0,0 +1,947 @@
/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
See file COPYING. */
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <setjmp.h>
#include <stdarg.h>
#include "c-mods.h"
#include "scheme48.h"
#include "scheme48vm.h"
/*
* The Joy of C
* I don't understand why we need this, but we do.
*/
struct s_jmp_buf {
jmp_buf buf;
};
/*
* Longjump target set up by the most recent call into C.
*/
static struct s_jmp_buf current_return_point;
/*
* The name of the procedure we are currently executing; used for error messages.
*/
static s48_value current_procedure;
/*
* Stack of Scheme stack-block records which represent portions of the process
* stack.
*/
static s48_value current_stack_block = S48_FALSE;
/*
* These need to agree with the record definition in callback.scm.
*/
#define STACK_BLOCK_FREE(stack_block) S48_UNSAFE_RECORD_REF(stack_block, 0)
#define STACK_BLOCK_UNWIND(stack_block) S48_UNSAFE_RECORD_REF(stack_block, 1)
#define STACK_BLOCK_PROC(stack_block) S48_UNSAFE_RECORD_REF(stack_block, 2)
#define STACK_BLOCK_THREAD(stack_block) S48_UNSAFE_RECORD_REF(stack_block, 3)
#define STACK_BLOCK_NEXT(stack_block) S48_UNSAFE_RECORD_REF(stack_block, 4)
/*
* For debugging.
*/
/*
static int callback_depth()
{
int depth = 0;
s48_value stack = current_stack_block;
for(; stack != S48_FALSE; depth++, stack = STACK_BLOCK_NEXT(stack));
return depth;
}
*/
/*
* The value being returned from an external call. The returns may be preceded
* by a longjmp(), so we stash the value here.
*/
static s48_value external_return_value;
/* Exports to Scheme */
static s48_value s48_clear_stack_top(void);
static s48_value s48_trampoline(s48_value proc, s48_value nargs);
/* Imports from Scheme */
static s48_value the_record_type_binding = S48_FALSE;
static s48_value stack_block_type_binding = S48_FALSE;
static s48_value callback_binding = S48_FALSE;
static s48_value delay_callback_return_binding = S48_FALSE;
static s48_value bignum_to_long_binding = S48_FALSE;
static s48_value long_to_bignum_binding = S48_FALSE;
void
s48_initialize_external()
{
S48_GC_PROTECT_GLOBAL(the_record_type_binding);
the_record_type_binding = s48_get_imported_binding("s48-the-record-type");
S48_GC_PROTECT_GLOBAL(stack_block_type_binding);
stack_block_type_binding = s48_get_imported_binding("s48-stack-block-type");
S48_GC_PROTECT_GLOBAL(callback_binding);
callback_binding = s48_get_imported_binding("s48-callback");
S48_GC_PROTECT_GLOBAL(delay_callback_return_binding);
delay_callback_return_binding =
s48_get_imported_binding("s48-delay-callback-return");
S48_GC_PROTECT_GLOBAL(bignum_to_long_binding);
bignum_to_long_binding = s48_get_imported_binding("s48-bignum-to-long");
S48_GC_PROTECT_GLOBAL(long_to_bignum_binding);
long_to_bignum_binding = s48_get_imported_binding("s48-long-to-bignum");
S48_GC_PROTECT_GLOBAL(current_stack_block);
S48_GC_PROTECT_GLOBAL(current_procedure);
S48_EXPORT_FUNCTION(s48_clear_stack_top);
S48_EXPORT_FUNCTION(s48_trampoline);
}
/* The three reasons for an extern-call longjump. */
#define NO_THROW 0
#define EXCEPTION_THROW 1
#define CLEANUP_THROW 2
/*
* Used to call `proc' from Scheme code. `nargs' the number of arguments in
* vector `argv'. If `spread_p' is true the procedure is applied to the
* arguments, otherwise `proc' is just called on `nargs' and `argv'.
*
* We do a setjmp() to get a return point for clearing off this portion of
* the process stack. This is used when `proc' calls back to Scheme and
* then a throw transfers control up past the call to `proc'.
*/
s48_value
s48_external_call(s48_value sch_proc, s48_value proc_name,
long nargs, char *char_argv)
{
volatile char *gc_roots_marker; /* volatile to survive longjumps */
volatile s48_value name = proc_name; /* volatile to survive longjumps */
/* int depth = callback_depth(); */ /* debugging */
long *argv = (long *) char_argv;
s48_value (*proc)() = (s48_value (*)())
*S48_EXTRACT_VALUE_POINTER(sch_proc, long);
int throw_reason;
current_procedure = name;
S48_CHECK_VALUE(sch_proc);
S48_CHECK_STRING(name);
gc_roots_marker = s48_set_gc_roots_baseB();
/* fprintf(stderr, "[external_call at depth %d]\n", depth); */
throw_reason = setjmp(current_return_point.buf);
if (throw_reason == NO_THROW) { /* initial entry */
switch (nargs) {
case 0:
external_return_value = proc();
break;
case 1:
external_return_value = proc(argv[0]);
break;
case 2:
external_return_value = proc(argv[1], argv[0]);
break;
case 3:
external_return_value = proc(argv[2], argv[1], argv[0]);
break;
case 4:
external_return_value = proc(argv[3], argv[2], argv[1], argv[0]);
break;
case 5:
external_return_value = proc(argv[4],
argv[3], argv[2], argv[1], argv[0]);
break;
case 6:
external_return_value = proc(argv[5], argv[4],
argv[3], argv[2], argv[1], argv[0]);
break;
case 7:
external_return_value = proc(argv[6], argv[5], argv[4],
argv[3], argv[2], argv[1], argv[0]);
break;
case 8:
external_return_value = proc(argv[7], argv[6], argv[5], argv[4],
argv[3], argv[2], argv[1], argv[0]);
break;
case 9:
external_return_value = proc(argv[8],
argv[7], argv[6], argv[5], argv[4],
argv[3], argv[2], argv[1], argv[0]);
break;
case 10:
external_return_value = proc(argv[9], argv[8],
argv[7], argv[6], argv[5], argv[4],
argv[3], argv[2], argv[1], argv[0]);
break;
case 11:
external_return_value = proc(argv[10], argv[9], argv[8],
argv[7], argv[6], argv[5], argv[4],
argv[3], argv[2], argv[1], argv[0]);
break;
case 12:
external_return_value = proc(argv[11], argv[10], argv[9], argv[8],
argv[7], argv[6], argv[5], argv[4],
argv[3], argv[2], argv[1], argv[0]);
break;
default:
fprintf(stderr, "external-apply called with too many arguments");
exit(-1); }
/* Raise an exception if the user neglected to pop off some gc roots. */
if (! s48_release_gc_roots_baseB((char *)gc_roots_marker)) {
s48_raise_scheme_exception(S48_EXCEPTION_GC_PROTECTION_MISMATCH, 0);
}
/* Clear any free stack-blocks off of the top of the stack-block stack and
then longjmp past the corresponding portions of the process stack. */
if (current_stack_block != S48_FALSE &&
STACK_BLOCK_FREE(current_stack_block) == S48_TRUE) {
s48_value bottom_free_block;
do {
bottom_free_block = current_stack_block;
current_stack_block = STACK_BLOCK_NEXT(current_stack_block);
}
while (current_stack_block != S48_FALSE &&
STACK_BLOCK_FREE(current_stack_block) == S48_TRUE);
/* fprintf(stderr, "[Freeing stack blocks from %d to %d]\n",
depth,
callback_depth()); */
longjmp(S48_EXTRACT_VALUE_POINTER(STACK_BLOCK_UNWIND(bottom_free_block),
struct s_jmp_buf)->buf,
CLEANUP_THROW);
}
}
else { /* throwing an exception or uwinding the stack */
/* fprintf(stderr, "[external_call throw; was %d and now %d]\n",
depth,
callback_depth());
fprintf(stderr, "[throw unrolling to %ld]\n", gc_roots_marker); */
s48_release_gc_roots_baseB((char *)gc_roots_marker);
}
/* Check to see if a thread is waiting to return to the next block down. */
if (current_stack_block != S48_FALSE &&
STACK_BLOCK_THREAD(current_stack_block) != S48_FALSE) {
/* fprintf(stderr, "[releasing return at %d]\n", callback_depth()); */
if (throw_reason == EXCEPTION_THROW) {
/* We are in the midst of raising an exception, so we need to piggyback
our exception on that one. */
s48_value old_exception
= s48_resetup_external_exception(S48_EXCEPTION_CALLBACK_RETURN_UNCOVERED,
2);
s48_push(old_exception);
s48_push(current_stack_block);
external_return_value = S48_UNSPECIFIC;
}
else {
s48_setup_external_exception(S48_EXCEPTION_CALLBACK_RETURN_UNCOVERED, 2);
s48_push(current_stack_block);
s48_push(external_return_value);
external_return_value = S48_UNSPECIFIC;
}
}
return external_return_value;
}
/*
* Call Scheme function `proc' from C. We push the call-back depth, `proc',
* and the arguments on the Scheme stack and then restart the VM. The restarted
* VM calls the Scheme procedure `callback' which wraps the call to `proc' with
* a dynamic-wind. This prevents downward throws back into the call to `proc',
* which C can't handle, and allows the C stack to be cleaned up if an upward
* throw occurs.
*
* The maximum number of arguments is determined by the amount of space reserved
* on the Scheme stack for exceptions. See the definition of stack-slack in
* scheme/vm/stack.scm.
*/
s48_value
s48_call_scheme(s48_value proc, long nargs, ...)
{
int i;
va_list arguments;
s48_value value;
s48_value unwind, stack_block;
S48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2(unwind, proc);
va_start(arguments, nargs);
S48_SHARED_BINDING_CHECK(callback_binding);
/* It would be nice to push a list of the arguments, but we have no way
of preserving them across a cons. */
if (nargs < 0 || 10 < nargs) { /* DO NOT INCREASE THIS NUMBER */
s48_value sch_nargs = s48_enter_integer(nargs); /* `proc' is protected */
s48_raise_scheme_exception(S48_EXCEPTION_TOO_MANY_ARGUMENTS_IN_CALLBACK,
2, proc, sch_nargs);
}
/* fprintf(stderr, "[s48_call, %ld args, depth %d]\n",
nargs, callback_depth()); */
s48_push(S48_UNSPECIFIC); /* placeholder */
s48_push(proc);
for (i = 0; i < nargs; i++)
s48_push(va_arg(arguments, s48_value));
va_end(arguments);
/* With everything safely on the stack we can do the necessary allocation. */
unwind = S48_MAKE_VALUE(struct s_jmp_buf);
S48_EXTRACT_VALUE(unwind, struct s_jmp_buf) = current_return_point;
stack_block = s48_make_record(stack_block_type_binding);
STACK_BLOCK_UNWIND(stack_block) = unwind;
STACK_BLOCK_PROC(stack_block) = current_procedure;
STACK_BLOCK_NEXT(stack_block) = current_stack_block;
STACK_BLOCK_FREE(stack_block) = S48_FALSE;
STACK_BLOCK_THREAD(stack_block) = S48_FALSE;
S48_GC_UNPROTECT(); /* no more references to `unwind' or `proc'. */
current_stack_block = stack_block;
/* if(s48_stack_ref(nargs + 1) != S48_UNSPECIFIC)
fprintf(stderr, "[stack_block set missed]\n"); */
s48_stack_setB(nargs + 1, stack_block);
/* fprintf(stderr, "[s48_call, %ld args, depth %d, off we go]\n",
nargs, callback_depth()); */
value = s48_restart(S48_UNSAFE_SHARED_BINDING_REF(callback_binding),
nargs + 2);
for (;s48_Scallback_return_stack_blockS != current_stack_block;) {
if (s48_Scallback_return_stack_blockS == S48_FALSE) {
/* fprintf(stderr, "[s48_call returning from VM %ld]\n", callback_depth()); */
exit(value);
}
else {
/* Someone has returned (because of threads) to the wrong section of the
C stack. We call back to a Scheme procedure that will suspend until
out block is at the top of the stack. */
s48_push(s48_Scallback_return_stack_blockS);
s48_push(S48_UNSAFE_SHARED_BINDING_REF(delay_callback_return_binding));
s48_push(s48_Scallback_return_stack_blockS);
s48_push(value);
/* fprintf(stderr, "[Premature return, %ld args, depth %d, back we go]\n",
nargs, callback_depth()); */
s48_disable_interruptsB();
value = s48_restart(S48_UNSAFE_SHARED_BINDING_REF(callback_binding), 4);
}
}
/* Restore the state of the current stack block. */
unwind = STACK_BLOCK_UNWIND(current_stack_block);
current_return_point = S48_EXTRACT_VALUE(unwind, struct s_jmp_buf);
current_procedure = STACK_BLOCK_PROC(current_stack_block);
current_stack_block = STACK_BLOCK_NEXT(current_stack_block);
/* fprintf(stderr, "[s48_call returns from depth %d]\n", callback_depth()); */
return value;
}
/*
* Because the top of the stack is cleared on the return from every external
* call, this doesn't have to do anything but exist.
*/
static s48_value
s48_clear_stack_top()
{
/* fprintf(stderr, "[Clearing stack top]\n"); */
return S48_UNSPECIFIC;
}
/*
* For testing callbacks. This just calls its argument on the specified number
* of values.
*/
static s48_value
s48_trampoline(s48_value proc, s48_value nargs)
{
fprintf(stderr, "[C trampoline, %ld args]\n", S48_UNSAFE_EXTRACT_FIXNUM(nargs));
switch (s48_extract_fixnum(nargs)) {
case -2: {
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(proc);
return S48_FALSE;
}
case -1: {
long n = - s48_extract_integer(proc);
fprintf(stderr, "[extract magnitude is %ld (%lx)]\n", n, n);
return s48_enter_integer(n);
}
case 0: {
s48_value value = s48_call_scheme(proc, 0);
if (value == S48_FALSE)
s48_raise_string_os_error("trampoline bouncing");
return value;
}
case 1:
return s48_call_scheme(proc, 1, s48_enter_fixnum(100));
case 2:
return s48_call_scheme(proc, 2, s48_enter_fixnum(100), s48_enter_fixnum(200));
case 3:
return s48_call_scheme(proc, 3, s48_enter_fixnum(100), s48_enter_fixnum(200),
s48_enter_fixnum(300));
default:
s48_raise_range_error(nargs, s48_enter_fixnum(0), s48_enter_fixnum(3));
return S48_UNDEFINED; /* not that we ever get here */
}
}
/********************************/
/*
* Raising exceptions. We push the arguments on the stack end then throw out
* of the most recent call from Scheme.
*
* The maximum number of arguments is determined by the amount of space reserved
* on the Scheme stack for exceptions. See the definition of stack-slack in
* scheme/vm/stack.scm.
*/
void
s48_raise_scheme_exception(long why, long nargs, ...)
{
int i;
va_list irritants;
va_start(irritants, nargs);
s48_setup_external_exception(why, nargs + 1);
if (10 < nargs) { /* DO NOT INCREASE THIS NUMBER */
fprintf(stderr, "s48_raise_scheme_exception() called with more than 10 arguments, discarding surplus\n");
nargs = 10;
}
s48_push(current_procedure);
for (i = 0; i < nargs; i++)
s48_push(va_arg(irritants, s48_value));
va_end(irritants);
external_return_value = S48_UNSPECIFIC;
longjmp(current_return_point.buf, EXCEPTION_THROW);
}
/* Specific exceptions */
void
s48_raise_argtype_error(s48_value value) {
s48_raise_scheme_exception(S48_EXCEPTION_WRONG_TYPE_ARGUMENT, 1, value);
}
void
s48_raise_argnumber_error(s48_value value, s48_value min, s48_value max) {
s48_raise_scheme_exception(S48_EXCEPTION_WRONG_NUMBER_OF_ARGUMENTS,
3, value, min, max);
}
void
s48_raise_range_error(s48_value value, s48_value min, s48_value max) {
s48_raise_scheme_exception(S48_EXCEPTION_INDEX_OUT_OF_RANGE,
3, value, min, max);
}
void
s48_raise_closed_channel_error() {
s48_raise_scheme_exception(S48_EXCEPTION_CLOSED_CHANNEL, 0);
}
void
s48_raise_os_error(int the_errno) {
s48_raise_scheme_exception(S48_EXCEPTION_OS_ERROR, 2,
s48_enter_fixnum(the_errno),
s48_enter_string(strerror(the_errno)));
}
void
s48_raise_string_os_error(char *reason) {
s48_raise_scheme_exception(S48_EXCEPTION_OS_ERROR, 1,
s48_enter_string(reason));
}
void
s48_raise_out_of_memory_error() {
s48_raise_scheme_exception(S48_EXCEPTION_OUT_OF_MEMORY, 0);
}
/********************************/
/* Support routines for external code */
/*
* Type-safe procedures for checking types and dereferencing and setting slots.
*/
int
s48_stob_has_type(s48_value thing, int type)
{
return S48_STOB_P(thing) && (S48_STOB_TYPE(thing) == type);
}
long
s48_stob_length(s48_value thing, int type)
{
if (!(S48_STOB_P(thing) && (S48_STOB_TYPE(thing) == type)))
s48_raise_argtype_error(thing);
return S48_STOB_DESCRIPTOR_LENGTH(thing);
}
long
s48_stob_byte_length(s48_value thing, int type)
{
if (!(S48_STOB_P(thing) && (S48_STOB_TYPE(thing) == type)))
s48_raise_argtype_error(thing);
if (type == S48_STOBTYPE_STRING)
return S48_STOB_BYTE_LENGTH(thing) - 1;
else
return S48_STOB_BYTE_LENGTH(thing);
}
s48_value
s48_stob_ref(s48_value thing, int type, long offset)
{
long length;
if (!(S48_STOB_P(thing) && (S48_STOB_TYPE(thing) == type)))
s48_raise_argtype_error(thing);
length = S48_STOB_DESCRIPTOR_LENGTH(thing);
if (offset < 0 || length <= offset)
s48_raise_range_error(s48_enter_integer(offset),
S48_UNSAFE_ENTER_FIXNUM(0),
S48_UNSAFE_ENTER_FIXNUM(length - 1));
return S48_STOB_REF(thing, offset);
}
void
s48_stob_set(s48_value thing, int type, long offset, s48_value value)
{
long length;
if (!(S48_STOB_P(thing) &&
(S48_STOB_TYPE(thing) == type) &&
!S48_STOB_IMMUTABLEP(thing)))
s48_raise_argtype_error(thing);
length = S48_STOB_DESCRIPTOR_LENGTH(thing);
if (offset < 0 || length <= offset)
s48_raise_range_error(s48_enter_integer(offset),
S48_UNSAFE_ENTER_FIXNUM(0),
S48_UNSAFE_ENTER_FIXNUM(length - 1));
S48_STOB_SET(thing, offset, value);
}
char
s48_byte_ref(s48_value thing, int type, long offset)
{
long length;
if (!(S48_STOB_P(thing) && (S48_STOB_TYPE(thing) == type)))
s48_raise_argtype_error(thing);
length = (type == S48_STOBTYPE_STRING) ?
S48_STOB_BYTE_LENGTH(thing) - 1 :
S48_STOB_BYTE_LENGTH(thing);
if (offset < 0 || length <= offset)
s48_raise_range_error(s48_enter_integer(offset),
S48_UNSAFE_ENTER_FIXNUM(0),
S48_UNSAFE_ENTER_FIXNUM(length - 1));
return S48_STOB_BYTE_REF(thing, offset);
}
void
s48_byte_set(s48_value thing, int type, long offset, char value)
{
long length;
if (!(S48_STOB_P(thing) && (S48_STOB_TYPE(thing) == type)))
s48_raise_argtype_error(thing);
length = (type == S48_STOBTYPE_STRING) ?
S48_STOB_BYTE_LENGTH(thing) - 1 :
S48_STOB_BYTE_LENGTH(thing);
if (offset < 0 || length <= offset)
s48_raise_range_error(s48_enter_integer(offset),
S48_UNSAFE_ENTER_FIXNUM(0),
S48_UNSAFE_ENTER_FIXNUM(length - 1));
S48_STOB_BYTE_SET(thing, offset, value);
}
void *
s48_value_pointer(s48_value value)
{
S48_CHECK_VALUE(value);
return S48_ADDRESS_AFTER_HEADER(value, void *);
}
/********************************/
/* Numbers, characters, and pointers. */
/*
* These two functions have the same range as the unsafe macros, but they signal
* an error if things go wrong, instead of silently producing garbage. Unlike
* the integer versions they cannot cause a GC.
*/
s48_value
s48_enter_fixnum(long value)
{
if (value < S48_MIN_FIXNUM_VALUE || S48_MAX_FIXNUM_VALUE < value)
s48_raise_argtype_error(s48_enter_integer(value));
return S48_UNSAFE_ENTER_FIXNUM(value);
}
long
s48_extract_fixnum(s48_value value)
{
if (! S48_FIXNUM_P(value))
s48_raise_argtype_error(value);
return S48_UNSAFE_EXTRACT_FIXNUM(value);
}
/*
* If `value' fits in a fixnum we put it there. Larger values are passed to the
* Scheme procedure LONG-TO-BIGNUM as the sign and the two sixteen-bit halves of
* the negative magnitude. Using the negative magnitude avoids problems with
* two's complement's asymmetry.
*/
s48_value
s48_enter_integer(long value)
{
if (S48_MIN_FIXNUM_VALUE <= value && value <= S48_MAX_FIXNUM_VALUE)
return S48_UNSAFE_ENTER_FIXNUM(value);
else {
S48_SHARED_BINDING_CHECK(long_to_bignum_binding);
if (value < 0)
return s48_call_scheme(S48_SHARED_BINDING_REF(long_to_bignum_binding),
3,
S48_FALSE,
S48_UNSAFE_ENTER_FIXNUM(value >> 16),
S48_UNSAFE_ENTER_FIXNUM(value & 0xFFFF));
else
return s48_call_scheme(S48_SHARED_BINDING_REF(long_to_bignum_binding),
3,
S48_TRUE,
S48_UNSAFE_ENTER_FIXNUM((- value) >> 16),
S48_UNSAFE_ENTER_FIXNUM((- value) & 0xFFFF));
}
}
/*
* If we have a fixnum we just extract it. Bignums require a call back into
* Scheme 48. (BIGNUM-TO-LONG n) returns a vector containing the sign and the
* high and low sixteen-bit halves of N. If N is not an integer we get #f back.
* Again, we use negative numbers to stay out of trouble.
*/
long
s48_extract_integer(s48_value value)
{
if (S48_FIXNUM_P(value))
return S48_UNSAFE_EXTRACT_FIXNUM(value);
else {
s48_value stuff;
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(value);
S48_SHARED_BINDING_CHECK(bignum_to_long_binding);
stuff = s48_call_scheme(S48_SHARED_BINDING_REF(bignum_to_long_binding),
1,
value);
S48_GC_UNPROTECT();
if (stuff == S48_FALSE)
s48_raise_argtype_error(value);
/* The first VECTOR_REF does the type checking for the rest. */
{
long low = S48_UNSAFE_EXTRACT_FIXNUM(S48_VECTOR_REF(stuff, 2));
s48_value boxed_high = S48_UNSAFE_VECTOR_REF(stuff, 1);
long high = S48_UNSAFE_EXTRACT_FIXNUM(boxed_high);
int pos_p = S48_EXTRACT_BOOLEAN(S48_UNSAFE_VECTOR_REF(stuff, 0));
if ((! S48_FIXNUM_P(boxed_high)) ||
high > (pos_p ? 0x7FFF : 0x8000))
s48_raise_argtype_error(value);
{
long magnitude = ((- high) << 16) - low;
return pos_p ? - magnitude : magnitude;
}
}
}
}
/*
* Doubles and characters are straightforward.
*/
s48_value
s48_enter_double(double value)
{
s48_value obj;
obj = s48_allocate_stob(S48_STOBTYPE_DOUBLE, sizeof(double));
S48_UNSAFE_EXTRACT_DOUBLE(obj) = value;
return obj;
}
double
s48_extract_double(s48_value s48_double)
{
if (! S48_DOUBLE_P(s48_double))
s48_raise_argtype_error(s48_double);
return S48_UNSAFE_EXTRACT_DOUBLE(s48_double);
}
s48_value
s48_enter_char(unsigned char a_char)
{
if (a_char > 255)
s48_raise_range_error(s48_enter_fixnum(a_char),
s48_enter_fixnum(0),
s48_enter_fixnum(255));
return S48_UNSAFE_ENTER_CHAR(a_char);
}
unsigned char
s48_extract_char(s48_value a_char)
{
if (! S48_CHAR_P(a_char))
s48_raise_argtype_error(a_char);
return S48_UNSAFE_EXTRACT_CHAR(a_char);
}
/********************************/
/* Allocation */
s48_value
s48_enter_pointer(void *pointer)
{
s48_value obj;
obj = s48_allocate_stob(S48_STOBTYPE_BYTE_VECTOR, sizeof(void *));
*(S48_ADDRESS_AFTER_HEADER(obj, void **)) = pointer;
return obj;
}
s48_value
s48_cons(s48_value v1, s48_value v2)
{
s48_value obj;
S48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2(v1, v2);
obj = s48_allocate_stob(S48_STOBTYPE_PAIR, 2 * sizeof(s48_value));
S48_UNSAFE_SET_CAR(obj, v1);
S48_UNSAFE_SET_CDR(obj, v2);
S48_GC_UNPROTECT();
return obj;
}
s48_value
s48_make_weak_pointer(s48_value value)
{
s48_value obj;
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(value);
obj = s48_allocate_stob(S48_STOBTYPE_WEAK_POINTER, sizeof(s48_value));
S48_STOB_SET(obj, 0, value);
S48_GC_UNPROTECT();
return obj;
}
s48_value
s48_enter_substring(char *str, int length)
{
s48_value obj = s48_allocate_stob(S48_STOBTYPE_STRING, length + 1);
strncpy(S48_UNSAFE_EXTRACT_STRING(obj), str, length);
*(S48_UNSAFE_EXTRACT_STRING(obj) + length) = '\0';
return obj;
}
s48_value
s48_enter_string(char *str)
{
return s48_enter_substring(str, strlen(str));
}
char *
s48_extract_string(s48_value string)
{
S48_CHECK_STRING(string);
return S48_UNSAFE_EXTRACT_STRING(string);
}
s48_value
s48_make_string(int length, char init)
{
s48_value obj = s48_allocate_stob(S48_STOBTYPE_STRING, length+1);
memset(S48_UNSAFE_EXTRACT_STRING(obj), init, length);
S48_UNSAFE_EXTRACT_STRING(obj)[length] = '\0';
return obj;
}
s48_value
s48_make_vector(int length, s48_value init)
{
int i;
s48_value obj;
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(init);
obj = s48_allocate_stob(S48_STOBTYPE_VECTOR, length * sizeof(s48_value));
for (i = 0; i < length; ++i)
S48_UNSAFE_VECTOR_SET(obj, i, init);
S48_GC_UNPROTECT();
return obj;
}
s48_value
s48_make_byte_vector(int length)
{
return s48_allocate_stob(S48_STOBTYPE_BYTE_VECTOR, length);
}
s48_value
s48_make_record(s48_value type_shared_binding)
{
int i, number_of_fields;
s48_value record = S48_FALSE;
s48_value record_type = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(record_type);
S48_SHARED_BINDING_CHECK(type_shared_binding);
S48_SHARED_BINDING_CHECK(the_record_type_binding);
record_type = S48_SHARED_BINDING_REF(type_shared_binding);
s48_check_record_type(record_type, the_record_type_binding);
number_of_fields =
S48_UNSAFE_EXTRACT_FIXNUM(S48_RECORD_TYPE_NUMBER_OF_FIELDS(record_type));
record = s48_allocate_stob(S48_STOBTYPE_RECORD,
(number_of_fields + 1) * sizeof(s48_value));
S48_UNSAFE_RECORD_SET(record, -1, record_type);
for (i = 0; i < number_of_fields; ++i)
S48_UNSAFE_RECORD_SET(record, i, S48_UNSPECIFIC);
S48_GC_UNPROTECT();
return record;
}
/*
* Raise an exception if `record' is not a record whose type is the one
* found in `type_binding'.
*/
void
s48_check_record_type(s48_value record, s48_value type_binding)
{
if (! S48_RECORD_P(S48_SHARED_BINDING_REF(type_binding)))
s48_raise_scheme_exception(S48_EXCEPTION_UNBOUND_EXTERNAL_NAME, 1,
S48_SHARED_BINDING_NAME(type_binding));
if ((! S48_RECORD_P(record)) ||
(S48_UNSAFE_SHARED_BINDING_REF(type_binding) !=
S48_UNSAFE_RECORD_REF(record, -1)))
s48_raise_argtype_error(record);
}
long
s48_length(s48_value list)
{
long i = 0;
while (!(S48_EQ(list, S48_NULL)))
{
list = S48_CDR(list);
++i;
}
return S48_UNSAFE_ENTER_FIXNUM(i);
}

11
c/fake/dlfcn.h Normal file
View File

@ -0,0 +1,11 @@
/*
* This include file is for systems which do not have dynamic loading.
*/
#if ! defined(HAVE_DLOPEN)
extern void *dlopen(char *filename, int flags);
extern char *dlerror(void);
extern void *dlsym(void *lib, char *name);
extern int dlclose(void *lib);
#endif

101
c/fake/libdl1.c Normal file
View File

@ -0,0 +1,101 @@
/*
* This is a fake version of the dynamic loading library for machines
* which don't have it, but which have nlist. We fake the stuff so that
* looking up in a NULL open library returns symbols in the current executable
* (whose name is pointed to by object_file).
*/
#include "sysdep.h"
#include <nlist.h>
#ifdef USCORE
#include <string.h>
#endif
#if ! defined(NLIST_HAS_N_NAME)
#define n_name n_un.n_name
#endif
static char self[] = "I am the wallrus",
*lasterror;
char *
dlerror(void)
{
char *res;
res = lasterror;
lasterror = NULL;
return (res);
}
void *
dlopen(char *name, int flags)
{
if (name == NULL)
return ((void *)self);
lasterror = "Dynamic loading not supported on this machine";
return (NULL);
}
int
dlclose(void *lib)
{
return (0);
}
void *
dlsym(void *lib, char *name)
{
struct nlist names[2];
int status;
extern char *s48_object_file;
#ifdef USCORE
int len;
char *tmp,
buff[40];
#endif
if (lib != self) {
lasterror = "Bad library pointer passed to dlsym()";
return (NULL);
}
if (object_file == NULL) {
lasterror = "I don't know the name of my executable";
return (NULL);
}
#ifdef USCORE
len = 1 + strlen(name) + 1;
if (len <= sizeof(buff))
tmp = buff;
else {
tmp = (char *)malloc(len);
if (tmp == NULL) {
lasterror = "Out of space";
return (NULL);
}
}
tmp[0] = '_';
strcpy(tmp + 1, name);
name = tmp;
#endif
names[0].n_name = name;
names[0].n_value = 0; /* for Linux */
names[0].n_type = 0; /* for Linux */
names[1].n_name = NULL;
status = nlist(object_file, names);
#ifdef USCORE
if (tmp != buff)
free((void *)tmp);
#endif
if ((status != 0)
|| (names[0].n_value == 0 && names[0].n_type == 0)) {
lasterror = "Symbol not found";
return (NULL);
}
return (names[0].n_value);
}

43
c/fake/libdl2.c Normal file
View File

@ -0,0 +1,43 @@
/*
* This is a fake version of the dynamic loading library for machines
* which don't have it, and don't even have an nlist.
* We fake it so that everything fails.
*/
#include "sysdep.h"
static char *lasterror;
char *
dlerror(void)
{
char *res;
res = lasterror;
lasterror = NULL;
return (res);
}
void *
dlopen(char *name, int flags)
{
lasterror = "Dynamic loading not supported on this machine";
return (NULL);
}
int
dlclose(void *lib)
{
return (0);
}
void *
dlsym(void *lib, char *name)
{
lasterror = "Dynamic loading not supported on this machine";
return (NULL);
}

15
c/fake/sigact.h Normal file
View File

@ -0,0 +1,15 @@
/*
* If we don't have sigaction, we fake it using signal.
*/
#if ! defined(HAVE_SIGACTION)
struct sigaction {
void (*sa_handler)();
int sa_mask;
int sa_flags;
};
#define sigaction(sig, act, oact) signal((sig), (act)->sa_handler)
#define sigemptyset(ign) 0
#endif

22
c/fake/strerror.c Normal file
View File

@ -0,0 +1,22 @@
/*
* If the system doesn't have a strerror procedure, we provide our own.
* Note, this depends on sys_nerr and sys_errlist being provided.
* If your system doesn't provide that either, you can replace this
* procedure with one that always returns "Unknown error".
*/
#include "sysdep.h"
extern int sys_nerr;
extern char *sys_errlist[];
char *
strerror(int errnum)
{
if ((0 <= errnum)
&& (errnum < sys_nerr))
return (sys_errlist[errnum]);
else
return ("Unknown error");
}

8
c/fake/strerror.h Normal file
View File

@ -0,0 +1,8 @@
/*
* If we don't have strerror(), we fake it using sys_nerr and sys_errlist.
*/
#if ! defined(HAVE_STRERROR)
extern char *strerror(int errnum);
#endif

9
c/fake/sys-select.h Normal file
View File

@ -0,0 +1,9 @@
/*
* If we have a sys/select.h, then include it.
*/
#if defined(HAVE_SYS_SELECT_H)
#include <sys/types.h>
#include <sys/select.h>
#endif

16
c/fd-io.h Normal file
View File

@ -0,0 +1,16 @@
#define STDIN_FD() 0
#define STDOUT_FD() 1
#define STDERR_FD() 2
extern int ps_open_fd(char *in_filename, bool is_input, long *status);
extern int ps_close_fd(long fd_as_long);
extern long ps_read_fd(long fd_as_long, char *buf_as_long, long max, bool waitp,
bool *eofp, bool *pending, long *status);
extern long ps_write_fd(long fd_as_long, char *buf_as_long, long max,
bool *pending, long *status);
extern long ps_abort_fd_op(long fd_as_long);

12
c/io.h Normal file
View File

@ -0,0 +1,12 @@
extern FILE *ps_open_input_file(char *, long *);
extern FILE *ps_open_output_file(char *, long *);
extern long ps_close(FILE *);
extern char ps_read_char(FILE *, char *, long *, char);
extern long ps_read_integer(FILE *, char *, long *);
extern long ps_write_char(char, FILE *);
extern long ps_write_integer(long, FILE *);
extern long ps_write_string(char *, FILE *);
extern long ps_read_block(FILE *, char *, long, char *, long *);
extern long ps_write_block(FILE *, char *, long);
extern char *ps_error_string(long);
extern void ps_error(char *, long count, ...);

181
c/main.c Normal file
View File

@ -0,0 +1,181 @@
/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
See file COPYING. */
#include <stdlib.h>
#include <stdio.h>
#include <unistd.h>
#include "scheme48vm.h"
#include "scheme48heap.h"
#if !defined(DEFAULT_HEAP_SIZE)
/* 1.5 megacell = 6 megabytes (3 meg per semispace) */
#define DEFAULT_HEAP_SIZE 1500000L
#endif
#if !defined(DEFAULT_STACK_SIZE)
/* 2500 cells = 10000 bytes */
#define DEFAULT_STACK_SIZE 2500L
#endif
#if defined(STATIC_AREAS)
#define DEFAULT_IMAGE_NAME NULL
#else
/* DEFAULT_IMAGE_NAME should be defined using the -D switch to cc. */
#if !defined(DEFAULT_IMAGE_NAME)
#define DEFAULT_IMAGE_NAME "scheme48.image"
#endif
#endif /* STATIC_AREAS */
extern void s48_sysdep_init(void);
extern void s48_initialize_external_modules(void);
char *s48_object_file; /* specified via a command line argument */
char *s48_reloc_file; /* dynamic loading will set this */
int
main(argc, argv)
int argc; char **argv;
{
char *image_name = DEFAULT_IMAGE_NAME;
long heap_size = DEFAULT_HEAP_SIZE; /* in numbers of cells */
long stack_size = DEFAULT_STACK_SIZE; /* in numbers of cells */
int errors = 0;
long return_value;
void *heap, *stack;
long required_heap_size;
int warn_undefined_imported_bindings_p = 1;
#if defined(STATIC_AREAS)
extern long static_entry;
extern long static_symbol_table;
extern long static_imported_binding_table, static_exported_binding_table;
extern long p_count, *p_areas[], p_sizes[];
extern long i_count, *i_areas[], i_sizes[];
#endif
long vm_argc = 0;
char *me = *argv; /* Save program name. */
s48_object_file = s48_reloc_file = NULL;
argv++; argc--; /* Skip program name. */
for (; argc > 0; argc--, argv++)
if (argv[0][0] == '-')
switch (argv[0][1]) {
case 'h':
argc--; argv++;
if (argc == 0) { errors++; break; }
heap_size = atoi(*argv);
if (heap_size <= 0) errors++;
break;
case 's':
argc--; argv++;
if (argc == 0) { errors++; break; }
stack_size = atoi(*argv);
if (stack_size <= 0) errors++;
break;
case 'i':
argc--; argv++;
if (argc == 0) { errors++; break; }
image_name = *argv;
break;
case 'a':
argc--;
vm_argc = argc; /* remaining args are passed to the VM */
argc = 0;
break;
case 'o':
argc--; argv++;
if (argc == 0) { errors++; break; }
s48_object_file = *argv;
break;
case 'u':
argc--; argv++;
warn_undefined_imported_bindings_p = 0;
break;
default:
fprintf(stderr, "Invalid argument: %s\n", *argv);
errors++;
}
else
if (argv[0][0] != '\0') {
fprintf(stderr, "Invalid argument: %s\n", *argv);
errors++; }
if (errors != 0) {
fprintf(stderr,
"Usage: %s [options] [-a arguments]\n\
Options: -h <total heap size in words>\n\
-s <stack buffer size in words>\n\
-i <image file name>\n\
-o <object file name>\n\
-u [don't warn on unbound external identifiers]",
me);
return 1;
}
s48_sysdep_init();
s48_heap_init();
s48_init();
if (image_name == NULL)
required_heap_size = 0;
else {
/* check_image_header returns number of bytes; required_heap_size
is number of cells. */
required_heap_size =
s48_check_image_header((unsigned char *)image_name) >> 2;
if (-1 == required_heap_size) {
fprintf(stderr, "Image file \"%s\" is unusable.\n", image_name);
return 1; }
}
/* two semi-spaces, plus we want some room to maneuver */
if (heap_size < 4 * required_heap_size) {
fprintf(stderr, "heap size %ld is too small, using %ld\n",
heap_size, 4 * required_heap_size);
heap_size = 4 * required_heap_size; }
heap = (void *) malloc(heap_size * sizeof(long));
stack = (void *) malloc(stack_size * sizeof(long));
if (!heap || !stack) {
fprintf(stderr, "system is out of memory\n");
return 1; }
s48_initialize_heap((long)heap, heap_size);
#if defined(STATIC_AREAS)
if (image_name == NULL) {
s48_register_static_areas(p_count, p_areas, p_sizes,
i_count, i_areas, i_sizes);
s48_set_image_valuesB(static_entry,
static_symbol_table,
static_imported_binding_table,
static_exported_binding_table);
} else if (s48_read_image() == -1) {
fprintf(stderr, "Image file \"%s\" is unusable.\n", image_name);
return 1; }
#else
if (s48_read_image() == -1) {
fprintf(stderr, "Image file \"%s\" is unusable.\n", image_name);
return 1; }
#endif
s48_initialize_vm(stack, stack_size);
s48_initialize_external_modules();
if (warn_undefined_imported_bindings_p)
s48_warn_about_undefined_imported_bindings();
return_value = s48_call_startup_procedure(argv, vm_argc);
if (s48_reloc_file != NULL)
if (0 != unlink(s48_reloc_file))
fprintf(stderr, "unable to delete file %s\n", s48_reloc_file);
return(return_value);
}

110
c/old-scheme48.h Normal file
View File

@ -0,0 +1,110 @@
typedef long scheme_value;
#define FIXNUM_TAG 0
#define FIXNUMP(x) (((long)(x) & 3L) == FIXNUM_TAG)
#define IMMEDIATE_TAG 1
#define IMMEDIATEP(x) (((long)(x) & 3L) == IMMEDIATE_TAG)
#define HEADER_TAG 2
#define HEADERP(x) (((long)(x) & 3L) == HEADER_TAG)
#define STOB_TAG 3
#define STOBP(x) (((long)(x) & 3L) == STOB_TAG)
#define ENTER_FIXNUM(n) ((scheme_value)((n) << 2))
#define EXTRACT_FIXNUM(x) ((long)(x) >> 2)
#define MISC_IMMEDIATE(n) (scheme_value)(IMMEDIATE_TAG | ((n) << 2))
#define SCHFALSE MISC_IMMEDIATE(0)
#define SCHTRUE MISC_IMMEDIATE(1)
#define SCHCHAR MISC_IMMEDIATE(2)
#define SCHUNSPECIFIC MISC_IMMEDIATE(3)
#define SCHUNDEFINED MISC_IMMEDIATE(4)
#define SCHEOF MISC_IMMEDIATE(5)
#define SCHNULL MISC_IMMEDIATE(6)
#define UNDEFINED SCHUNDEFINED
#define UNSPECIFIC SCHUNSPECIFIC
#define ENTER_BOOLEAN(n) ((n) ? SCHTRUE : SCHFALSE)
#define EXTRACT_BOOLEAN(x) ((x) != SCHFALSE)
#define ENTER_CHAR(c) (SCHCHAR | ((c) << 8))
#define EXTRACT_CHAR(x) ((x) >> 8)
#define CHARP(x) ((((long) (x)) & 0xff) == SCHCHAR)
#define ADDRESS_AFTER_HEADER(x, type) ((type *)((x) - STOB_TAG))
#define STOB_REF(x, i) ((ADDRESS_AFTER_HEADER(x, long))[i])
#define STOB_TYPE(x) ((STOB_HEADER(x)>>2)&31)
#define STOB_HEADER(x) (STOB_REF((x),-1))
#define STOB_BLENGTH(x) (STOB_HEADER(x) >> 8)
#define STOB_LLENGTH(x) (STOB_HEADER(x) >> 10)
#define STOBTYPE_PAIR 0
#define PAIRP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_PAIR))
#define STOBTYPE_SYMBOL 1
#define SYMBOLP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_SYMBOL))
#define STOBTYPE_VECTOR 2
#define VECTORP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_VECTOR))
#define STOBTYPE_CLOSURE 3
#define CLOSUREP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_CLOSURE))
#define STOBTYPE_LOCATION 4
#define LOCATIONP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_LOCATION))
#define STOBTYPE_CHANNEL 5
#define CHANNELP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_CHANNEL))
#define STOBTYPE_PORT 6
#define PORTP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_PORT))
#define STOBTYPE_RATNUM 7
#define RATNUMP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_RATNUM))
#define STOBTYPE_RECORD 8
#define RECORDP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_RECORD))
#define STOBTYPE_CONTINUATION 9
#define CONTINUATIONP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_CONTINUATION))
#define STOBTYPE_EXTENDED_NUMBER 10
#define EXTENDED_NUMBERP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_EXTENDED_NUMBER))
#define STOBTYPE_TEMPLATE 11
#define TEMPLATEP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_TEMPLATE))
#define STOBTYPE_WEAK_POINTER 12
#define WEAK_POINTERP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_WEAK_POINTER))
#define STOBTYPE_SHARED_BINDING 13
#define SHARED_BINDINGP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_SHARED_BINDING))
#define STOBTYPE_UNUSED_D_HEADER1 14
#define UNUSED_D_HEADER1P(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_UNUSED_D_HEADER1))
#define STOBTYPE_UNUSED_D_HEADER2 15
#define UNUSED_D_HEADER2P(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_UNUSED_D_HEADER2))
#define STOBTYPE_STRING 16
#define STRINGP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_STRING))
#define STOBTYPE_CODE_VECTOR 17
#define CODE_VECTORP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_CODE_VECTOR))
#define STOBTYPE_DOUBLE 18
#define DOUBLEP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_DOUBLE))
#define STOBTYPE_BIGNUM 19
#define BIGNUMP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_BIGNUM))
#define CAR(x) STOB_REF(x, 0)
#define CDR(x) STOB_REF(x, 1)
#define SYMBOL_TO_STRING(x) STOB_REF(x, 0)
#define LOCATION_ID(x) STOB_REF(x, 0)
#define CONTENTS(x) STOB_REF(x, 1)
#define CLOSURE_TEMPLATE(x) STOB_REF(x, 0)
#define CLOSURE_ENV(x) STOB_REF(x, 1)
#define WEAK_POINTER_REF(x) STOB_REF(x, 0)
#define SHARED_BINDING_NAME(x) STOB_REF(x, 0)
#define SHARED_BINDING_IS_IMPORTP(x) STOB_REF(x, 1)
#define SHARED_BINDING_REF(x) STOB_REF(x, 2)
#define PORT_HANDLER(x) STOB_REF(x, 0)
#define PORT_STATUS(x) STOB_REF(x, 1)
#define PORT_LOCK(x) STOB_REF(x, 2)
#define PORT_LOCKEDP(x) STOB_REF(x, 3)
#define PORT_DATA(x) STOB_REF(x, 4)
#define PORT_BUFFER(x) STOB_REF(x, 5)
#define PORT_INDEX(x) STOB_REF(x, 6)
#define PORT_LIMIT(x) STOB_REF(x, 7)
#define PORT_PENDING_EOFP(x) STOB_REF(x, 8)
#define CHANNEL_STATUS(x) STOB_REF(x, 0)
#define CHANNEL_ID(x) STOB_REF(x, 1)
#define CHANNEL_OS_INDEX(x) STOB_REF(x, 2)
#define VECTOR_LENGTH(x) STOB_LLENGTH(x)
#define VECTOR_REF(x, i) STOB_REF(x, i)
#define CODE_VECTOR_LENGTH(x) STOB_BLENGTH(x)
#define CODE_VECTOR_REF(x, i) (ADDRESS_AFTER_HEADER(x, unsigned char)[i])
#define STRING_LENGTH(x) (STOB_BLENGTH(x)-1)
#define STRING_REF(x, i) (ADDRESS_AFTER_HEADER(x, char)[i])

59
c/prescheme.h Normal file
View File

@ -0,0 +1,59 @@
#include <errno.h>
#include "io.h"
#define PS_READ_CHAR(PORT,RESULT,EOFP,STATUS) \
{ \
FILE * TTport = PORT; \
int TTchar; \
if (EOF == (TTchar = getc(TTport))) \
RESULT = ps_read_char(TTport, &EOFP, &STATUS, 0==1);\
else { \
RESULT = TTchar; \
EOFP = 0; \
STATUS = 0; } \
}
#define PS_PEEK_CHAR(PORT,RESULT,EOFP,STATUS) \
{ \
FILE * TTport = PORT; \
int TTchar; \
if (EOF == (TTchar = getc(TTport))) \
RESULT = ps_read_char(TTport, &EOFP, &STATUS, 0==0);\
else { \
RESULT = TTchar; \
ungetc(RESULT, TTport); \
EOFP = 0; \
STATUS = 0; } \
}
#define PS_READ_INTEGER(PORT,RESULT,EOFP,STATUS) \
RESULT = ps_read_integer(PORT,&EOFP,&STATUS);
#define PS_WRITE_CHAR(CHAR,PORT,STATUS) \
{ \
FILE * TTport = PORT; \
char TTchar = CHAR; \
if (EOF == putc(TTchar,TTport)) \
STATUS = ps_write_char(TTchar,TTport); \
else { \
STATUS = 0; } \
}
/* C shifts may not work if the amount is greater than the machine word size */
/* Patched by JAR 6/6/93 */
#define PS_SHIFT_RIGHT(X,Y,RESULT) \
{ \
long TTx = X, TTy = Y; \
RESULT = TTy >= 32 ? (TTx < 0 ? -1 : 0) : TTx >> TTy; \
}
#define PS_SHIFT_LEFT(X,Y,RESULT) \
{ \
long TTy = Y; \
RESULT = TTy >= 32 ? 0 : X << TTy; \
}
extern long s48_return_value, s48_run_machine();

459
c/scheme48.h Normal file
View File

@ -0,0 +1,459 @@
/* This file was generated automatically.
It's probably not a good idea to change it. */
#ifndef _H_SCHEME48
#define _H_SCHEME48
/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
See file COPYING. */
#include "write-barrier.h"
typedef long s48_value;
#define NO_ERRORS 0 /* errno value */
/* Misc stuff */
#define S48_EQ(v1, v2) ((v1) == (v2))
#define S48_MAX_FIXNUM_VALUE ((1 << 29) - 1)
#define S48_MIN_FIXNUM_VALUE (-1 << 29)
extern int s48_stob_has_type(s48_value, int);
extern long s48_stob_length(s48_value, int);
extern long s48_stob_byte_length(s48_value, int);
extern s48_value s48_stob_ref(s48_value, int, long);
extern void s48_stob_set(s48_value, int, long, s48_value);
extern char s48_stob_byte_ref(s48_value, int, long);
extern void s48_stob_byte_set(s48_value, int, long, char);
extern void s48_register_gc_rootB(char *);
extern void s48_push_gc_rootsB(char *, long);
extern char s48_pop_gc_rootsB(void);
extern char s48_pop_gc_roots_up_to_markerB(char *);
extern s48_value s48_enter_char(unsigned char);
extern unsigned char s48_extract_char(s48_value);
extern s48_value s48_enter_fixnum(long);
extern long s48_extract_fixnum(s48_value);
extern s48_value s48_enter_integer(long);
extern long s48_extract_integer(s48_value);
extern s48_value s48_enter_double(double);
extern double s48_extract_double(s48_value);
extern s48_value s48_cons(s48_value, s48_value);
extern s48_value s48_enter_string(char *);
extern char * s48_extract_string(s48_value);
extern s48_value s48_enter_substring(char *, int);
extern s48_value s48_make_string(int, char);
extern s48_value s48_make_vector(int, s48_value);
extern s48_value s48_make_byte_vector(int);
extern s48_value s48_make_record(s48_value);
extern s48_value s48_make_weak_pointer(s48_value);
extern void s48_check_record_type(s48_value, s48_value);
extern long s48_length(s48_value);
extern s48_value s48_enter_pointer(void *);
extern s48_value s48_get_imported_binding(char *);
extern void s48_define_exported_binding(char *, s48_value);
extern s48_value s48_set_channel_os_index(s48_value, long);
extern s48_value s48_add_channel(s48_value, s48_value, long);
extern void s48_close_channel(long);
extern s48_value s48_call_scheme(s48_value proc, long nargs, ...);
#define S48_EXPORT_FUNCTION(p) (s48_define_exported_binding(#p, s48_enter_pointer(p)))
#define S48_MAKE_VALUE(type) (s48_make_byte_vector(sizeof(type)))
extern void * s48_value_pointer(s48_value);
#define S48_EXTRACT_VALUE_POINTER(x, type) ((type *) s48_value_pointer(x))
#define S48_EXTRACT_VALUE(x, type) (*(S48_EXTRACT_VALUE_POINTER((x), type)))
#define S48_SET_VALUE(x, type, v) (S48_EXTRACT_VALUE((x), type) = (v))
#define S48_UNSAFE_EXTRACT_VALUE_POINTER(x, type) \
(S48_ADDRESS_AFTER_HEADER((x), type))
#define S48_UNSAFE_EXTRACT_VALUE(x, type) \
(*(S48_UNSAFE_EXTRACT_VALUE_POINTER((x), type)))
#define S48_UNSAFE_SET_VALUE(x, type, v) \
(S48_UNSAFE_EXTRACT_VALUE((x), type) = (v))
#define S48_UNSAFE_EXTRACT_DOUBLE(x) \
(*(S48_ADDRESS_AFTER_HEADER((x), double)))
#define S48_DECLARE_GC_PROTECT(n) long ___gc_buffer[(n)+2]
#define S48_GC_PROTECT_1(v) \
(___gc_buffer[2]=(long)&(v), \
s48_push_gc_rootsB((char *) ___gc_buffer, 1))
#define S48_GC_PROTECT_2(v1, v2) \
(___gc_buffer[2]=(long)&(v1), ___gc_buffer[3]=(long)&(v2), \
s48_push_gc_rootsB((char *) ___gc_buffer, 2))
#define S48_GC_PROTECT_3(v1, v2, v3) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
s48_push_gc_rootsB((char *) ___gc_buffer, 3))
#define S48_GC_PROTECT_4(v1, v2, v3, v4) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
s48_push_gc_rootsB((char *) ___gc_buffer, 4))
#define S48_GC_PROTECT_5(v1, v2, v3, v4, v5) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
___gc_buffer[6]=(long)&(v5), \
s48_push_gc_rootsB((char *) ___gc_buffer, 5))
#define S48_GC_PROTECT_6(v1, v2, v3, v4, v5, v6) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
___gc_buffer[6]=(long)&(v5), \
___gc_buffer[7]=(long)&(v6), \
s48_push_gc_rootsB((char *) ___gc_buffer, 6))
#define S48_GC_PROTECT_7(v1, v2, v3, v4, v5, v6, v7) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
___gc_buffer[6]=(long)&(v5), \
___gc_buffer[7]=(long)&(v6), \
___gc_buffer[8]=(long)&(v7), \
s48_push_gc_rootsB((char *) ___gc_buffer, 7))
#define S48_GC_PROTECT_8(v1, v2, v3, v4, v5, v6, v7, v8) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
___gc_buffer[6]=(long)&(v5), \
___gc_buffer[7]=(long)&(v6), \
___gc_buffer[8]=(long)&(v7), \
___gc_buffer[9]=(long)&(v8), \
s48_push_gc_rootsB((char *) ___gc_buffer, 8))
#define S48_GC_PROTECT_9(v1, v2, v3, v4, v5, v6, v7, v8, v9) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
___gc_buffer[6]=(long)&(v5), \
___gc_buffer[7]=(long)&(v6), \
___gc_buffer[8]=(long)&(v7), \
___gc_buffer[9]=(long)&(v8), \
___gc_buffer[10]=(long)&(v9), \
s48_push_gc_rootsB((char *) ___gc_buffer, 9))
#define S48_GC_PROTECT_10(v1, v2, v3, v4, v5, v6, v7, v8, v9, v10) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
___gc_buffer[6]=(long)&(v5), \
___gc_buffer[7]=(long)&(v6), \
___gc_buffer[8]=(long)&(v7), \
___gc_buffer[9]=(long)&(v8), \
___gc_buffer[10]=(long)&(v9), \
___gc_buffer[11]=(long)&(v10), \
s48_push_gc_rootsB((char *) ___gc_buffer, 10))
#define S48_GC_UNPROTECT() \
do { if (! s48_pop_gc_rootsB()) \
s48_raise_scheme_exception( S48_EXCEPTION_GC_PROTECTION_MISMATCH, 0); \
} while(0)
#define S48_GC_PROTECT_GLOBAL(v) (s48_register_gc_rootB((char *)&(v)))
/* Exceptions */
extern void s48_raise_scheme_exception(long type, long nargs, ...);
extern void s48_raise_argtype_error(s48_value value);
extern void s48_raise_argnumber_error(s48_value value,
s48_value min, s48_value max);
extern void s48_raise_range_error(s48_value value,
s48_value min, s48_value max);
extern void s48_raise_closed_channel_error();
extern void s48_raise_os_error(int the_errno);
extern void s48_raise_string_os_error(char *reason);
extern void s48_raise_out_of_memory_error();
/* Type checking */
#define S48_CHECK_PAIR(v) do { if (!S48_PAIR_P(v)) s48_raise_argtype_error(v); } while (0)
#define S48_CHECK_FIXNUM(v) do { if (!S48_FIXNUM_P(v)) s48_raise_argtype_error(v); } while (0)
#define S48_CHECK_STRING(v) do { if (!S48_STRING_P(v)) s48_raise_argtype_error(v); } while (0)
#define S48_CHECK_CHANNEL(v) do { if (!S48_CHANNEL_P(v)) s48_raise_argtype_error(v); } while (0)
#define S48_CHECK_RECORD(v) do { if (!S48_RECORD_P(v)) s48_raise_argtype_error(v); } while (0)
#define S48_CHECK_VALUE(v) do { if (!S48_BYTE_VECTOR_P(v)) s48_raise_argtype_error(v); } while (0)
#define S48_CHECK_EXPORT_BINDING(v) do { if (!S48_EXPORT_BINDING_P(v)) s48_raise_argtype_error(v); } while (0)
#define S48_VALUE_P(v) (S48_BYTE_VECTOR_P(v))
extern void s48_check_record_type(s48_value record, s48_value type_binding);
#define S48_SHARED_BINDING_CHECK(binding) \
do { if (S48_UNSPECIFIC == S48_SHARED_BINDING_REF(binding)) \
s48_raise_scheme_exception(S48_EXCEPTION_UNBOUND_EXTERNAL_NAME, 1, \
S48_SHARED_BINDING_NAME(binding)); \
} while(0)
#define S48_FIXNUM_TAG 0
#define S48_FIXNUM_P(x) (((long)(x) & 3L) == S48_FIXNUM_TAG)
#define S48_IMMEDIATE_TAG 1
#define S48_IMMEDIATE_P(x) (((long)(x) & 3L) == S48_IMMEDIATE_TAG)
#define S48_HEADER_TAG 2
#define S48_HEADER_P(x) (((long)(x) & 3L) == S48_HEADER_TAG)
#define S48_STOB_TAG 3
#define S48_STOB_P(x) (((long)(x) & 3L) == S48_STOB_TAG)
#define S48_UNSAFE_ENTER_FIXNUM(n) ((s48_value)((n) << 2))
#define S48_UNSAFE_EXTRACT_FIXNUM(x) ((long)(x) >> 2)
#define S48_MISC_IMMEDIATE(n) ((s48_value)(S48_IMMEDIATE_TAG | ((n) << 2)))
#define S48_FALSE (S48_MISC_IMMEDIATE(0))
#define S48_TRUE (S48_MISC_IMMEDIATE(1))
#define S48_CHAR (S48_MISC_IMMEDIATE(2))
#define S48_UNSPECIFIC (S48_MISC_IMMEDIATE(3))
#define S48_UNDEFINED (S48_MISC_IMMEDIATE(4))
#define S48_EOF (S48_MISC_IMMEDIATE(5))
#define S48_NULL (S48_MISC_IMMEDIATE(6))
#define S48_ENTER_BOOLEAN(n) ((n) ? S48_TRUE : S48_FALSE)
#define S48_EXTRACT_BOOLEAN(x) ((x) != S48_FALSE)
#define S48_UNSAFE_ENTER_CHAR(c) (S48_CHAR | ((c) << 8))
#define S48_UNSAFE_EXTRACT_CHAR(x) ((x) >> 8)
#define S48_CHAR_P(x) ((((long) (x)) & 0xff) == S48_CHAR)
#define S48_ADDRESS_AFTER_HEADER(x, type) ((type *)((x) - S48_STOB_TAG))
#define S48_STOB_REF(x, i) (S48_ADDRESS_AFTER_HEADER(x, s48_value)[i])
#define S48_STOB_BYTE_REF(x, i) (((char *)S48_ADDRESS_AFTER_HEADER(x, s48_value))[i])
#define S48_STOB_SET(x, i, v) do { s48_value __stob_set_x = (x); long __stob_set_i = (i); s48_value __stob_set_v = (v); if (S48_STOB_IMMUTABLEP(__stob_set_x)) s48_raise_argtype_error(__stob_set_x); else { S48_WRITE_BARRIER((__stob_set_x), (char *) (&S48_STOB_REF((__stob_set_x), (__stob_set_i))),(__stob_set_v)); *(&S48_STOB_REF((__stob_set_x), (__stob_set_i))) = (__stob_set_v); } } while (0)
#define S48_STOB_BYTE_SET(x, i, v) do { char __stob_set_x = (x); long __stob_set_i = (i); s48_value __stob_set_v = (v); if (S48_STOB_IMMUTABLEP(__stob_set_x)) s48_raise_argtype_error(__stob_set_x); else *(&S48_STOB_BYTE_REF((__stob_set_x), (__stob_set_i))) = (__stob_set_v); } while (0)
#define S48_STOB_TYPE(x) ((S48_STOB_HEADER(x)>>2)&31)
#define S48_STOB_HEADER(x) (S48_STOB_REF((x),-1))
#define S48_STOB_ADDRESS(x) (&(S48_STOB_HEADER(x)))
#define S48_STOB_BYTE_LENGTH(x) (S48_STOB_HEADER(x) >> 8)
#define S48_STOB_DESCRIPTOR_LENGTH(x) (S48_STOB_HEADER(x) >> 10)
#define S48_STOB_IMMUTABLEP(x) ((S48_STOB_HEADER(x)>>7) & 1)
#define S48_STOB_MAKE_IMMUTABLE(x) ((S48_STOB_HEADER(x)) |= (1<<7))
#define S48_STOBTYPE_PAIR 0
#define S48_PAIR_P(x) (s48_stob_has_type(x, 0))
#define S48_STOBTYPE_SYMBOL 1
#define S48_SYMBOL_P(x) (s48_stob_has_type(x, 1))
#define S48_STOBTYPE_VECTOR 2
#define S48_VECTOR_P(x) (s48_stob_has_type(x, 2))
#define S48_STOBTYPE_CLOSURE 3
#define S48_CLOSURE_P(x) (s48_stob_has_type(x, 3))
#define S48_STOBTYPE_LOCATION 4
#define S48_LOCATION_P(x) (s48_stob_has_type(x, 4))
#define S48_STOBTYPE_CHANNEL 5
#define S48_CHANNEL_P(x) (s48_stob_has_type(x, 5))
#define S48_STOBTYPE_PORT 6
#define S48_PORT_P(x) (s48_stob_has_type(x, 6))
#define S48_STOBTYPE_RATNUM 7
#define S48_RATNUM_P(x) (s48_stob_has_type(x, 7))
#define S48_STOBTYPE_RECORD 8
#define S48_RECORD_P(x) (s48_stob_has_type(x, 8))
#define S48_STOBTYPE_CONTINUATION 9
#define S48_CONTINUATION_P(x) (s48_stob_has_type(x, 9))
#define S48_STOBTYPE_EXTENDED_NUMBER 10
#define S48_EXTENDED_NUMBER_P(x) (s48_stob_has_type(x, 10))
#define S48_STOBTYPE_TEMPLATE 11
#define S48_TEMPLATE_P(x) (s48_stob_has_type(x, 11))
#define S48_STOBTYPE_WEAK_POINTER 12
#define S48_WEAK_POINTER_P(x) (s48_stob_has_type(x, 12))
#define S48_STOBTYPE_SHARED_BINDING 13
#define S48_SHARED_BINDING_P(x) (s48_stob_has_type(x, 13))
#define S48_STOBTYPE_UNUSED_D_HEADER1 14
#define S48_UNUSED_D_HEADER1_P(x) (s48_stob_has_type(x, 14))
#define S48_STOBTYPE_UNUSED_D_HEADER2 15
#define S48_UNUSED_D_HEADER2_P(x) (s48_stob_has_type(x, 15))
#define S48_STOBTYPE_STRING 16
#define S48_STRING_P(x) (s48_stob_has_type(x, 16))
#define S48_STOBTYPE_BYTE_VECTOR 17
#define S48_BYTE_VECTOR_P(x) (s48_stob_has_type(x, 17))
#define S48_STOBTYPE_DOUBLE 18
#define S48_DOUBLE_P(x) (s48_stob_has_type(x, 18))
#define S48_STOBTYPE_BIGNUM 19
#define S48_BIGNUM_P(x) (s48_stob_has_type(x, 19))
#define S48_CAR_OFFSET 0
#define S48_CAR(x) (s48_stob_ref((x), S48_STOBTYPE_PAIR, 0))
#define S48_UNSAFE_CAR(x) (S48_STOB_REF((x), 0))
#define S48_SET_CAR(x, v) (s48_stob_ref((x), S48_STOBTYPE_PAIR, 0, (v)))
#define S48_UNSAFE_SET_CAR(x, v) S48_STOB_SET((x), 0, (v))
#define S48_CDR_OFFSET 1
#define S48_CDR(x) (s48_stob_ref((x), S48_STOBTYPE_PAIR, 1))
#define S48_UNSAFE_CDR(x) (S48_STOB_REF((x), 1))
#define S48_SET_CDR(x, v) (s48_stob_ref((x), S48_STOBTYPE_PAIR, 1, (v)))
#define S48_UNSAFE_SET_CDR(x, v) S48_STOB_SET((x), 1, (v))
#define S48_SYMBOL_TO_STRING_OFFSET 0
#define S48_SYMBOL_TO_STRING(x) (s48_stob_ref((x), S48_STOBTYPE_SYMBOL, 0))
#define S48_UNSAFE_SYMBOL_TO_STRING(x) (S48_STOB_REF((x), 0))
#define S48_LOCATION_ID_OFFSET 0
#define S48_LOCATION_ID(x) (s48_stob_ref((x), S48_STOBTYPE_LOCATION, 0))
#define S48_UNSAFE_LOCATION_ID(x) (S48_STOB_REF((x), 0))
#define S48_SET_LOCATION_ID(x, v) (s48_stob_ref((x), S48_STOBTYPE_LOCATION, 0, (v)))
#define S48_UNSAFE_SET_LOCATION_ID(x, v) S48_STOB_SET((x), 0, (v))
#define S48_CONTENTS_OFFSET 1
#define S48_CONTENTS(x) (s48_stob_ref((x), S48_STOBTYPE_LOCATION, 1))
#define S48_UNSAFE_CONTENTS(x) (S48_STOB_REF((x), 1))
#define S48_SET_CONTENTS(x, v) (s48_stob_ref((x), S48_STOBTYPE_LOCATION, 1, (v)))
#define S48_UNSAFE_SET_CONTENTS(x, v) S48_STOB_SET((x), 1, (v))
#define S48_CLOSURE_TEMPLATE_OFFSET 0
#define S48_CLOSURE_TEMPLATE(x) (s48_stob_ref((x), S48_STOBTYPE_CLOSURE, 0))
#define S48_UNSAFE_CLOSURE_TEMPLATE(x) (S48_STOB_REF((x), 0))
#define S48_CLOSURE_ENV_OFFSET 1
#define S48_CLOSURE_ENV(x) (s48_stob_ref((x), S48_STOBTYPE_CLOSURE, 1))
#define S48_UNSAFE_CLOSURE_ENV(x) (S48_STOB_REF((x), 1))
#define S48_WEAK_POINTER_REF_OFFSET 0
#define S48_WEAK_POINTER_REF(x) (s48_stob_ref((x), S48_STOBTYPE_WEAK_POINTER, 0))
#define S48_UNSAFE_WEAK_POINTER_REF(x) (S48_STOB_REF((x), 0))
#define S48_SHARED_BINDING_NAME_OFFSET 0
#define S48_SHARED_BINDING_NAME(x) (s48_stob_ref((x), S48_STOBTYPE_SHARED_BINDING, 0))
#define S48_UNSAFE_SHARED_BINDING_NAME(x) (S48_STOB_REF((x), 0))
#define S48_SHARED_BINDING_IS_IMPORTP_OFFSET 1
#define S48_SHARED_BINDING_IS_IMPORTP(x) (s48_stob_ref((x), S48_STOBTYPE_SHARED_BINDING, 1))
#define S48_UNSAFE_SHARED_BINDING_IS_IMPORTP(x) (S48_STOB_REF((x), 1))
#define S48_SHARED_BINDING_REF_OFFSET 2
#define S48_SHARED_BINDING_REF(x) (s48_stob_ref((x), S48_STOBTYPE_SHARED_BINDING, 2))
#define S48_UNSAFE_SHARED_BINDING_REF(x) (S48_STOB_REF((x), 2))
#define S48_SHARED_BINDING_SET(x, v) (s48_stob_ref((x), S48_STOBTYPE_SHARED_BINDING, 2, (v)))
#define S48_UNSAFE_SHARED_BINDING_SET(x, v) S48_STOB_SET((x), 2, (v))
#define S48_PORT_HANDLER_OFFSET 0
#define S48_PORT_HANDLER(x) (s48_stob_ref((x), S48_STOBTYPE_PORT, 0))
#define S48_UNSAFE_PORT_HANDLER(x) (S48_STOB_REF((x), 0))
#define S48_PORT_STATUS_OFFSET 1
#define S48_PORT_STATUS(x) (s48_stob_ref((x), S48_STOBTYPE_PORT, 1))
#define S48_UNSAFE_PORT_STATUS(x) (S48_STOB_REF((x), 1))
#define S48_SET_PORT_STATUS(x, v) (s48_stob_ref((x), S48_STOBTYPE_PORT, 1, (v)))
#define S48_UNSAFE_SET_PORT_STATUS(x, v) S48_STOB_SET((x), 1, (v))
#define S48_PORT_LOCK_OFFSET 2
#define S48_PORT_LOCK(x) (s48_stob_ref((x), S48_STOBTYPE_PORT, 2))
#define S48_UNSAFE_PORT_LOCK(x) (S48_STOB_REF((x), 2))
#define S48_SET_PORT_LOCK(x, v) (s48_stob_ref((x), S48_STOBTYPE_PORT, 2, (v)))
#define S48_UNSAFE_SET_PORT_LOCK(x, v) S48_STOB_SET((x), 2, (v))
#define S48_PORT_LOCKEDP_OFFSET 3
#define S48_PORT_LOCKEDP(x) (s48_stob_ref((x), S48_STOBTYPE_PORT, 3))
#define S48_UNSAFE_PORT_LOCKEDP(x) (S48_STOB_REF((x), 3))
#define S48_SET_PORT_LOCKEDP(x, v) (s48_stob_ref((x), S48_STOBTYPE_PORT, 3, (v)))
#define S48_UNSAFE_SET_PORT_LOCKEDP(x, v) S48_STOB_SET((x), 3, (v))
#define S48_PORT_DATA_OFFSET 4
#define S48_PORT_DATA(x) (s48_stob_ref((x), S48_STOBTYPE_PORT, 4))
#define S48_UNSAFE_PORT_DATA(x) (S48_STOB_REF((x), 4))
#define S48_SET_PORT_DATA(x, v) (s48_stob_ref((x), S48_STOBTYPE_PORT, 4, (v)))
#define S48_UNSAFE_SET_PORT_DATA(x, v) S48_STOB_SET((x), 4, (v))
#define S48_PORT_BUFFER_OFFSET 5
#define S48_PORT_BUFFER(x) (s48_stob_ref((x), S48_STOBTYPE_PORT, 5))
#define S48_UNSAFE_PORT_BUFFER(x) (S48_STOB_REF((x), 5))
#define S48_SET_PORT_BUFFER(x, v) (s48_stob_ref((x), S48_STOBTYPE_PORT, 5, (v)))
#define S48_UNSAFE_SET_PORT_BUFFER(x, v) S48_STOB_SET((x), 5, (v))
#define S48_PORT_INDEX_OFFSET 6
#define S48_PORT_INDEX(x) (s48_stob_ref((x), S48_STOBTYPE_PORT, 6))
#define S48_UNSAFE_PORT_INDEX(x) (S48_STOB_REF((x), 6))
#define S48_SET_PORT_INDEX(x, v) (s48_stob_ref((x), S48_STOBTYPE_PORT, 6, (v)))
#define S48_UNSAFE_SET_PORT_INDEX(x, v) S48_STOB_SET((x), 6, (v))
#define S48_PORT_LIMIT_OFFSET 7
#define S48_PORT_LIMIT(x) (s48_stob_ref((x), S48_STOBTYPE_PORT, 7))
#define S48_UNSAFE_PORT_LIMIT(x) (S48_STOB_REF((x), 7))
#define S48_SET_PORT_LIMIT(x, v) (s48_stob_ref((x), S48_STOBTYPE_PORT, 7, (v)))
#define S48_UNSAFE_SET_PORT_LIMIT(x, v) S48_STOB_SET((x), 7, (v))
#define S48_PORT_PENDING_EOFP_OFFSET 8
#define S48_PORT_PENDING_EOFP(x) (s48_stob_ref((x), S48_STOBTYPE_PORT, 8))
#define S48_UNSAFE_PORT_PENDING_EOFP(x) (S48_STOB_REF((x), 8))
#define S48_SET_PORT_PENDING_EOFP(x, v) (s48_stob_ref((x), S48_STOBTYPE_PORT, 8, (v)))
#define S48_UNSAFE_SET_PORT_PENDING_EOFP(x, v) S48_STOB_SET((x), 8, (v))
#define S48_CHANNEL_STATUS_OFFSET 0
#define S48_CHANNEL_STATUS(x) (s48_stob_ref((x), S48_STOBTYPE_CHANNEL, 0))
#define S48_UNSAFE_CHANNEL_STATUS(x) (S48_STOB_REF((x), 0))
#define S48_CHANNEL_ID_OFFSET 1
#define S48_CHANNEL_ID(x) (s48_stob_ref((x), S48_STOBTYPE_CHANNEL, 1))
#define S48_UNSAFE_CHANNEL_ID(x) (S48_STOB_REF((x), 1))
#define S48_CHANNEL_OS_INDEX_OFFSET 2
#define S48_CHANNEL_OS_INDEX(x) (s48_stob_ref((x), S48_STOBTYPE_CHANNEL, 2))
#define S48_UNSAFE_CHANNEL_OS_INDEX(x) (S48_STOB_REF((x), 2))
#define S48_VECTOR_LENGTH(x) (s48_stob_length((x), S48_STOBTYPE_VECTOR))
#define S48_UNSAFE_VECTOR_LENGTH(x) (STOB_DESCRIPTOR_LENGTH(x))
#define S48_VECTOR_REF(x, i) (s48_stob_ref((x), S48_STOBTYPE_VECTOR, (i)))
#define S48_VECTOR_SET(x, i, v) (s48_stob_set((x), S48_STOBTYPE_VECTOR, (i), (v)))
#define S48_UNSAFE_VECTOR_REF(x, i) (S48_STOB_REF((x), (i)))
#define S48_UNSAFE_VECTOR_SET(x, i, v) S48_STOB_SET((x), (i), (v))
#define S48_RECORD_LENGTH(x) (s48_stob_length((x), S48_STOBTYPE_RECORD))
#define S48_UNSAFE_RECORD_LENGTH(x) (STOB_DESCRIPTOR_LENGTH(x))
#define S48_RECORD_REF(x, i) (s48_stob_ref((x), S48_STOBTYPE_RECORD, (i) + 1))
#define S48_RECORD_SET(x, i, v) (s48_stob_set((x), S48_STOBTYPE_RECORD, (i) + 1, (v)))
#define S48_UNSAFE_RECORD_REF(x, i) (S48_STOB_REF((x), (i) + 1))
#define S48_UNSAFE_RECORD_SET(x, i, v) S48_STOB_SET((x), (i) + 1, (v))
#define S48_RECORD_TYPE(x) (s48_stob_ref((x), S48_STOBTYPE_RECORD))
#define S48_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)))
#define S48_BYTE_VECTOR_SET(x, i, v) (s48_stob_byte_set((x), S48_STOBTYPE_BYTE_VECTOR, (i), (v)))
#define S48_UNSAFE_BYTE_VECTOR_REF(x, i) (S48_STOB_BYTE_REF((x), (i)))
#define S48_UNSAFE_BYTE_VECTOR_SET(x, i, v) S48_BYTE_STOB_SET((x), (i), (v))
#define S48_STRING_LENGTH(x) (s48_stob_byte_length((x), S48_STOBTYPE_STRING))
#define S48_STRING_REF(x, i) (s48_stob_byte_ref((x), S48_STOBTYPE_STRING, (i)))
#define S48_STRING_SET(x, i, v) (s48_stob_byte_set((x), S48_STOBTYPE_STRING, (i), (v)))
#define S48_UNSAFE_STRING_REF(x, i) (S48_STOB_BYTE_REF((x), (i)))
#define S48_UNSAFE_STRING_SET(x, i, v) S48_BYTE_STOB_SET((x), (i), (v))
#define S48_UNSAFE_BYTE_VECTOR_LENGTH(x) (S48_STOB_BYTE_LENGTH(x))
#define S48_UNSAFE_STRING_LENGTH(x) (S48_STOB_BYTE_LENGTH(x) - 1)
#define S48_UNSAFE_EXTRACT_STRING(x) (S48_ADDRESS_AFTER_HEADER((x), char))
#define S48_EXTRACT_EXTERNAL_OBJECT(x, type) ((type *)(S48_ADDRESS_AFTER_HEADER(x, long)+1))
#define S48_RECORD_TYPE_RESUMER(x) S48_RECORD_REF((x), 0)
#define S48_RECORD_TYPE_UID(x) S48_RECORD_REF((x), 1)
#define S48_RECORD_TYPE_NAME(x) S48_RECORD_REF((x), 2)
#define S48_RECORD_TYPE_FIELD_NAMES(x) S48_RECORD_REF((x), 3)
#define S48_RECORD_TYPE_NUMBER_OF_FIELDS(x) S48_RECORD_REF((x), 4)
#define S48_RECORD_TYPE_DISCLOSER(x) S48_RECORD_REF((x), 5)
#define S48_EXCEPTION_UNASSIGNED_LOCAL 0
#define S48_EXCEPTION_UNDEFINED_GLOBAL 1
#define S48_EXCEPTION_UNBOUND_GLOBAL 2
#define S48_EXCEPTION_BAD_PROCEDURE 3
#define S48_EXCEPTION_WRONG_NUMBER_OF_ARGUMENTS 4
#define S48_EXCEPTION_WRONG_TYPE_ARGUMENT 5
#define S48_EXCEPTION_ARITHMETIC_OVERFLOW 6
#define S48_EXCEPTION_INDEX_OUT_OF_RANGE 7
#define S48_EXCEPTION_HEAP_OVERFLOW 8
#define S48_EXCEPTION_OUT_OF_MEMORY 9
#define S48_EXCEPTION_CANNOT_OPEN_CHANNEL 10
#define S48_EXCEPTION_CHANNEL_OS_INDEX_ALREADY_IN_USE 11
#define S48_EXCEPTION_CLOSED_CHANNEL 12
#define S48_EXCEPTION_PENDING_CHANNEL_IO 13
#define S48_EXCEPTION_BUFFER_FULLEMPTY 14
#define S48_EXCEPTION_UNIMPLEMENTED_INSTRUCTION 15
#define S48_EXCEPTION_TRAP 16
#define S48_EXCEPTION_PROCEEDING_AFTER_EXCEPTION 17
#define S48_EXCEPTION_BAD_OPTION 18
#define S48_EXCEPTION_UNBOUND_EXTERNAL_NAME 19
#define S48_EXCEPTION_TOO_MANY_ARGUMENTS_TO_EXTERNAL_PROCEDURE 20
#define S48_EXCEPTION_TOO_MANY_ARGUMENTS_IN_CALLBACK 21
#define S48_EXCEPTION_CALLBACK_RETURN_UNCOVERED 22
#define S48_EXCEPTION_EXTENSION_EXCEPTION 23
#define S48_EXCEPTION_EXTENSION_RETURN_ERROR 24
#define S48_EXCEPTION_OS_ERROR 25
#define S48_EXCEPTION_UNRESUMABLE_RECORDS_IN_IMAGE 26
#define S48_EXCEPTION_GC_PROTECTION_MISMATCH 27
#define S48_CHANNEL_STATUS_CLOSED S48_UNSAFE_ENTER_FIXNUM(0)
#define S48_CHANNEL_STATUS_INPUT S48_UNSAFE_ENTER_FIXNUM(1)
#define S48_CHANNEL_STATUS_OUTPUT S48_UNSAFE_ENTER_FIXNUM(2)
#define S48_CHANNEL_STATUS_SPECIAL_INPUT S48_UNSAFE_ENTER_FIXNUM(3)
#define S48_CHANNEL_STATUS_SPECIAL_OUTPUT S48_UNSAFE_ENTER_FIXNUM(4)
#endif /* _H_SCHEME48 */

202
c/scheme48.h.in Normal file
View File

@ -0,0 +1,202 @@
/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
See file COPYING. */
#include "write-barrier.h"
typedef long s48_value;
#define NO_ERRORS 0 /* errno value */
/* Misc stuff */
#define S48_EQ(v1, v2) ((v1) == (v2))
#define S48_MAX_FIXNUM_VALUE ((1 << 29) - 1)
#define S48_MIN_FIXNUM_VALUE (-1 << 29)
extern int s48_stob_has_type(s48_value, int);
extern long s48_stob_length(s48_value, int);
extern long s48_stob_byte_length(s48_value, int);
extern s48_value s48_stob_ref(s48_value, int, long);
extern void s48_stob_set(s48_value, int, long, s48_value);
extern char s48_stob_byte_ref(s48_value, int, long);
extern void s48_stob_byte_set(s48_value, int, long, char);
extern void s48_register_gc_rootB(char *);
extern void s48_push_gc_rootsB(char *, long);
extern char s48_pop_gc_rootsB(void);
extern char s48_pop_gc_roots_up_to_markerB(char *);
extern s48_value s48_enter_char(unsigned char);
extern unsigned char s48_extract_char(s48_value);
extern s48_value s48_enter_fixnum(long);
extern long s48_extract_fixnum(s48_value);
extern s48_value s48_enter_integer(long);
extern long s48_extract_integer(s48_value);
extern s48_value s48_enter_double(double);
extern double s48_extract_double(s48_value);
extern s48_value s48_cons(s48_value, s48_value);
extern s48_value s48_enter_string(char *);
extern char * s48_extract_string(s48_value);
extern s48_value s48_enter_substring(char *, int);
extern s48_value s48_make_string(int, char);
extern s48_value s48_make_vector(int, s48_value);
extern s48_value s48_make_byte_vector(int);
extern s48_value s48_make_record(s48_value);
extern s48_value s48_make_weak_pointer(s48_value);
extern void s48_check_record_type(s48_value, s48_value);
extern long s48_length(s48_value);
extern s48_value s48_enter_pointer(void *);
extern s48_value s48_get_imported_binding(char *);
extern void s48_define_exported_binding(char *, s48_value);
extern s48_value s48_set_channel_os_index(s48_value, long);
extern s48_value s48_add_channel(s48_value, s48_value, long);
extern void s48_close_channel(long);
extern s48_value s48_call_scheme(s48_value proc, long nargs, ...);
#define S48_EXPORT_FUNCTION(p) (s48_define_exported_binding(#p, s48_enter_pointer(p)))
#define S48_MAKE_VALUE(type) (s48_make_byte_vector(sizeof(type)))
extern void * s48_value_pointer(s48_value);
#define S48_EXTRACT_VALUE_POINTER(x, type) ((type *) s48_value_pointer(x))
#define S48_EXTRACT_VALUE(x, type) (*(S48_EXTRACT_VALUE_POINTER((x), type)))
#define S48_SET_VALUE(x, type, v) (S48_EXTRACT_VALUE((x), type) = (v))
#define S48_UNSAFE_EXTRACT_VALUE_POINTER(x, type) \
(S48_ADDRESS_AFTER_HEADER((x), type))
#define S48_UNSAFE_EXTRACT_VALUE(x, type) \
(*(S48_UNSAFE_EXTRACT_VALUE_POINTER((x), type)))
#define S48_UNSAFE_SET_VALUE(x, type, v) \
(S48_UNSAFE_EXTRACT_VALUE((x), type) = (v))
#define S48_UNSAFE_EXTRACT_DOUBLE(x) \
(*(S48_ADDRESS_AFTER_HEADER((x), double)))
#define S48_DECLARE_GC_PROTECT(n) long ___gc_buffer[(n)+2]
#define S48_GC_PROTECT_1(v) \
(___gc_buffer[2]=(long)&(v), \
s48_push_gc_rootsB((char *) ___gc_buffer, 1))
#define S48_GC_PROTECT_2(v1, v2) \
(___gc_buffer[2]=(long)&(v1), ___gc_buffer[3]=(long)&(v2), \
s48_push_gc_rootsB((char *) ___gc_buffer, 2))
#define S48_GC_PROTECT_3(v1, v2, v3) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
s48_push_gc_rootsB((char *) ___gc_buffer, 3))
#define S48_GC_PROTECT_4(v1, v2, v3, v4) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
s48_push_gc_rootsB((char *) ___gc_buffer, 4))
#define S48_GC_PROTECT_5(v1, v2, v3, v4, v5) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
___gc_buffer[6]=(long)&(v5), \
s48_push_gc_rootsB((char *) ___gc_buffer, 5))
#define S48_GC_PROTECT_6(v1, v2, v3, v4, v5, v6) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
___gc_buffer[6]=(long)&(v5), \
___gc_buffer[7]=(long)&(v6), \
s48_push_gc_rootsB((char *) ___gc_buffer, 6))
#define S48_GC_PROTECT_7(v1, v2, v3, v4, v5, v6, v7) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
___gc_buffer[6]=(long)&(v5), \
___gc_buffer[7]=(long)&(v6), \
___gc_buffer[8]=(long)&(v7), \
s48_push_gc_rootsB((char *) ___gc_buffer, 7))
#define S48_GC_PROTECT_8(v1, v2, v3, v4, v5, v6, v7, v8) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
___gc_buffer[6]=(long)&(v5), \
___gc_buffer[7]=(long)&(v6), \
___gc_buffer[8]=(long)&(v7), \
___gc_buffer[9]=(long)&(v8), \
s48_push_gc_rootsB((char *) ___gc_buffer, 8))
#define S48_GC_PROTECT_9(v1, v2, v3, v4, v5, v6, v7, v8, v9) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
___gc_buffer[6]=(long)&(v5), \
___gc_buffer[7]=(long)&(v6), \
___gc_buffer[8]=(long)&(v7), \
___gc_buffer[9]=(long)&(v8), \
___gc_buffer[10]=(long)&(v9), \
s48_push_gc_rootsB((char *) ___gc_buffer, 9))
#define S48_GC_PROTECT_10(v1, v2, v3, v4, v5, v6, v7, v8, v9, v10) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
___gc_buffer[6]=(long)&(v5), \
___gc_buffer[7]=(long)&(v6), \
___gc_buffer[8]=(long)&(v7), \
___gc_buffer[9]=(long)&(v8), \
___gc_buffer[10]=(long)&(v9), \
___gc_buffer[11]=(long)&(v10), \
s48_push_gc_rootsB((char *) ___gc_buffer, 10))
#define S48_GC_UNPROTECT() \
do { if (! s48_pop_gc_rootsB()) \
s48_raise_scheme_exception( S48_EXCEPTION_GC_PROTECTION_MISMATCH, 0); \
} while(0)
#define S48_GC_PROTECT_GLOBAL(v) (s48_register_gc_rootB((char *)&(v)))
/* Exceptions */
extern void s48_raise_scheme_exception(long type, long nargs, ...);
extern void s48_raise_argtype_error(s48_value value);
extern void s48_raise_argnumber_error(s48_value value,
s48_value min, s48_value max);
extern void s48_raise_range_error(s48_value value,
s48_value min, s48_value max);
extern void s48_raise_closed_channel_error();
extern void s48_raise_os_error(int the_errno);
extern void s48_raise_string_os_error(char *reason);
extern void s48_raise_out_of_memory_error();
/* Type checking */
#define S48_CHECK_PAIR(v) do { if (!S48_PAIR_P(v)) s48_raise_argtype_error(v); } while (0)
#define S48_CHECK_FIXNUM(v) do { if (!S48_FIXNUM_P(v)) s48_raise_argtype_error(v); } while (0)
#define S48_CHECK_STRING(v) do { if (!S48_STRING_P(v)) s48_raise_argtype_error(v); } while (0)
#define S48_CHECK_CHANNEL(v) do { if (!S48_CHANNEL_P(v)) s48_raise_argtype_error(v); } while (0)
#define S48_CHECK_RECORD(v) do { if (!S48_RECORD_P(v)) s48_raise_argtype_error(v); } while (0)
#define S48_CHECK_VALUE(v) do { if (!S48_BYTE_VECTOR_P(v)) s48_raise_argtype_error(v); } while (0)
#define S48_CHECK_EXPORT_BINDING(v) do { if (!S48_EXPORT_BINDING_P(v)) s48_raise_argtype_error(v); } while (0)
#define S48_VALUE_P(v) (S48_BYTE_VECTOR_P(v))
extern void s48_check_record_type(s48_value record, s48_value type_binding);
#define S48_SHARED_BINDING_CHECK(binding) \
do { if (S48_UNSPECIFIC == S48_SHARED_BINDING_REF(binding)) \
s48_raise_scheme_exception(S48_EXCEPTION_UNBOUND_EXTERNAL_NAME, 1, \
S48_SHARED_BINDING_NAME(binding)); \
} while(0)

2357
c/scheme48heap.c Normal file
View File

File diff suppressed because it is too large Load Diff

53
c/scheme48heap.h Normal file
View File

@ -0,0 +1,53 @@
/*
* Externally visible objects defined in scheme48heap.c.
*/
/* initialize top-level variables */
extern void s48_heap_init(void);
/* heap-init interface */
extern void s48_initialize_heap(long, long);
extern void s48_register_static_areas(unsigned char, long *, long *,
unsigned char, long *, long *);
/* heap interface */
extern long s48_available(void);
extern long s48_heap_size(void);
extern long s48_find_all(long);
extern long s48_find_all_records(long);
extern char *s48_ShpS;
extern char *s48_SlimitS;
/* gc interface */
extern void s48_begin_collection(void);
extern long s48_trace_value(long);
extern long s48_trace_locationsB(char *, char *);
extern long s48_trace_stob_contentsB(long);
extern void s48_do_gc(void);
extern void s48_end_collection(void);
extern char s48_extantP(long);
extern long s48_gc_count(void);
/* allocation interface */
extern char s48_availableP(long);
extern long s48_preallocate_space(long);
extern char *s48_allocate_space(long, long, long);
extern void s48_write_barrier(long, char *, long);
/* images interface */
extern char s48_image_writing_okayP(void);
extern long s48_write_image(long, FILE *);
extern long s48_check_image_header(unsigned char *);
extern long s48_read_image();
extern long s48_startup_procedure(void);
extern long s48_initial_symbols(void);
extern long s48_initial_imported_bindings(void);
extern long s48_initial_exported_bindings(void);
extern long s48_resumer_records(void);
extern long s48_undumpable_records(long *);
extern void s48_initialization_completeB(void);
extern void s48_initializing_gc_root(void);
extern void s48_set_image_valuesB(long, long, long, long);

41
c/scheme48vm-prelude.h Normal file
View File

@ -0,0 +1,41 @@
#include <stdlib.h>
#include <stdio.h>
#include "c-mods.h"
#include "write-barrier.h"
#define SMALL_MULTIPLY(x,y) ((x) * (y))
#define NO_ERRORS 0 /* extension to errno.h */
#include "scheme48vm.h"
#include "scheme48heap.h"
#include "event.h"
#include "fd-io.h"
extern s48_value s48_extended_vm(long, s48_value),
s48_lookup_external_name(char *, char *),
s48_external_call(s48_value proc,
s48_value proc_name,
long nargs,
char *argv);
/*
* The following are hand-written macro versions of procedures
* in scheme48heap.c.
*/
#define AVAILABLEp(cells) (s48_ShpS + ((cells)<<2) < s48_SlimitS)
static char *_HHallocate_temp;
#define ALLOCATE_SPACE(type, len) \
(_HHallocate_temp = s48_ShpS, \
s48_ShpS += ((len)+3) & ~3, \
_HHallocate_temp)
/*
* We rename these to avoid name clashes.
*/
#define TTreturn_value s48_return_value
#define TTrun_machine(x) s48_run_machine(x)

10513
c/scheme48vm.c Normal file
View File

File diff suppressed because it is too large Load Diff

61
c/scheme48vm.h Normal file
View File

@ -0,0 +1,61 @@
/*
* Externally visible objects defined in scheme48vm.c.
*/
#include "scheme48.h"
/* initializing */
extern void s48_init(void);
extern void s48_initialize_vm(char *, long);
/* running */
extern long s48_call_startup_procedure(char **, long);
extern s48_value s48_restart(s48_value proc, long nargs);
extern s48_value s48_Scallback_return_stack_blockS;
/* for extension.c */
extern void s48_set_extension_valueB(s48_value);
extern s48_value s48_Sextension_valueS;
/* interrupts */
extern void s48_note_event(void);
extern char s48_Spending_eventsPS;
extern char s48_Spending_interruptPS;
extern void s48_disable_interruptsB(void);
extern void s48_enable_interruptsB(void);
extern void s48_set_os_signal(s48_value type, s48_value argument);
/* imported and exported bindings */
extern void s48_define_exported_binding(char *, s48_value);
extern s48_value s48_get_imported_binding(char *);
/* for raising exceptions in external code */
extern void s48_setup_external_exception(s48_value exception,
long nargs);
extern s48_value s48_resetup_external_exception(s48_value exception,
long additional_nargs);
extern void s48_push(s48_value value);
extern s48_value s48_stack_ref(long offset);
extern void s48_stack_setB(long offset, s48_value value);
/* called when writing an image */
extern s48_value s48_copy_symbol_table(void);
extern void s48_mark_traced_channels_closedB(void);
extern s48_value s48_cleaned_imported_bindings(void);
extern s48_value s48_exported_bindings(void);
/* called when resuming an image */
extern char s48_warn_about_undefined_imported_bindings(void);
/* manipulating channels */
extern void s48_close_channel(long);
extern s48_value s48_set_channel_os_index(s48_value, long);
extern s48_value s48_add_channel(s48_value, s48_value, long);
/* external allocation and GC roots */
extern s48_value s48_allocate_stob(long type, long size);
extern void s48_push_gc_rootsB(char *, long);
extern char s48_pop_gc_rootsB(void);
extern char * s48_set_gc_roots_baseB(void);
extern char s48_release_gc_roots_baseB(char *);
extern void s48_register_gc_rootB(char *marker);

99
c/sysdep.h.in Normal file
View File

@ -0,0 +1,99 @@
/* c/sysdep.h.in. Generated automatically from configure.in by autoheader. */
/* Define to empty if the keyword does not work. */
#undef const
/* Define if you need to in order for stat and other things to work. */
#undef _POSIX_SOURCE
/* Define as the return type of signal handlers (int or void). */
#undef RETSIGTYPE
/*
* HAVE_SIGACTION is defined iff sigaction() is available.
*/
#undef HAVE_SIGACTION
/*
* HAVE_STRERROR is defined iff the standard libraries provide strerror().
*/
#undef HAVE_STRERROR
/*
* NLIST_HAS_N_NAME is defined iff a struct nlist has an n_name member.
* If it doesn't then we assume it has an n_un member which, in turn,
* has an n_name member.
*/
#undef NLIST_HAS_N_NAME
/*
* USCORE is defined iff C externals are prepended with an underscore.
*/
#undef USCORE
/* Define if you have the chroot function. */
#undef HAVE_CHROOT
/* Define if you have the dlopen function. */
#undef HAVE_DLOPEN
/* Define if you have the ftime function. */
#undef HAVE_FTIME
/* Define if you have the gettimeofday function. */
#undef HAVE_GETTIMEOFDAY
/* Define if you have the nlist function. */
#undef HAVE_NLIST
/* Define if you have the select function. */
#undef HAVE_SELECT
/* Define if you have the setitimer function. */
#undef HAVE_SETITIMER
/* Define if you have the sigaction function. */
#undef HAVE_SIGACTION
/* Define if you have the socket function. */
#undef HAVE_SOCKET
/* Define if you have the <libgen.h> header file. */
#undef HAVE_LIBGEN_H
/* Define if you have the <posix/time.h> header file. */
#undef HAVE_POSIX_TIME_H
/* Define if you have the <sys/select.h> header file. */
#undef HAVE_SYS_SELECT_H
/* Define if you have the <sys/timeb.h> header file. */
#undef HAVE_SYS_TIMEB_H
/* Define if you have the dl library (-ldl). */
#undef HAVE_LIBDL
/* Define if you have the elf library (-lelf). */
#undef HAVE_LIBELF
/* Define if you have the gen library (-lgen). */
#undef HAVE_LIBGEN
/* Define if you have the m library (-lm). */
#undef HAVE_LIBM
/* Define if you have the mld library (-lmld). */
#undef HAVE_LIBMLD
/* Define if you have the nsl library (-lnsl). */
#undef HAVE_LIBNSL
/* Define if you have the socket library (-lsocket). */
#undef HAVE_LIBSOCKET
/* Define if you have the sun library (-lsun). */
#undef HAVE_LIBSUN
#include "fake/sigact.h"
#include "fake/strerror.h"
#include "fake/sys-select.h"

40
c/unix/dynamo-test.c Normal file
View File

@ -0,0 +1,40 @@
/*
* A simple test file for dynamic loading, dynamic name lookup, and
* old-style external calls.
*/
#include <stdio.h>
#include "scheme48.h"
/*
* These should only be called on characters or other immediates.
*/
s48_value
s48_dynamo_test(s48_value arg0, s48_value arg1, s48_value arg2)
{
int i;
s48_value vector = s48_make_vector(3, S48_FALSE);
S48_VECTOR_SET(vector, 0, arg0);
S48_VECTOR_SET(vector, 1, arg1);
S48_VECTOR_SET(vector, 2, arg2);
return vector;
}
s48_value
s48_old_dynamo_test(long nargs, s48_value args[])
{
int i;
s48_value vector = s48_make_vector(nargs, S48_FALSE);
for (i = 0; i < nargs; i++)
S48_VECTOR_SET(vector, i, args[i]);
return vector;
}

185
c/unix/dynamo.c Normal file
View File

@ -0,0 +1,185 @@
/*
* Lookup external names in the running scheme virtual machine and, on
* machines which support it, do dynamic loading.
*/
#include <stdlib.h>
#include <unistd.h>
#include "sysdep.h"
#include "scheme48.h"
#include <dlfcn.h>
#if defined(RTLD_NOW)
#define DLOPEN_MODE RTLD_NOW
#elif defined(RTLD_LAZY)
#define DLOPEN_MODE (RTLD_LAZY)
#else
#define DLOPEN_MODE (1)
#endif
#define bool char /* boolean type */
#define TRUE (0 == 0)
#define FALSE (! TRUE)
/*
* Linked list of dynamically loaded libraries.
*/
static struct dlob {
struct dlob *next;
char *name;
void *handle;
} *dlobs;
static s48_value s48_external_lookup(s48_value svname, s48_value svlocp),
s48_old_external_call(s48_value svproc, s48_value svargv),
s48_dynamic_load(s48_value filename);
static long lookup_external_name(char *name, long *locp);
static bool dynamic_load(char *name);
/*
* Install all exported functions in Scheme48.
*/
void
s48_init_external_lookup(void)
{
S48_EXPORT_FUNCTION(s48_external_lookup);
S48_EXPORT_FUNCTION(s48_old_external_call);
S48_EXPORT_FUNCTION(s48_dynamic_load);
}
/*
* Glue between Scheme48 types and C types for external name lookup.
* Look up svname (either in a dynamically loaded library, or in the
* running executable).
* On success we return TRUE, having set *(long *)svlocp to the location.
* On failure, we return FALSE.
*/
static s48_value
s48_external_lookup(s48_value svname, s48_value svlocp)
{
char *name;
long *locp,
res;
name = s48_extract_string(svname);
locp = S48_EXTRACT_VALUE_POINTER(svlocp, long);
res = lookup_external_name(name, locp);
return (S48_ENTER_BOOLEAN(res));
}
/*
* Glue between Scheme48 types and C types for external call.
* svproc is a byte vector containing the procedure and svargs is a
* vector of arguments.
*/
static s48_value
s48_old_external_call(s48_value svproc, s48_value svargv)
{
s48_value (*func)();
long *argv,
argc;
func = (s48_value (*)())*S48_EXTRACT_VALUE_POINTER(svproc, long);
argc = S48_VECTOR_LENGTH(svargv);
argv = S48_ADDRESS_AFTER_HEADER(svargv, long);
return (func(argc, argv));
}
/*
* Lookup an external name (either in a dynamically loaded library, or
* in the running executable).
* On success we return TRUE, having set *(long *)locp to the location.
* On failure, we return FALSE.
*/
static long
lookup_external_name(char *name, long *locp)
{
struct dlob *dp;
void *res;
static void *self;
for (dp = dlobs; dp != NULL; dp = dp->next) {
res = dlsym(dp->handle, name);
if (dlerror() == NULL) {
*locp = (long)res;
return (TRUE);
}
}
if (self == NULL) {
self = dlopen((char *)NULL, DLOPEN_MODE);
if (dlerror() != NULL)
return (FALSE);
}
res = dlsym(self, name);
if (dlerror() == NULL) {
*locp = (long)res;
return (TRUE);
}
return (FALSE);
}
/*
* External to load a library.
* Raises an exception if the file cannot be loaded, or loaded properly.
* Note, if you load the same file a second time, afterwards you must
* evaluate (lookup-all-externals) in package externals to update any
* externals the pointed to the old version of the library.
*/
s48_value
s48_dynamic_load(s48_value filename)
{
S48_CHECK_STRING(filename);
if (! dynamic_load(S48_UNSAFE_EXTRACT_STRING(filename)))
/* the cast below is to remove the const part of the type */
s48_raise_string_os_error((char *)dlerror());
return S48_UNSPECIFIC;
}
static bool
dynamic_load(char *name)
{
struct dlob **dpp,
*dp;
void *handle;
for (dpp = &dlobs;; dpp = &dp->next) {
dp = *dpp;
if (dp == NULL) {
handle = dlopen(name, DLOPEN_MODE);
if (handle == NULL)
return (FALSE);
dp = (struct dlob *)malloc(sizeof(*dp) + strlen(name) + 1);
if (dp == NULL) {
dlclose(handle);
return (FALSE);
}
dp->next = dlobs;
dlobs = dp;
dp->name = (char *)(dp + 1);
strcpy(dp->name, name);
dp->handle = handle;
return (TRUE);
} else if (strcmp(name, dp->name) == 0) {
dlclose(dp->handle);
dp->handle = dlopen(name, DLOPEN_MODE);
if (dp->handle == NULL) {
*dpp = dp->next;
free((void *)dp);
return (FALSE);
}
return (TRUE);
}
}
}

589
c/unix/event.c Normal file
View File

@ -0,0 +1,589 @@
/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
See file COPYING. */
#include <signal.h> /* for sigaction() (POSIX.1) */
#include <stdlib.h>
#include <unistd.h>
#include <stdio.h>
#include <sys/types.h>
#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"
/* turning interrupts and I/O readiness into events */
#define block_interrupts()
#define allow_interrupts()
static void when_keyboard_interrupt();
static void when_alarm_interrupt();
static void when_sigpipe_interrupt();
bool s48_setcatcher(int signum, void (*catcher)(int));
void s48_start_alarm_interrupts(void);
void
s48_sysdep_init(void)
{
if (!s48_setcatcher(SIGINT, when_keyboard_interrupt)
|| !s48_setcatcher(SIGALRM, when_alarm_interrupt)
|| !s48_setcatcher(SIGPIPE, when_sigpipe_interrupt)) {
fprintf(stderr,
"Failed to install signal handlers, errno = %d\n",
errno);
exit(1);
}
s48_start_alarm_interrupts();
}
/*
* Unless a signal is being ignored, set up the handler.
* If we return FALSE, something went wrong and errno is set to what.
*/
bool
s48_setcatcher(int signum, void (*catcher)(int))
{
struct sigaction sa;
if (sigaction(signum, (struct sigaction *)NULL, &sa) != 0)
return (FALSE);
if (sa.sa_handler == SIG_IGN)
return (TRUE);
sa.sa_handler = catcher;
sigemptyset(&sa.sa_mask);
sa.sa_flags = 0;
if (sigaction(signum, &sa, (struct sigaction *)NULL) != 0)
return (FALSE);
return (TRUE);
}
static long keyboard_interrupt_count = 0;
static void
when_keyboard_interrupt(int ign)
{
keyboard_interrupt_count += 1;
NOTE_EVENT;
return;
}
/*
We turn off SIGPIPE interrupts by installing a handler that does nothing.
Turning them off affects exec()'ed programs, so we don't want to do that.
Any actual pipe problems are caught when we try to read or write to them.
We thank Olin Shivers for this hack.
*/
static void
when_sigpipe_interrupt(int ign)
{
return;
}
/* ticks since last timer-interrupt request */
long s48_current_time = 0;
static long alarm_time = -1;
static long poll_time = -1;
static long poll_interval = 5;
static void
when_alarm_interrupt(int ign)
{
s48_current_time += 1;
/* fprintf(stderr, "[tick]"); */
if ((alarm_time >= 0 && alarm_time <= s48_current_time) ||
(poll_time >= 0 && poll_time <= s48_current_time)) {
NOTE_EVENT;
};
return;
}
#define USEC_PER_POLL (1000000 / POLLS_PER_SECOND)
/* delta is in ticks, 0 cancels current alarm */
long
s48_schedule_alarm_interrupt(long delta)
{
long old;
/*
fprintf(stderr, "<scheduling alarm for %ld + %ld>\n", s48_current_time,
delta/TICKS_PER_POLL);
*/
/* get remaining time */
if (alarm_time == -1)
old = -1;
else
old = (alarm_time - s48_current_time) * TICKS_PER_POLL;
/* decrement poll_time and reset current_time */
if (poll_time != -1)
poll_time -= s48_current_time;
s48_current_time = 0;
/* set alarm_time */
if (delta == 0) {
NOTE_EVENT;
alarm_time = 0; }
else
alarm_time = delta / TICKS_PER_POLL;
return old;
}
/* The next two procedures return times in seconds and ticks */
long
s48_real_time(long *ticks)
{
struct timeval tv;
static struct timeval tv_orig;
static int initp = 0;
if (!initp) {
gettimeofday(&tv_orig, NULL);
initp = 1;
};
gettimeofday(&tv, NULL);
*ticks = (tv.tv_usec - tv_orig.tv_usec)/(1000000/TICKS_PER_SECOND);
return tv.tv_sec - tv_orig.tv_sec;
}
long
s48_run_time(long *ticks)
{
struct tms time_buffer;
static long clock_tick = 0;
long cpu_time;
if (clock_tick == 0)
clock_tick = sysconf(_SC_CLK_TCK); /* POSIX.1, POSIX.2 */
times(&time_buffer); /* On Sun, getrusage() would be better */
cpu_time = time_buffer.tms_utime + time_buffer.tms_stime;
*ticks = (cpu_time % clock_tick) * TICKS_PER_SECOND / clock_tick;
return cpu_time / clock_tick;
}
void
s48_start_alarm_interrupts(void)
{
struct itimerval new, old;
new.it_value.tv_sec = 0;
new.it_value.tv_usec = USEC_PER_POLL;
new.it_interval.tv_sec = 0;
new.it_interval.tv_usec = USEC_PER_POLL;
if (0 != setitimer(ITIMER_REAL, &new, &old)) {
perror("setitimer");
exit(-1); }
}
void
s48_stop_alarm_interrupts(void)
{
struct itimerval new, old;
new.it_value.tv_sec = 0;
new.it_value.tv_usec = 0;
new.it_interval.tv_sec = 0;
new.it_interval.tv_usec = 0;
if (0 != setitimer(ITIMER_REAL, &new, &old)) {
perror("setitimer");
exit(-1); }
}
/*
* ; Scheme version of the get-next-event procedure
* ;
* ; 1. If there has been a keyboard interrupt, return it.
* ; 2. Check for ready ports if enough time has passed since the last check.
* ; 3. If there is a ready port, return it.
* ; 4. If an alarm is due, return it.
* ; 5. If no events are pending, clear the event flags.
* (define (get-next-event)
* (cond ((> *keyboard-interrupt-count* 0)
* (without-interrupts
* (lambda ()
* (set! *keyboard-interrupt-count*
* (- *keyboard-interrupt-count* 1))))
* (values (enum event-type keyboard-interrupt) #f #f))
* (else
* (cond ((>= *current_time* *poll-time*)
* (queue-ready-ports)
* (set! *poll-time* (+ *time* *poll-interval*))))
* (cond ((not (queue-empty? ready-ports))
* (values (enum event-type i/o-completion)
* (dequeue! ready-ports)))
* ((>= *current_time* *alarm-time*)
* (set! *alarm-time* max-integer)
* (values (enum event-type alarm-interrupt) #f))
* (else
* (without-interrupts
* (lambda ()
* (if (and (= *keyboard-interrupt-count* 0)
* (> *alarm-time* *current_time*)
* (> *poll-time* *current_time*))
* (set! *pending-event?* #f))))
* (values (enum event-type no-event) #f))))))
*/
static bool there_are_ready_ports(void);
static int next_ready_port(void);
static int queue_ready_ports(bool wait, long seconds, long ticks);
int
s48_get_next_event(long *ready_fd, long *status)
{
/*
extern int s48_os_signal_pending(void);
*/
int io_poll_status;
/*
fprintf(stderr, "[poll at %d (waiting for %d)]\n", s48_current_time, alarm_time);
*/
if (keyboard_interrupt_count > 0) {
block_interrupts();
--keyboard_interrupt_count;
allow_interrupts();
/* fprintf(stderr, "[keyboard interrupt]\n"); */
return (KEYBOARD_INTERRUPT_EVENT);
}
if (poll_time != -1 && s48_current_time >= poll_time) {
io_poll_status = queue_ready_ports(FALSE, 0, 0);
if (io_poll_status == NO_ERRORS)
poll_time = s48_current_time + poll_interval;
else {
*status = io_poll_status;
return (ERROR_EVENT);
}
}
if (there_are_ready_ports()) {
*ready_fd = next_ready_port();
*status = 0; /* chars read or written */
/* fprintf(stderr, "[i/o completion]\n"); */
return (IO_COMPLETION_EVENT);
}
if (alarm_time != -1 && s48_current_time >= alarm_time) {
alarm_time = -1;
/* fprintf(stderr, "[alarm]\n"); */
return (ALARM_EVENT);
}
/*
if (s48_os_signal_pending())
return (OS_SIGNAL_EVENT);
*/
block_interrupts();
if ((keyboard_interrupt_count == 0)
&& (alarm_time == -1 || s48_current_time < alarm_time)
&& (poll_time == -1 || s48_current_time < poll_time))
s48_Spending_eventsPS = FALSE;
allow_interrupts();
return (NO_EVENT);
}
/*
* We keep two queues of ports: those that have a pending operation, and
* those whose operation has completed. Periodically, we call select() on
* the pending ports and move any that are ready onto the other queue and
* signal an event.
*/
#define FD_QUIESCENT 0 /* idle */
#define FD_READY 1 /* I/O ready to be performed */
#define FD_PENDING 2 /* waiting */
typedef struct fd_struct {
int fd, /* file descriptor */
status; /* one of the FD_* constants */
bool is_input; /* iff input */
struct fd_struct *next; /* next on same queue */
} fd_struct;
/*
* A queue of fd_structs is empty iff the first field is NULL. In
* that case, lastp points to first.
*/
typedef struct fdque {
fd_struct *first,
**lastp;
} fdque;
static fd_struct *fds[FD_SETSIZE];
static fdque ready = {
NULL,
&ready.first
},
pending = {
NULL,
&pending.first
};
static void findrm(fd_struct *entry, fdque *que);
static fd_struct *rmque(fd_struct **link, fdque *que);
static void addque(fd_struct *entry, fdque *que);
static fd_struct *add_fd(int fd, bool is_input);
/*
* Find a fd_struct in a queue, and remove it.
*/
static void
findrm(fd_struct *entry, fdque *que)
{
fd_struct **fp,
*f;
for (fp = &que->first; (f = *fp) != entry; fp = &f->next)
if (f == NULL) {
fprintf(stderr, "ERROR: findrm fd %d, status %d not on queue.\n",
entry->fd, entry->status);
return;
}
rmque(fp, que);
}
/*
* Given a pointer to the link of a fd_struct, and a pointer to
* the queue it is on, remove the entry from the queue.
* The entry removed is returned.
*/
static fd_struct *
rmque(fd_struct **link, fdque *que)
{
fd_struct *res;
res = *link;
*link = res->next;
if (res->next == NULL)
que->lastp = link;
return (res);
}
/*
* Add a fd_struct to a queue.
*/
static void
addque(fd_struct *entry, fdque *que)
{
*que->lastp = entry;
entry->next = NULL;
que->lastp = &entry->next;
}
static bool
there_are_ready_ports(void)
{
return (ready.first != NULL);
}
static int
next_ready_port(void)
{
fd_struct *p;
p = rmque(&ready.first, &ready);
p->status = FD_QUIESCENT;
return (p->fd);
}
/*
* Put fd on to the queue of ports with pending operations.
* Return TRUE if successful, and FALSE otherwise.
*/
bool
s48_add_pending_fd(int fd, bool is_input)
{
fd_struct *data;
if (! (0 <= fd && fd < FD_SETSIZE)) {
fprintf(stderr, "ERROR: add_pending fd %d not in [0, %d)\n",
fd,
FD_SETSIZE);
return (FALSE);
}
data = fds[fd];
if (data == NULL) {
data = add_fd(fd, is_input);
if (data == NULL)
return (FALSE); /* no more memory */
} else if (data->status == FD_PENDING)
return (TRUE); /* fd is already pending */
else if (data->status == FD_READY)
findrm(data, &ready);
data->status = FD_PENDING;
addque(data, &pending);
if (poll_time == -1)
poll_time = s48_current_time + poll_interval;
return TRUE;
}
/*
* Add a new fd_struct for fd.
*/
static fd_struct *
add_fd(int fd, bool is_input)
{
struct fd_struct *new;
new = (struct fd_struct *)malloc(sizeof(*new));
if (new != NULL) {
new->fd = fd;
new->status = FD_QUIESCENT;
new->is_input = is_input;
new->next = NULL;
fds[fd] = new;
}
return (new);
}
/*
* Remove fd from any queues it is on. Returns true if the FD was on a queue
* and false if it wasn't.
*/
bool
s48_remove_fd(int fd)
{
struct fd_struct *data;
if (! (0 <= fd && fd < FD_SETSIZE)) {
fprintf(stderr, "ERROR: s48_remove_fd fd %d not in [0, %d)\n",
fd,
FD_SETSIZE);
return FALSE;
}
data = fds[fd];
if (data == NULL)
return FALSE;
if (data->status == FD_PENDING) {
findrm(data, &pending);
if (pending.first == NULL)
poll_time = -1;
} else if (data->status == FD_READY)
findrm(data, &ready);
free((void *)data);
fds[fd] = NULL;
return TRUE;
}
int
s48_wait_for_event(long max_wait, bool is_minutes)
{
int status;
long seconds,
ticks;
/* fprintf(stderr, "[waiting]\n"); */
s48_stop_alarm_interrupts();
ticks = 0;
if (max_wait == -1)
seconds = -1;
else if (is_minutes)
seconds = max_wait * 60;
else {
seconds = max_wait / TICKS_PER_SECOND;
ticks = max_wait % TICKS_PER_SECOND;
}
if (keyboard_interrupt_count > 0)
status = NO_ERRORS;
else {
status = queue_ready_ports(TRUE, seconds, ticks);
if (there_are_ready_ports())
NOTE_EVENT;
}
s48_start_alarm_interrupts();
return (status);
}
/*
* Call select() on the pending ports and move any ready ones to the ready
* queue. If wait is true, seconds is either -1 (wait forever) or the
* maximum number of seconds to wait (with ticks any additional ticks).
* The returned value is a status code.
*/
static int
queue_ready_ports(bool wait, long seconds, long ticks)
{
fd_set reads,
writes,
alls;
int limfd;
fd_struct *fdp,
**fdpp;
int left;
struct timeval tv,
*tvp;
if ((! wait)
&& (pending.first == NULL))
return (NO_ERRORS);
FD_ZERO(&reads);
FD_ZERO(&writes);
FD_ZERO(&alls);
limfd = 0;
for (fdp = pending.first; fdp != NULL; fdp = fdp->next) {
FD_SET(fdp->fd, fdp->is_input ? &reads : &writes);
FD_SET(fdp->fd, &alls);
if (limfd <= fdp->fd)
limfd = fdp->fd + 1;
}
tvp = &tv;
if (wait)
if (seconds == -1)
tvp = NULL;
else {
tv.tv_sec = seconds;
tv.tv_usec = ticks * (1000000 / TICKS_PER_SECOND);
}
else
timerclear(&tv);
while(TRUE) {
left = select(limfd, &reads, &writes, &alls, tvp);
if (left > 0) {
fdpp = &pending.first;
while (left > 0 && (fdp = *fdpp) != NULL)
if ((FD_ISSET(fdp->fd, &alls))
|| (FD_ISSET(fdp->fd, fdp->is_input ? &reads : &writes))) {
--left;
rmque(fdpp, &pending);
fdp->status = FD_READY;
addque(fdp, &ready);
} else
fdpp = &fdp->next;
if (pending.first == NULL)
poll_time = -1;
return NO_ERRORS;
}
else if (left == 0)
return NO_ERRORS;
else if (errno == EINTR) {
tvp = &tv; /* turn off blocking and try again */
timerclear(tvp);
}
else
return errno;
}
}

181
c/unix/fd-io.c Normal file
View File

@ -0,0 +1,181 @@
/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
See file COPYING. */
#include <unistd.h>
#include <stdio.h>
#include <sys/types.h>
#include <sys/stat.h>
#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"
/* Non-blocking I/O on file descriptors.
There appear to be two ways to get non-blocking input and output. One
is to open files with the O_NONBLOCK flag (and to use fcntl() to do the
same to stdin and stdout), the other is to call select() on each file
descriptor before doing the I/O operation. O_NONBLOCK has the problem
of being a property of the file descriptor, and its use with stdin and
stdout can lead to horrible results.
We use a mixture of both. For input files we call select() before doing
a read(), because read() will return immediately if there are any bytes
available at all, and using O_NONBLOCK on stdin is a very bad idea.
Output files are opened using O_NONBLOCK and stdout is left alone.
*/
int
ps_open_fd(char *filename, bool is_input, long *status)
{
#define FILE_NAME_SIZE 1024
#define PERMISSION 0666 /* read and write for everyone */
char filename_temp[FILE_NAME_SIZE];
char *expanded;
extern char *s48_expand_file_name(char *, char *, int);
int flags;
mode_t mode;
expanded = s48_expand_file_name(filename, filename_temp, FILE_NAME_SIZE);
if (expanded == NULL)
return -1;
if (is_input) {
flags = O_RDONLY;
mode = 0; }
else {
flags = O_WRONLY | O_CREAT | O_TRUNC | O_NONBLOCK;
mode = PERMISSION; }
/* keep trying if interrupted */
while(TRUE) {
int fd = open(expanded, flags, mode);
if (fd != -1) {
*status = NO_ERRORS;
return fd; }
else if (errno != EINTR) {
*status = errno;
return -1; }
}
}
int
ps_close_fd(long fd_as_long)
{
int fd = (int)fd_as_long;
/* keep retrying if interrupted */
while(TRUE) {
int status = close(fd);
if (status != -1) {
s48_remove_fd(fd);
return NO_ERRORS; }
else if (errno != EINTR)
return errno;
}
}
long
ps_read_fd(long fd_as_long, char *buffer, long max, bool waitp,
bool *eofp, bool *pending, long *status)
{
int got, ready;
void *buf = (void *)buffer;
int fd = (int)fd_as_long;
struct timeval timeout;
fd_set readfds;
FD_ZERO(&readfds);
FD_SET(fd, &readfds);
timerclear(&timeout);
/* for the normal return */
*eofp = FALSE;
*pending = FALSE;
*status = NO_ERRORS;
while(TRUE) {
ready = select(fd + 1, &readfds, NULL, &readfds, &timeout);
if (ready == 0) {
if (!waitp)
return 0;
else if (s48_add_pending_fd(fd, TRUE)) {
*pending = TRUE;
return 0; }
else {
*status = ENOMEM; /* as close as POSIX gets */
return 0; }}
else if (ready == -1) {
if (errno != EINTR) {
*status = errno;
return 0; } }
else { /* characters waiting */
got = read(fd, buf, max);
if (got > 0) { /* all is well */
return got; }
else if (got == 0) { /* end of file */
*eofp = TRUE;
return 0; }
else if (errno == EINTR) { /* HCC */
return 0; }
else if (errno == EAGAIN) { /* HCC */
if (!waitp)
return 0;
else if (s48_add_pending_fd(fd, TRUE)) {
*pending = TRUE;
return 0; }
else {
*status = ENOMEM; /* as close as POSIX gets */
return 0; } }
else {
*status = errno;
return 0; } } }
}
long
ps_write_fd(long fd_as_long, char *buffer, long max, bool *pending, long *status)
{
int sent;
int fd = (int)fd_as_long;
void *buf = (void *)buffer;
*pending = FALSE;
*status = NO_ERRORS;
sent = write(fd, buf, max);
if (sent > 0)
{}
else if (errno == EINTR || errno == EAGAIN) { /* HCC */
if (s48_add_pending_fd(fd, FALSE))
*pending = TRUE;
else
*status = ENOMEM; /* as close as POSIX gets */
sent = 0; }
else {
*status = errno;
sent = 0; }
return sent;
}
long
ps_abort_fd_op(long fd_as_long)
{
int fd = (int)fd_as_long;
if (!s48_remove_fd(fd))
fprintf(stderr, "Error: ps_abort_fd_op, no pending operation on fd %d\n",
fd);
return 0; /* because we do not actually do any I/O in parallel the
status is always zero: no characters transfered. */
}

296
c/unix/io.c Normal file
View File

@ -0,0 +1,296 @@
/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
See file COPYING. */
#include <stdio.h>
#include <stdlib.h>
#include <errno.h>
#include <stdarg.h>
#include <string.h>
#include "io.h"
#include "scheme48.h"
#define TRUE (0 == 0)
#define FALSE (! TRUE)
#define bool char
/* read a character while ignoring interrupts */
#define READ_CHAR(PORT,RESULT) \
{ \
FILE * TTport = PORT; \
int TTchar; \
if (EOF == (TTchar = getc(TTport))) \
RESULT = s48_read_char(TTport); \
else \
RESULT = TTchar; \
}
/*
Helper procedure for the READ_CHAR macro. If the getc was interrupted
we clear the error bit and try again.
*/
int
s48_read_char(FILE *port)
{
int result;
while(TRUE) {
if (ferror(port) && errno == EINTR) {
clearerr(port);
result = getc(port);
if (EOF != result)
return result; }
else
return EOF; }
}
/* called when getc(port) returned EOF */
char
ps_read_char(FILE *port, bool *eofp, long *status, bool peekp)
{
bool errorp;
int result;
result = s48_read_char(port); /* read past any interruptions */
if (result != EOF) {
if (peekp)
ungetc(result, port);
*eofp = FALSE;
*status = NO_ERRORS;
return result; }
else {
errorp = ferror(port);
clearerr(port);
if (errorp) {
*eofp = FALSE;
*status = errno;
return 0; }
else {
*eofp = TRUE;
*status = NO_ERRORS;
return 0; } }
}
long
ps_read_integer(FILE *port, bool *eofp, long *status)
{
long result;
int ch;
bool negate;
bool errorp;
/* eat whitespace */
do { READ_CHAR(port, ch); }
while (ch == ' ' || ch == '\t' || ch == '\n');
/* read optional sign */
if (ch == '-') {
negate = TRUE;
READ_CHAR(port, ch); }
else
negate = FALSE;
if (ch < '0' || '9' < ch) {
if (ch != EOF) {
*eofp = FALSE;
*status = EINVAL; } /* has to be something */
else {
errorp = ferror(port);
clearerr(port);
if (errorp) {
*eofp = FALSE;
*status = errno; }
else {
*eofp = TRUE;
*status = 0; } }
result = 0; }
else {
result = ch - '0';
while(1) {
READ_CHAR(port, ch);
if (ch < '0' || '9' < ch)
break;
result = (10 * result) + (ch - '0'); }
if (ch != EOF)
ungetc(ch, port);
*eofp = FALSE;
*status = 0; }
return (negate ? -result : result);
}
/* write a character regardless of interrupts */
#define WRITE_CHAR(CH,PORT,RESULT) \
{ \
char TTch = CH; \
FILE * TTport = PORT; \
if (putc(TTch, TTport) != EOF) \
RESULT = 0; \
else \
RESULT = ps_write_char(TTch, TTport); \
}
/* called when putc(char, port) returned EOF */
long
ps_write_char(char ch, FILE *port)
{
while(TRUE) {
clearerr(port);
if (errno != EINTR)
return errno;
else if (putc(ch, port) != EOF)
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)
{
char ch;
long status;
if (n == 0)
status = 0;
else {
status = write_integer(n / 10, port);
if (status == 0) {
ch = (n % 10) + '0';
WRITE_CHAR(ch, port,status); } }
return status;
}
long
ps_write_string(char *string, FILE *port)
{
while (TRUE) {
if (EOF != fputs(string, port))
return (0);
clearerr(port);
if (errno != EINTR)
return (errno);
}
}
long
ps_read_block(FILE *port, char *buffer, long count, bool *eofp, long *status)
{
int got = 0;
bool errorp;
while(TRUE) {
got += fread(buffer, sizeof(char), count - got, port);
if (got == count) {
*eofp = FALSE;
*status = NO_ERRORS;
return got;}
else if (ferror(port) && errno == EINTR)
clearerr(port);
else {
*eofp = feof(port);
errorp = ferror(port);
clearerr(port);
if (errorp)
*status = errno;
else
*status = NO_ERRORS;
return got;} };
}
long
ps_write_block(FILE *port, char *buffer, long count)
{
int sent = 0;
while(TRUE) {
sent += fwrite(buffer, sizeof(char), count - sent, port);
if (sent == count)
return NO_ERRORS;
else if (ferror(port) && errno == EINTR)
clearerr(port);
else {
clearerr(port);
return errno; } }
}
void
ps_error(char *message, long count, ...)
{
va_list ap;
va_start(ap, count);
fputs(message, stderr);
for(; count > 0; --count)
fprintf(stderr, " %ld", va_arg(ap, long));
putc('\n', stderr);
exit(-1);
}
static FILE *
ps_really_open_file(char *filename, long *status, char *mode)
{
#define FILE_NAME_SIZE 1024
char filename_temp[FILE_NAME_SIZE];
char *expanded;
extern char *s48_expand_file_name(char *, char *, int);
FILE *new;
expanded = s48_expand_file_name(filename, filename_temp, FILE_NAME_SIZE);
if (expanded == NULL) {
*status = EDOM; /* has to be something */
return NULL; }
new = fopen(expanded, mode);
if (new == NULL) {
*status = errno;
return NULL; }
*status = NO_ERRORS;
return new;
}
FILE *
ps_open_input_file(char *name, long *status)
{
return ps_really_open_file(name, status, "r");
}
FILE *
ps_open_output_file(char *name, long *status)
{
return ps_really_open_file(name, status, "w");
}
long
ps_close(FILE *stream)
{
if (0 == fclose(stream))
return 0;
else
return errno;
}

129
c/unix/misc.c Normal file
View File

@ -0,0 +1,129 @@
/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
See file COPYING. */
#include <stdio.h>
#include <stdlib.h> /* for getenv(), etc. (POSIX?/ANSI) */
#include <string.h> /* for strncpy(), etc. (POSIX/ANSI) */
#include <pwd.h> /* for getpwnam() (POSIX.1) */
#include <unistd.h> /* for sysconf(), etc. (POSIX.1/.2)*/
#include <errno.h>
#include "sysdep.h"
#define TRUE (0 == 0)
#define FALSE (0 == 1)
/*
Expanding Unix filenames
Unix Sucks
Richard Kelsey Wed Jan 17 21:40:26 EST 1990
Later modified by others who wish to remain anonymous
Expands initial ~ and ~/ in string `name', leaving the result in `buffer'.
`buffer_len' is the length of `buffer'.
Note: strncpy(x, y, n) copies from y to x.
*/
char *s48_expand_file_name (name, buffer, buffer_len)
char *name, *buffer;
int buffer_len;
{
#define USER_NAME_SIZE 256
char *dir, *p, user_name[USER_NAME_SIZE];
struct passwd *user_data;
int dir_len, i;
extern char *getenv();
int name_len = strlen(name);
dir = 0;
if (name[0] == '~') {
name++; name_len--;
if (name[0] == '/' || name[0] == 0) {
dir = getenv("HOME"); }
else {
for (i = 0, p = name; i < name_len && *p != '/'; i++, p++)
if (i > (USER_NAME_SIZE - 2)) {
fprintf(stderr,
"\ns48_expand_file_name: user name longer than %d characters\n",
USER_NAME_SIZE - 3);
return(NULL); };
strncpy(user_name, name, i);
user_name[i] = 0;
user_data = getpwnam(user_name);
if (!user_data) {
fprintf(stderr, "\ns48_expand_file_name: unknown user \"%s\"\n",
user_name);
return(NULL); };
name_len -= i;
name = p;
dir = user_data->pw_dir; } }
else if (name[0] == '$') {
name++; name_len--;
for (i = 0, p = name; i < name_len && *p != '/'; i++, p++)
if (i > (USER_NAME_SIZE - 2)) {
fprintf(stderr,
"\ns48_expand_file_name: environment variable longer than %d characters\n",
USER_NAME_SIZE - 3);
return(NULL); };
strncpy(user_name, name, i);
user_name[i] = 0;
name_len -= i;
name = p;
dir = getenv(user_name); }
if (dir) {
dir_len = strlen(dir);
if ((name_len + dir_len + 1) > buffer_len) {
fprintf(stderr, "\ns48_expand_file_name: supplied buffer is too small\n");
return(NULL); };
strncpy(buffer, dir, dir_len);
strncpy(buffer + dir_len, name, name_len);
buffer[name_len + dir_len] = 0; }
else {
if ((name_len + 1) > buffer_len) {
fprintf(stderr, "\ns48_expand_file_name: supplied buffer is too small\n");
return(NULL); };
strncpy(buffer, name, name_len);
buffer[name_len] = 0; }
return(buffer);
}
/* test routine
main(argc, argv)
int argc;
char *argv[];
{
char buffer[32];
s48_expand_file_name(argv[1], buffer, 32);
printf("%s\n", buffer);
return(0);
}
*/
/* Driver loop for tail-recursive calls */
long s48_return_value;
long
s48_run_machine(long (*proc) (void))
{
while (proc != 0)
proc = (long (*) (void)) (*proc)();
return s48_return_value;
}
unsigned char *
ps_error_string(long the_errno)
{
return((unsigned char *)strerror(the_errno));
}

376
c/unix/socket.c Normal file
View File

@ -0,0 +1,376 @@
/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
See file COPYING. */
/*
* An interface to Unix sockets.
*/
#include <sys/types.h>
#include <sys/socket.h>
#include <sys/param.h>
#include <errno.h>
#include <fcntl.h>
#include <netdb.h>
#include <unistd.h>
#include <string.h>
#include <netinet/in.h>
#include "c-mods.h"
#include "scheme48.h"
#include "fd-io.h" /* ps_close_fd() */
#include "event.h" /* add_pending_fd() */
/* Henry Cejtin says that 5 is the largest safe number for this. */
#define LISTEN_QUEUE_SIZE 5
extern void s48_init_socket(void);
static s48_value s48_socket(s48_value server_p),
s48_bind(s48_value socket_channel, s48_value number),
s48_socket_number(s48_value socket_channel),
s48_listen(s48_value socket_channel),
s48_accept(s48_value socket_channel),
s48_connect(s48_value socket_channel,
s48_value machine,
s48_value port),
s48_close_socket_half(s48_value socket_channel,
s48_value input_p),
s48_get_host_name(void);
/*
* Install all exported functions in Scheme48.
*/
void
s48_init_socket(void)
{
S48_EXPORT_FUNCTION(s48_socket);
S48_EXPORT_FUNCTION(s48_bind);
S48_EXPORT_FUNCTION(s48_socket_number);
S48_EXPORT_FUNCTION(s48_listen);
S48_EXPORT_FUNCTION(s48_accept);
S48_EXPORT_FUNCTION(s48_connect);
S48_EXPORT_FUNCTION(s48_close_socket_half);
S48_EXPORT_FUNCTION(s48_get_host_name);
}
/*
* Create an internet-domain stream (reliable, sequenced) socket.
* We return an input channel on success and raise an exception on failure.
* The socket has been made non-blocking.
*/
static s48_value
s48_socket(s48_value server_p)
{
int fd,
mode;
s48_value channel;
fd = socket(AF_INET, SOCK_STREAM, 0);
if (fd < 0)
s48_raise_os_error(errno);
if (-1 == fcntl(fd, F_SETFL, O_NONBLOCK))
s48_raise_os_error(errno);
mode = (server_p == S48_FALSE) ?
S48_CHANNEL_STATUS_SPECIAL_OUTPUT :
S48_CHANNEL_STATUS_SPECIAL_INPUT;
channel = s48_add_channel(mode, s48_enter_string("socket"), fd);
if (!S48_CHANNEL_P(channel)) {
ps_close_fd(fd); /* retries if interrupted */
s48_raise_scheme_exception(s48_extract_fixnum(channel), 0); };
return channel;
}
/*
* Given an internet-domain stream socket and a port number, bind
* the socket to the port and prepare to receive connections.
* If the port number is #f, then we bind the socket to any available
* port.
*
* Nothing useful is returned.
*/
static s48_value
s48_bind(s48_value channel, s48_value port_number)
{
int socket_fd,
port;
struct sockaddr_in address;
S48_CHECK_CHANNEL(channel);
socket_fd = S48_UNSAFE_EXTRACT_FIXNUM(S48_UNSAFE_CHANNEL_OS_INDEX(channel));
if (port_number == S48_FALSE)
port = 0;
else
port = s48_extract_fixnum(port_number);
address.sin_family = AF_INET;
address.sin_addr.s_addr = htonl(INADDR_ANY);
address.sin_port = htons(port);
if (bind(socket_fd, (struct sockaddr *)&address, sizeof(address)) < 0)
s48_raise_os_error(errno);
return S48_UNSPECIFIC;
}
/*
* Return the port number associated with an internet stream socket.
*/
static s48_value
s48_socket_number(s48_value channel)
{
int socket_fd,
len;
struct sockaddr_in address;
S48_CHECK_CHANNEL(channel);
socket_fd = S48_UNSAFE_EXTRACT_FIXNUM(S48_UNSAFE_CHANNEL_OS_INDEX(channel));
address.sin_addr.s_addr = htonl(INADDR_ANY);
len = sizeof(address);
if ((getsockname(socket_fd, (struct sockaddr *)&address, &len) < 0)
|| (address.sin_family != AF_INET))
s48_raise_os_error(errno);
return s48_enter_fixnum(htons(address.sin_port));
}
static s48_value
s48_listen(s48_value channel)
{
int socket_fd;
S48_CHECK_CHANNEL(channel);
socket_fd = S48_UNSAFE_EXTRACT_FIXNUM(S48_UNSAFE_CHANNEL_OS_INDEX(channel));
if (listen(socket_fd, LISTEN_QUEUE_SIZE) < 0)
s48_raise_os_error(errno);
return S48_UNSPECIFIC;
}
/*
* Given an internet-domain stream socket which has been bound
* accept a connection and return the resulting socket as a pair of channels
* (after marking it non-blocking).
*
* If the accept fails because the client hasn't connected yet, then we
* return #f.
*
* If it fails for any other reason, then an exception is raised.
*/
static s48_value
s48_accept(s48_value channel)
{
int socket_fd,
connect_fd,
output_fd,
len;
struct sockaddr_in address;
s48_value input_channel,
output_channel;
S48_CHECK_CHANNEL(channel);
socket_fd = S48_UNSAFE_EXTRACT_FIXNUM(S48_UNSAFE_CHANNEL_OS_INDEX(channel));
len = sizeof(address);
connect_fd = accept(socket_fd, (struct sockaddr *)&address, &len);
/*
* Check for a connection. If we have one we create two channels, one
* input and one, with a dup()'ed fd, output. Lots of error checking
* makes this messy.
*/
if (connect_fd >= 0) {
S48_DECLARE_GC_PROTECT(1);
if (-1 == fcntl(connect_fd, F_SETFL, O_NONBLOCK))
s48_raise_os_error(errno);
input_channel = s48_add_channel(S48_CHANNEL_STATUS_INPUT,
s48_enter_string("socket connection"),
connect_fd);
if (!S48_CHANNEL_P(input_channel)) {
ps_close_fd(connect_fd); /* retries if interrupted */
s48_raise_scheme_exception(s48_extract_fixnum(input_channel), 0); };
output_fd = dup(connect_fd);
if (output_fd == -1)
s48_raise_os_error(errno);
S48_GC_PROTECT_1(input_channel);
output_channel = s48_add_channel(S48_CHANNEL_STATUS_OUTPUT,
s48_enter_string("socket connection"),
output_fd);
if (!S48_CHANNEL_P(output_channel)) {
/* input_channel will eventually be closed by the GC */
ps_close_fd(output_fd); /* retries if interrupted */
s48_raise_scheme_exception(s48_extract_fixnum(output_channel), 0); };
S48_GC_UNPROTECT();
return s48_cons(input_channel, output_channel);
}
/*
* Check for errors. If we need to retry we mark the socket as pending
* and return #F to tell the Scheme procedure to wait.
*/
if ((errno != EWOULDBLOCK) && (errno != EINTR) && (errno == EAGAIN))
s48_raise_os_error(errno);
if (! s48_add_pending_fd(socket_fd, TRUE))
s48_raise_out_of_memory_error();
return S48_FALSE;
}
/*
* Given an internet-domain stream socket, a machine name and a port number,
* connect the socket to that machine/port.
*
* If this succeeds, it returns an output channel for the connection.
* If it fails because the connect would block, add the socket to the
* pending queue (for output) and return #f.
* If it fails for any other reason, raise an exception.
*/
static s48_value
s48_connect(s48_value channel, s48_value machine, s48_value port)
{
int socket_fd,
output_fd,
port_number;
char *machine_name;
struct hostent *host;
struct sockaddr_in address;
s48_value output_channel;
S48_CHECK_CHANNEL(channel);
socket_fd = S48_UNSAFE_EXTRACT_FIXNUM(S48_UNSAFE_CHANNEL_OS_INDEX(channel));
S48_CHECK_STRING(machine);
machine_name = S48_UNSAFE_EXTRACT_STRING(machine);
S48_CHECK_FIXNUM(port);
port_number = S48_UNSAFE_EXTRACT_FIXNUM(port);
/*
* Get the host and initialize `address'.
*/
host = gethostbyname(machine_name);
if (host == NULL)
s48_raise_os_error(errno);
memset((void *)&address, 0, sizeof(address));
address.sin_family = host->h_addrtype;
if (host->h_length > sizeof(address.sin_addr))
s48_raise_range_error(s48_enter_fixnum(host->h_length),
S48_UNSAFE_ENTER_FIXNUM(0),
s48_enter_fixnum(sizeof(address.sin_addr)));
memcpy((void *)&address.sin_addr, (void *)host->h_addr, host->h_length);
address.sin_port = htons(port_number);
/*
* Try the connection. If it works we make an output channel and return it.
* The original socket channel will be used as the input channel.
*/
if (connect(socket_fd, (struct sockaddr *)&address, sizeof(address)) >= 0) {
S48_STOB_SET(channel, S48_CHANNEL_STATUS_OFFSET, S48_CHANNEL_STATUS_INPUT);
output_fd = dup(socket_fd);
if (output_fd == -1)
s48_raise_os_error(errno);
output_channel = s48_add_channel(S48_CHANNEL_STATUS_OUTPUT,
s48_enter_string("socket connection"),
output_fd);
if (!S48_CHANNEL_P(output_channel)) {
ps_close_fd(output_fd); /* retries if interrupted */
s48_raise_scheme_exception(s48_extract_fixnum(output_channel), 0); };
return output_channel;
}
/*
* Check for errors. If we need to retry we mark the socket as pending
* and return #F to tell the Scheme procedure to wait.
*/
/* already connected, will raise an error from Scheme */
if (errno == EISCONN)
return S48_TRUE;
if (errno != EWOULDBLOCK && errno != EINTR && errno != EALREADY
&& errno != EINPROGRESS && errno != EAGAIN)
s48_raise_os_error(errno);
if (! (s48_add_pending_fd(socket_fd, FALSE)))
s48_raise_out_of_memory_error();
return S48_FALSE;
}
/*
* Close half of a socket; if `input_p' is true we close the input half,
* otherwise the output half. This horribleness is forced upon us by
* Unix's use of bidirectional file descriptors.
*/
static s48_value
s48_close_socket_half(s48_value channel, s48_value input_p)
{
int socket_fd;
S48_CHECK_CHANNEL(channel);
socket_fd = S48_UNSAFE_EXTRACT_FIXNUM(S48_UNSAFE_CHANNEL_OS_INDEX(channel));
/* We ignore `endpoint is not connected' errors, as we just want to get
the file descriptor closed. */
if ((0 > shutdown(socket_fd, S48_EXTRACT_BOOLEAN(input_p) ? 0 : 1))
&& (errno != ENOTCONN))
s48_raise_os_error(errno);
return S48_TRUE;
}
/*
* Get the name of the local machine.
*/
static s48_value
s48_get_host_name(void)
{
char mbuff[MAXHOSTNAMELEN];
if (gethostname(mbuff, sizeof(mbuff)) < 0)
s48_raise_os_error(errno);
return s48_enter_string(mbuff);
}

12
c/unix/test.c Normal file
View File

@ -0,0 +1,12 @@
#include "c/scheme48.h"
long
frog(long arg_count, long *args)
{
long i, res;
for (i = 0, res = s48_enter_integer(-100); i < arg_count; res += args[i], i++);
return res;
}

2
c/write-barrier.h Normal file
View File

@ -0,0 +1,2 @@
#define S48_WRITE_BARRIER(stob, address, value) ((void)0)

1925
configure vendored Executable file
View File

File diff suppressed because it is too large Load Diff

130
configure.in Normal file
View File

@ -0,0 +1,130 @@
dnl Process this file with autoconf to produce a configure script.
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
LIBS="${LIBS} /usr/posix/usr/lib/libc.a"
fi
])dnl
dnl
dnl Run AC_PROG_CC, but don't accept it's changes to CFLAGS.
dnl For some insane reason, it sets CFLAGS to either `-O' or `-g -O' for gcc.
dnl I don't want the silly -g (because if you are using nlist, you can't strip
dnl the binary), I want -O2 for gcc and -O for other C compilers.
define(S48_PROG_CC, [dnl
oldCFLAGS="$CFLAGS"
AC_PROG_CC
if test "z$oldCFLAGS" = z; then
if test "z$GCC" = z; then
CFLAGS='-O'
else
CFLAGS='-O2'
fi
fi
])dnl
dnl
dnl Linux/ELF systems need the -rdynamic flag when linking so that
dnl dlsym() can find symbols in the executable.
dnl Note, on some Sun's, you can link with -rdynamic but the resulting
dnl a.out always core dumps.
define(S48_RDYNAMIC, [dnl
AC_MSG_CHECKING([link with -rdynamic])
AC_TRY_COMPILE([],
[#if defined(__linux__) && defined(__ELF__)
this must not compile
#endif],
[AC_MSG_RESULT(no)],
[AC_MSG_RESULT(yes)
LDFLAGS="$LDFLAGS -rdynamic"])
])dnl
dnl
define(S48_USCORE, [dnl
AC_MSG_CHECKING([underscore before symbols])
echo 'main() { return 0; } fnord() {}' >conftest.c
if ${CC} ${CFLAGS} ${CPPFLAGS} ${LDFLAGS} conftest.c ${LIBS} &&
nm a.out | grep _fnord >/dev/null; then
AC_MSG_RESULT([yes])
AC_DEFINE(USCORE)
else
AC_MSG_RESULT([no])
fi
rm -f conftest.c a.out
])dnl
dnl
AC_INIT(c/scheme48vm.c)
AC_CONFIG_HEADER(c/sysdep.h)
S48_PROG_CC
AC_ISC_POSIX
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_CHECK_LIB(m, main)
AC_CHECK_LIB(dl, main)
AC_CHECK_LIB(mld, main)
AC_CHECK_LIB(nsl, main)
AC_CHECK_LIB(gen, main)
AC_CHECK_LIB(socket, main)
AC_CHECK_LIB(sun, getpwnam)
dnl Solaris 2.3 seems to need -lelf for nlist(). (tnx Bryan O'Sullivan)
AC_CHECK_LIB(elf, main)
S48_POSIX_LIBC
AC_CONST
AC_RETSIGTYPE
AC_CHECK_HEADERS(libgen.h sys/timeb.h posix/time.h)
AC_CHECK_HEADERS(sys/select.h)
AC_CHECK_FUNCS(gettimeofday ftime nlist select setitimer sigaction)
AC_CHECK_FUNC(dlopen, AC_DEFINE(HAVE_DLOPEN),
AC_CHECK_FUNC(nlist, [LIBOBJS="$LIBOBJS c/fake/libdl1.c],
[LIBOBJS="$LIBOBJS c/fake/libdl2.c]))
AC_CHECK_FUNCS(socket chroot)
AC_CHECK_FUNC(strerror, AC_DEFINE(HAVE_STRERROR),
[LIBOBJS="$LIBOBJS c/fake/strerror.o"])
AC_MSG_CHECKING([n_name])
AC_TRY_LINK([#include <nlist.h>],
[struct nlist name_list;
name_list.n_name = "foo";],
AC_DEFINE(NLIST_HAS_N_NAME)
AC_MSG_RESULT([yes]),
AC_MSG_RESULT([no]))
AC_MSG_CHECKING([__NEXT__])
AC_TRY_LINK(,[
#ifdef __NeXT__
return 0;
#else
fail
#endif
],
CC="$CC -posix"
AC_DEFINE(HAVE_SIGACTION)
AC_MSG_RESULT([yes]),
AC_MSG_RESULT([no]))
S48_USCORE
S48_RDYNAMIC
AC_SUBST(CFLAGS)
AC_SUBST(LIBOBJS)
AC_SUBST(LDFLAGS)
AC_OUTPUT(Makefile)

309
doc/big-scheme.txt Normal file
View File

@ -0,0 +1,309 @@
Documentation for Big Scheme
Big Scheme is a set of generally useful facilities.
Easiest way to access these things:
> ,open big-scheme
Load structure big-scheme (y/n)? y
...
A better way is to use the module system.
-----
Ascii conversions
(CHAR->ASCII <char>) => <integer>
(ASCII->CHAR <integer>) => <char>
These are identical to CHAR->INTEGER and INTEGER->CHAR except that
they use the ASCII encoding.
-----
Bitwise operations
(BITWISE-NOT <integer>) => <integer>
(BITWISE-AND <integer> <integer>) => <integer>
(BITWISE-IOR <integer> <integer>) => <integer>
(BITWISE-XOR <integer> <integer>) => <integer>
These perform various logical operations on integers on a bit-by-bit
basis, using a two's-complement representation.
(ARITHMETIC-SHIFT <integer> <bit-count>) => <integer>
Shift the integer by the given bit count, shifting left for positive
counts and right for negative ones. A two's complement
representation is used.
-----
Hash tables
(MAKE-TABLE) => <table>
(MAKE-STRING-TABLE) => <string-table>
Make a new, empty table. MAKE-TABLE returns a table that uses EQ?
for comparing keys and an ad-hoc hash function. String tables uses
strings for keys.
(MAKE-TABLE-MAKER <comparison-procedure> <hash-procedure>) => <procedure>
Returns a procedure of no arguments that makes tables that use the
given comparison and hash procedures.
(<comparison-procedure> <key1> <key2>) => <boolean>
(<hash-procedure> <key>) => <non-negative-integer>
(TABLE? <x>) => <boolean>
True if <x> is a table.
(TABLE-REF <table> <key>) => <x>
Return the value for <key> in <table>, or #F if there is none.
<key> should be of a type appropriate for <table>.
(TABLE-SET! <table> <key> <value>) => <undefined>
Make <value> be the value of <key> in <table>. <key> should be of a
type appropriate for <table>.
(TABLE-WALK <procedure> <table>) => <undefined>
Apply <procedure>, which must accept two arguments, to every
associated key and value in <table>.
-----
Enumerations
(DEFINE-ENUMERATION <type-name> (<name0> <name1> ...)) *SYNTAX*
Defines <type-name> to be an enumeration with components <name0>
<name1> .... Also defines <type-name>-COUNT to be the number of
components.
(ENUM <type-name> <component-name>) => <integer> *SYNTAX*
Evaluates to the value of <component-name> within the enumeration
<type-name>. For example, if (DEFINE-ENUMERATION COLOR (GREEN
RED)), then (ENUM COLOR GREEN) is zero and (ENUM COLOR RED) is one.
The mapping from name to integer is done at macro-expansion time, so
there is no run-time overhead.
(ENUMERAND->NAME <integer> <enumeration>) => <symbol>
Returns the name associated with <integer> within <enumeration>.
E.g. (ENUMERAND->NAME 1 COLOR) => 'RED.
(NAME->ENUMERAND <symbol> <enumeration>) => <integer>
Returns the integer associated with <symbol> within <enumeration>.
E.g. (ENUMERAND->NAME 'GREEN COLOR) => 0.
-----
Port extensions
(MAKE-TRACKING-INPUT-PORT <input-port>) => <input-port>
(MAKE-TRACKING-OUTPUT-PORT <output-port>) => <output-port>
These return ports that keep track of the current row and column and
are otherwise identical to their arguments.
(MAKE-STRING-INPUT-PORT <string>) => <input-port>
Returns a port that reads characters from the supplied string.
(CALL-WITH-STRING-OUTPUT-PORT <procedure>) => <string>
The procedure is called on a port. When it returns, CALL-WITH-STRING-
OUTPUT-PORT returns a string containing the characters written to the port.
(WRITE-ONE-LINE <output-port> <character-count> <procedure>) => <unspecified>
The procedure is called on an output port. Output written to that
port is copied to <output-port> until <character-count> characters
have been written, at which point WRITE-ONE-LINE returns.
(CURRENT-ROW <port>) => <integer> or #f
(CURRENT-COLUMN <port>) => <integer> or #f
These return the current read or write location of the port. #F is
returned if the port does not keep track of its location.
(FRESH-LINE <output-port>) => <undefined>
Write a newline character to <output-port> if its current column is not 0.
(INPUT-PORT? <any>) => <boolean>
(OUTPUT-PORT? <any>) => <boolean>
These are versions of the standard Scheme predicates that answer true for
extended ports.
-----
Queues
(MAKE-QUEUE) => <queue>
Returns a new, empty queue.
(ENQUEUE! <queue> <x>) => <undefined>
Puts <x> on the queue.
(DEQUEUE! <queue>) => <x>
Removes and returns the first element of the queue.
(QUEUE-EMPTY? <queue>) => <boolean>
True if the queue is empty.
(QUEUE? <x>) => <boolean>
True if <x> is a queue.
(QUEUE->LIST <queue>) => <list>
Returns a list of the elements of the queue, in order.
(QUEUE-LENGTH <queue>) => <integer>
The number of elements currently on the queue.
(DELETE-FROM-QUEUE! <queue> <x>) => <boolean>
Removes the first occurance of <x> from the queue, returning true if
it was found and false otherwise.
-----
Little utility procedures
(ATOM? <any>) => <boolean>
(ATOM? x) == (NOT (PAIR? x))
(NULL-LIST? <list>) => <boolean>
Returns #t for the empty list, #f for a pair, and signals an error
otherwise.
(NEQ? <any> <any>) => <boolean>
(NEQ? x y) is the same as (NOT (EQ? x y)).
(N= <number> <number>) => <boolean>
(N= x y) is the same as (NOT (= x y)).
(IDENTITY <any>) => <any>
(NO-OP <any>) => <any>
These both just return their argument. NO-OP is guaranteed not to
be compiled in-line, IDENTITY may be.
-----
List utilities
(MEMQ? <element> <list>) => <boolean>
Returns true if <element> is in <list>, false otherwise.
(ANY? <predicate> <list>) => <boolean>
Returns true if <predicate> is true for any element of <list>.
(EVERY? <predicate> <list>) => <boolean>
Returns true if <predicate> is true for every element of <list>.
(ANY <predicate> <list>)
(FIRST <predicate> <list>)
ANY returns some element of <list> for which <predicate> is true, or
#F if there are none. FIRST does the same except that it returns
the first element for which <predicate> is true.
(FILTER <predicate> <list>)
(FILTER! <predicate> <list>)
Returns a list containing all of the elements of <list> for which
<predicate> is true. The order of the elements is preserved.
FILTER! may reuse the storage of <list>.
(FILTER-MAP <procedure> <list>)
The same as FILTER except the returned list contains the results of
applying <procedure> instead of elements of <list>. (FILTER-MAP p
l) is the same as (FILTER IDENTITY (MAP p l)).
(PARTITION-LIST <predicate> <list>) => <list> <list>
(PARTITION-LIST! <predicate> <list>) => <list> <list>
The first return value contains those elements <list> for which
<predicate> is true, the second contains the remaining elements.
The order of the elements is preserved. PARTITION-LIST! may resuse
the storage of the <list>.
(REMOVE-DUPLICATES <list>) => <list>
Returns its argument with all duplicate elements removed. The first
instance of each element is preserved.
(DELQ <element> <list>) => <list>
(DELQ! <element> <list>) => <list>
(DELETE <predicate> <list>) => <list>
All three of these return <list> with some elements removed. DELQ
removes all elements EQ? to <element>. DELQ! does the same and may
modify the list argument. DELETE removes all elements for which
<predicate> is true. Both DELQ and DELETE may reuse some of the
storage in the list argument, but won't modify it.
(REVERSE! <list>) => <list>
Destructively reverses <list>.
(SORT-LIST <list> <a<b-procedure>) => <list>
(SORT-LIST! <list> <a<b-procedure>) => <list>
Returns a sorted copy of <list>. The sorting algorithm is stable.
(SORT-LIST '(6 5 1 3 2 4) <) => '(1 2 3 4 5 6)
-----
Additional syntax
(DESTRUCTURE ((<pattern> <init>) ...) <body> ...) *SYNTAX*
The <init>s are evaluated and their values are dissasembled
according to the corresponding patterns, with identifiers in the
patterns being bound to fresh locations holding the corresponding
part, and the body is evaluated in the extended environment.
Patterns may be any of the following:
#f Discard the corresponding part.
<identifier> Bind the <indentifier> to the part.
(<pattern> ...) The part must be a list at least as long as the
pattern.
(<pattern1> ... . <patternN>)
The same thing, except that the final CDR of the
part is dissasembled according to <patternN>.
#(<pattern> ...) The part must be a vector at least as long as the
pattern.
(RECEIVE <identifiers> <exp> <body> ...) *SYNTAX*
=> (CALL-WITH-VALUES (LAMBDA () <exp>) (LAMBDA <identifiers> <body> ...))
Bind <identifiers> to the values returned by <exp>, and evaluate the
body in the resulting environment.
-----
Printing and related procedures
(CONCATENATE-SYMBOL . <components>)
Returns the symbol whose name is produced by concatenating the DISPLAYed
representations of <components>.
(CONCATENATE-SYMBOL 'abc "-" 4) => 'abc-4
(FORMAT <port-spec> <format-string> . <arguments>) => <string> or <undefined>
Prints the arguments to the port as directed by the string. <port-spec>
should be either:
An output port. The output is written directly to the port. The result
of the call to FORMAT is undefined.
#T. The output is written to the current output port. The result of the
call to FORMAT is undefined.
#F. The output is written to a string, which is then the value returned
from the call to FORMAT.
Characters in <format-string> which are not preceded by a ~ are written
directly to the output. Characters preceded by a ~ have the following
meaning (case is irrelevant; ~a and ~A have the same meaning):
~~ prints a single ~
~A prints the next argument using DISPLAY
~D prints the next argument as a decimal number
~S prints the next argument using WRITE
~% prints a newline character
~& prints a NEWLINE character if the previous printed character was not one
(this is implemented using FRESH-LINE)
~? performs a recursive call to FORMAT using the next two arguments as the
string and the list of arguments
(ERROR <format-string> . <format-arguments>)
(BREAKPOINT <format-string> . <format-arguments>)
Signals an error or breakpoint condition, passing it the result of
applying FORMAT to the arguments.
(P <thing>)
(P <thing> <output-port>)
(PRETTY-PRINT <thing> <output-port> <position>)
Pretty-print <thing>. The current output port is used if no port is
specified. <position> is the starting offset. <thing> will be
pretty-printed to the right of this column.
Original by RK, 26 Jan 1993.
Minor changes by JAR, 5 Dec 1993.

4430
doc/external.ps Normal file
View File

File diff suppressed because it is too large Load Diff

290
doc/hacking.txt Normal file
View File

@ -0,0 +1,290 @@
,bench
,load-package linker
,new-package =link= linker debuginfo defpackage
,load scripts.scm
(link-initial-system)
To change between initial image starting in mini-command (MINI) and
command (MAXI):
1. Definition of initial system's command module in comp-packages.scm:
MINI: (make-mini-command scheme)
MAXI: (make-command scheme)
2. Location of (define-module (make-command ...)...):
MINI: more-packages.scm
MAXI: comp-packages.scm
3. Location of (define-interface command-interface ...):
MINI: more-interfaces.scm
MAXI: interfaces.scm
> ,new-package z architecture primitives packages table enumerated debug-data
z> (let ((i 0))
(table-walk (lambda (x y) (set! i (+ i 1)))
location-name-table)
i)
1385
z> (vector-length (find-all-xs (name->enumerand 'location stob)))
1259
(vector-length (find-all-xs (name->enumerand 'record stob)))
2150
(find-all-xs (name->enumerand 'record stob))
z> (do ((i 0 (+ i 1))
(j 0 (if (package? (vector-ref rs i)) (+ j 1) j))) ((= i (vector-length rs)) j))
72
z>
> ,new-package z architecture primitives compiler table
z> (vector-ref stob 10)
'template
z> stob
'#(pair symbol vector closure location port ratio record continuation extended-number template weak-pointer external unused-d-header1 unused-d-header2 string code-vector double bignum)
z> (vector-ref stob 7)
'record
z> (define rs (find-all-xs 7))
z> (vector-length rs)
2178
z> (define ls (find-all-xs 4))
z> (vector-length ls)
1266
z>
To get a fresh config package:
,in config (define-structures ((config1 (export)))
(open defpackage built-in-structures more-structures))
,config-package-is config1
To load a linker with a fresh new compiler:
x48 -i new-scheme48.image -h 10000000 <l.s48
Then ,load scripts.scm or whatever.
These are all files not belonging to any package description:
boot-packages.scm
comp-packages.scm
flatload.scm
more-packages.scm
more-interfaces.scm
rts-packages.scm
scripts.scm
interfaces.scm
infix/
debug/
alt/
link/p-features.scm
link/p-record.scm
link/t-features.scm
link/t-record.scm
misc/icon.scm
misc/mail.scm -- related to more-thread.scm
misc/more-thread.scm -- needs work
misc/sicp.scm -- add to more-packages
,load-package rk-extensions
,new-package rk-user rk-extensions
,user-package-is rk-user
# If initial images starts in mini-command instead of command, the
# rule for $(IMAGE) becomes something like this:
# (echo ,load more-interfaces.scm $(S48ROOT)/more-packages.scm; \
# echo "(ensure-loaded command)"; \
# echo ",go ((structure-ref command 'command-processor) batch)"; \
,in config (define-structures ((reification (export reify-structures)))
(open scheme-level-2 table
signals ;error
packages
features ;location-id location?
scan) ;find-free-names-in-syntax-rules
(files (link reify)))
,load-package reification
debug-config> ,in reification reify-structures
'#{Procedure 8447 reify-structures}
debug-config> (define reify-structures ##)
debug-config> make-simple-package
Error: undefined variable
make-simple-package
(package debug-config)
1 debug-config>
debug-config> (define-structures ((p (export start))) (open initial-system scheme-level-2 packages))
debug-config> (define go (in p `(start ,(reify-structures (desirable-packages) (lambda (loc) `',loc)))))
### Small images for exercising the linker and/or runtime system
debug/tiny.image: debug/tiny.scm $(LINKER_IMAGE)
($(START_LINKER_RUNNABLE) \
echo "(load \"debug/tiny-packages.scm\")"; \
echo "(link-simple-system '(debug tiny) 'start tiny-system)") \
| $(LINKER_RUNNABLE) -i $(LINKER_IMAGE)
debug/little.image: $(LINKER_IMAGE) $(CONFIG_FILES) $(little-files)
($(START_LINKER_RUNNABLE) \
echo "(load \"scripts.scm\")"; \
echo "(link-little-system)") \
| $(LINKER_RUNNABLE) -i $(LINKER_IMAGE) $(BIG_HEAP)
debug/medium.image: $(LINKER_IMAGE) $(CONFIG_FILES) $(medium-files)
($(START_LINKER_RUNNABLE) \
echo "(load \"scripts.scm\")"; \
echo "(link-medium-system)") \
| $(LINKER_RUNNABLE) -i $(LINKER_IMAGE) $(BIG_HEAP)
echo "(define l-f (package-all-filenames little-system))"; \
echo "(define m-f (package-all-filenames medium-system))"; \
'little-files l-f 'medium-files m-f \
[The following is from June 1992, and probably not quite compatible
with the current compiler internals.]
To eliminate use of the stack GC to implement tail recursion, change
comp.scm as follows:
(define (compile-unknown-call exp cenv depth cont)
(note-source-code
exp
(maybe-push-continuation (sequentially
(push-all (cdr exp) cenv 0)
(compile (car exp)
cenv
(length (cdr exp))
(fall-through-cont))
(instruction (if (return-cont? cont)
op/move-args-and-call
op/call)
(length (cdr exp))))
depth
cont)))
--------------------
Here's another cool thing. 6/28/93
(define-interface evaluation-interface
(export eval load eval-from-file))
(define-structure run evaluation-interface
(open scheme-level-2 syntactic packages scan
environments
signals
locations
features ;force-output
table
fluids)
(files (debug run)))
,load-package run
,in run
,in package-commands (environment-for-syntax-promise)
(define cool (make-simple-package (list scheme) eval ## 'cool))
,in command set-environment-for-commands!
(## cool)
cool> ,inspect (lambda (x) x)
'#{Procedure 6394}
[0: exp] '(lambda (x) x)
[1: env] '#{Package 286 cool}
inspect:
inspect: q
cool>
(define (z s)
(define (show-type name static)
(write name)
(display " : ")
(write (static-type static))
(newline))
(if (package? s)
(for-each-definition (lambda (name static loc)
(show-type name static))
s)
(interface-walk (lambda (name type)
(show-type name
(car (structure-lookup
s name #t))))
(structure-interface s))))
; ,open expander syntactic packages reconstruction
(define (e x)
(let ((p (interaction-environment)))
(let ((node (expand-form x p)))
(write (node-type node (package->environment p)))
(newline)
(eval node p))))
> (define hunk3 (lap hunk3
0 (check-nargs= 3)
2 (pop)
3 (make-stored-object 3 0)
6 (return)))
> (hunk3 1 2 3)
'(1 . 2)
> (define cxr (lap cxr
0 (check-nargs= 2)
2 (pop)
3 (stored-object-indexed-ref 0)
5 (return)))
> (cxr (hunk3 1 2 3) 2)
3
>
(define-syntax %cons
(lambda (e r c)
(let ((n (cadr e))
(kind (caddr e)))
`(,(r 'lap) (%cons ,n ,kind)
(check-nargs= ,n)
(pop)
(make-stored-object ,n ,kind)
(return)))))
(define (& x)
(or (node-ref x 'uid)
(begin (set! *n* (+ *n* 1))
(node-set! x 'uid *n*)
*n*))
x)
(define (uid n) (node-ref (& n) 'uid))
(define *n* 0)

690
doc/html/external.html Normal file
View File

@ -0,0 +1,690 @@
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final//EN">
<HTML>
<!-- HTML file produced from file: external.tex --
-- using Hyperlatex v 2.3.1 (c) Otfried Cheong--
-- on Emacs 19.34.1, Tue Feb 23 18:21:44 1999 -->
<HEAD>
<TITLE>Mixing Scheme 48 and C</TITLE>
</HEAD><BODY>
<H1 ALIGN=CENTER>Using C code with Scheme 48</H1>
<H2 ALIGN=CENTER>Mike Sperber<BR><TT><FONT SIZE=-1>sperber@informatik.uni-tuebingen.de</FONT></TT><BR>Richard Kelsey<BR><TT><FONT SIZE=-1>kelsey@research.nj.nec.com</FONT></TT>
</H2>
<H3 ALIGN=CENTER>February 23, 1999</H3>
<H3 ALIGN=CENTER>Abstract</H3>
<BLOCKQUOTE>
This document describes an interface for calling C functions
from Scheme, calling Scheme functions from C, and allocating
storage in the Scheme heap.
These facilities are designed to link
existing C libraries into Scheme&nbsp;48 in order to use them from Scheme.
To this end, Scheme&nbsp;48 manages stub functions in C that
negotiate between the calling conventions of Scheme and C and the
memory allocation policies of both worlds.
No stub generator is available yet, but writing them is a straightforward task.
</BLOCKQUOTE>
<H1><A NAME="1">Available Facilities</A></H1>
<P>The following facilities are available for interfacing between
Scheme&nbsp;48 and C:
<UL><LI>Scheme code can call C functions.
<LI>The external interface provides full introspection for all
Scheme objects. External code may inspect, modify, and allocate
Scheme objects arbitrarily.
<LI>External code may raise exceptions back to Scheme&nbsp;48 to
signal errors.
<LI>External code may call back into Scheme. Scheme&nbsp;48
correctly unrolls the process stack on non-local exits.
<LI>External modules may register bindings of names to values with a
central registry accessible from
Scheme. Conversely, Scheme code can register shared
bindings for access by C code.
</UL>
This document has three parts: the first describes how bindings are
moved from Scheme to C and vice versa, the second tells how to call
C functions from Scheme, and the third covers the C interface
to Scheme objects, including calling Scheme procedures, using the
Scheme heap, and so forth.
<H2><A NAME="2">Scheme structures</A></H2>
<P>The structure <CODE>external-calls</CODE> has
most of the Scheme functions described here.
The others are in
<CODE>dynamic-externals</CODE>, which has the functions for dynamic loading and
name lookup from
the section on <A HREF="#dynamic-externals">Dynamic Loading</A>,
and <CODE>shared-bindings</CODE>, which has the additional shared-binding functions
described in
the section on the <A HREF="#more-shared-bindings">complete shared-binding interface</A>.
<H2><A NAME="3">C naming conventions</A></H2>
<P>The names of all of Scheme&nbsp;48's visible C bindings begin
with `<CODE>s48_</CODE>' (for procedures and variables) or
`<CODE>S48_</CODE>' (for macros).
Whenever a C name is derived from a Scheme identifier, we
replace `<CODE>-</CODE>' with `<CODE>_</CODE>' and convert letters to lowercase
for procedures and uppercase for macros.
A final `<CODE>?</CODE>' converted to `<CODE>_p</CODE>' (`<CODE>_P</CODE>' in C macro names).
A final `<CODE>!</CODE>' is dropped.
Thus the C macro for Scheme's <CODE>pair?</CODE> is <CODE>S48_PAIR_P</CODE> and
the one for <CODE>set-car!</CODE> is <CODE>S48_SET_CAR</CODE>.
Procedures and macros that do not check the types of their arguments
have `<CODE>unsafe</CODE>' in their names.
<P>All of the C functions and macros described have prototypes or definitions
in the file <CODE>c/scheme48.h</CODE>.
The C type for Scheme values is defined there to be <CODE>s48_value</CODE>.
<H1><A NAME="4">Shared bindings</A></H1>
<P>Shared bindings are the means by which named values are shared between Scheme
code and C code.
There are two separate tables of shared bindings, one for values defined in
Scheme and accessed from C and the other for values going the other way.
Shared bindings actually bind names to cells, to allow a name to be looked
up before it has been assigned.
This is necessary because C initialization code may be run before or after
the corresponding Scheme code, depending on whether the Scheme code is in
the resumed image or is run in the current session.
<H2><A NAME="5">Exporting Scheme values to C</A></H2>
<UL><LI><CODE>(define-exported-binding<I>&nbsp;name&nbsp;value</I>)&nbsp;-&gt;&nbsp;<I>shared-binding</I></CODE>
</UL>
<UL><LI><CODE>s48_value s48_get_imported_binding(char *name)</CODE>
<LI><CODE>s48_value S48_SHARED_BINDING_REF(s48_value shared_binding)</CODE>
</UL>
<P><CODE>Define-exported-binding</CODE> makes <CODE><I>value</I></CODE> available to C code
under as <CODE><I>name</I></CODE> which must be a <CODE><I>string</I></CODE>, creating a new shared
binding if necessary.
The C function <CODE>s48_get_imported_binding</CODE> returns the shared binding
defined for <CODE>name</CODE>, again creating it if necessary.
The C macro <CODE>S48_SHARED_BINDING_REF</CODE> dereferences a shared binding,
returning its current value.
<H2><A NAME="6">Exporting C values to Scheme</A></H2>
<UL><LI><CODE>void s48_define_exported_binding(char *name, s48_value value)</CODE>
</UL>
<UL><LI><CODE>(lookup-imported-binding<I>&nbsp;string</I>)&nbsp;-&gt;&nbsp;<I>shared-binding</I></CODE>
<LI><CODE>(shared-binding-ref<I>&nbsp;shared-binding</I>)&nbsp;-&gt;&nbsp;<I>value</I></CODE>
</UL>
<P>These are used to define shared bindings from C and to access them
from Scheme.
Again, if a name is looked up before it has been defined, a new binding is
created for it.
<P>The common case of exporting a C function to Scheme can be done using
the macro <CODE>S48_EXPORT_FUNCTION(<EM>name</EM>)</CODE>.
This expands into
<P><CODE>s48_define_exported_binding("<CODE><I>name</I></CODE>", s48_enter_pointer(<CODE><I>name</I></CODE>))</CODE>
<P>which boxes the function into a Scheme byte vector and then
exports it.
Note that <CODE>s48_enter_pointer</CODE> allocates space in the Scheme heap
and might trigger a
<A HREF="#gc">garbage collection</A>.
<UL><LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
<tr> <td><CODE>(import-definition <CODE><I>name</I></CODE>)</CODE></td> <td align=right>syntax</td></tr></table>
<LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
<tr> <td><CODE>(import-definition <CODE><I>name&nbsp;c-name</I></CODE>)</CODE></td> <td align=right>syntax</td></tr></table>
</UL>
These macros simplify importing definitions from C to Scheme.
They expand into
<P><CODE>(define <CODE><I>name</I></CODE> (lookup-imported-binding <CODE><I>c-name</I></CODE>))</CODE>
<P>where <CODE><I>c-name</I></CODE> is as supplied for the second form.
For the first form <CODE><I>c-name</I></CODE> is derived from <CODE><I>name</I></CODE> by
replacing `<CODE>-</CODE>' with `<CODE>_</CODE>' and converting letters to lowercase.
For example, <CODE>(import-definition my-foo)</CODE> expands into
<P><CODE>(define my-foo (lookup-imported-binding "my_foo"))</CODE>
<H2><A NAME="more-shared-bindings">Complete shared binding interface</A></H2>
<P>There are a number of other Scheme functions related to shared bindings;
these are in the structure <CODE>shared-bindings</CODE>.
<UL><LI><CODE>(shared-binding?<I>&nbsp;x</I>)&nbsp;-&gt;&nbsp;<I>boolean</I></CODE>
<LI><CODE>(shared-binding-name<I>&nbsp;shared-binding</I>)&nbsp;-&gt;&nbsp;<I>string</I></CODE>
<LI><CODE>(shared-binding-is-import?<I>&nbsp;shared-binding</I>)&nbsp;-&gt;&nbsp;<I>boolean</I></CODE>
<LI><CODE>(shared-binding-set!<I>&nbsp;shared-binding&nbsp;value</I>)</CODE>
<LI><CODE>(define-imported-binding<I>&nbsp;string&nbsp;value</I>)</CODE>
<LI><CODE>(lookup-exported-binding<I>&nbsp;string</I>)</CODE>
<LI><CODE>(undefine-imported-binding<I>&nbsp;string</I>)</CODE>
<LI><CODE>(undefine-exported-binding<I>&nbsp;string</I>)</CODE>
</UL>
<P><CODE>Shared-binding?</CODE> is the predicate for shared-bindings.
<CODE>Shared-binding-name</CODE> returns the name of a binding.
<CODE>Shared-binding-is-import?</CODE> is true if the binding was defined from C.
<CODE>Shared-binding-set!</CODE> changes the value of a binding.
<CODE>Define-imported-binding</CODE> and <CODE>lookup-exported-binding</CODE> are
Scheme versions of <CODE>s48_define_exported_binding</CODE>
and <CODE>s48_lookup_imported_binding</CODE>.
The two <CODE>undefine-</CODE> procedures remove bindings from the two tables.
They do nothing if the name is not found in the table.
<P>The following C macros correspond to the Scheme functions above.
<UL><LI><CODE>int S48_SHARED_BINDING_P(x)</CODE>
<LI><CODE>int S48_SHARED_BINDING_IS_IMPORT_P(s48_value s_b)</CODE>
<LI><CODE>s48_value S48_SHARED_BINDING_NAME(s48_value s_b)</CODE>
<LI><CODE>void S48_SHARED_BINDING_SET(s48_value s_b, s48_value value)</CODE>
</UL>
<H1><A NAME="8">Calling C Functions from Scheme</A></H1>
<P>There are three different ways to call C functions from Scheme, depending on
how the C function was obtained.
<UL><LI><CODE>(call-imported-binding<I>&nbsp;binding&nbsp;arg<I><sub>0</sub></I>&nbsp;...</I>)&nbsp;-&gt;&nbsp;<I>value</I></CODE>
<LI><CODE>(call-external<I>&nbsp;external&nbsp;arg<I><sub>0</sub></I>&nbsp;...</I>)&nbsp;-&gt;&nbsp;<I>value</I></CODE>
<LI><CODE>(call-external-value<I>&nbsp;value&nbsp;name&nbsp;arg<I><sub>0</sub></I>&nbsp;...</I>)&nbsp;-&gt;&nbsp;<I>value</I></CODE>
</UL>
Each of these applies its first argument, a C function, to the rest of
the arguments.
For <CODE>call-imported-binding</CODE> the function argument must be an
imported binding.
For <CODE>call-external</CODE> the function argument must be an external
bound in the current process
(see
the section on <A HREF="#dynamic-externals">Dynamic Loading</A>).
For <CODE>call-external-value</CODE> <CODE><I>value</I></CODE> must be a byte vector
whose contents is a pointer to a C function and <CODE><I>name</I></CODE> should be
a string naming the function.
The <CODE><I>name</I></CODE> argument is used only for printing error messages.
<P>For all of these, the C function is passed the <CODE><I>arg<I><sub>i</sub></I></I></CODE> values
and the value returned is that returned by C procedure.
Up to twelve arguments may be passed.
There is no method supplied for returning multiple values to
Scheme from C (or vice versa) (mainly because C does not have multiple return
values).
<P>Keyboard interrupts that occur during a call to a C function are ignored
until the function returns to Scheme (this is clearly a
problem; we are working on a solution).
<UL><LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
<tr> <td><CODE>(import-lambda-definition <CODE><I>name</I></CODE> (<CODE><I>formal</I></CODE> ...))</CODE></td> <td align=right>syntax</td></tr></table>
<LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
<tr> <td><CODE>(import-lambda-definition <CODE><I>name</I></CODE> (<CODE><I>formal</I></CODE> ...) <CODE><I>c-name</I></CODE>)</CODE></td> <td align=right>syntax</td></tr></table>
</UL>
These macros simplify importing functions from C.
They define <CODE><I>name</I></CODE> to be a function with the given formals that
applies those formals to the corresponding C binding.
<CODE><I>C-name</I></CODE>, if supplied, should be a string.
These expand into
<BLOCKQUOTE><PRE>
(define temp (lookup-imported-binding <CODE><I>c-name</I></CODE>))
(define <CODE><I>name</I></CODE>
(lambda (<CODE><I>formal</I></CODE> ...)
(external-apply temp <CODE><I>formal</I></CODE> ...)))
</PRE></BLOCKQUOTE>
<P>
If <CODE><I>c-name</I></CODE> is not supplied, it is derived from <CODE><I>name</I></CODE> by converting
all letters to lowercase and replacing `<CODE>-</CODE>' with `<CODE>_</CODE>'.
<H1><A NAME="9">Adding external modules to the <CODE>Makefile</CODE></A></H1>
<P>Getting access to C bindings from Scheme requires that the C code be
compiled an linked in with the Scheme&nbsp;48 virtual machine and that the
relevent shared-bindings be created.
The Scheme&nbsp;48 makefile has rules for compiling and linking external code
and for specifying initialization functions that should be called on
startup.
There are three Makefile variables that control which external modules are
included in the executable for the virutal machine (<CODE>scheme48vm</CODE>).
<CODE>EXTERNAL_OBJECTS</CODE> lists the object files to be included in
<CODE>scheme48vm</CODE>,
<CODE>EXTERNAL_FLAGS</CODE> is a list of <CODE>ld</CODE> flags to be used when
creating <CODE>scheme48vm</CODE>, and
<CODE>EXTERNAL_INITIALIZERS</CODE> is a list of C procedures to be called
on startup.
The procedures listed in <CODE>EXTERNAL_INITIALIZERS</CODE> should take no
arguments and have a return type of <CODE>void</CODE>.
After changing the definitions of any of these variables you should
do <CODE>make scheme48vm</CODE> to rebuild the virtual machine.
<H1><A NAME="dynamic-externals">Dynamic Loading</A></H1>
<P>External code can be loaded into a running Scheme&nbsp;48 process
and C object-file bindings can be dereferenced at runtime and
their values called
(although not all versions of Unix support all of this).
The required Scheme functions are in the structure <CODE>dynamic-externals</CODE>.
<UL><LI><CODE>(dynamic-load<I>&nbsp;string</I>)</CODE>
</UL>
<CODE>Dynamic-load</CODE> loads the named file into the current
process, raising an exception if the file cannot be found or if dynamic
loading is not supported by the operating system.
The file must have been compiled and linked appropriately.
For Linux, the following commands compile <CODE>foo.c</CODE> into a
file <CODE>foo.so</CODE> that can be loaded dynamically.
<BLOCKQUOTE><PRE>
% gcc -c -o foo.o foo.c
% ld -shared -o foo.so foo.o
</PRE></BLOCKQUOTE>
<UL><LI><CODE>(get-external<I>&nbsp;string</I>)&nbsp;-&gt;&nbsp;<I>external</I></CODE>
<LI><CODE>(external?<I>&nbsp;x</I>)&nbsp;-&gt;&nbsp;<I>boolean</I></CODE>
<LI><CODE>(external-name<I>&nbsp;external</I>)&nbsp;-&gt;&nbsp;<I>string</I></CODE>
<LI><CODE>(external-value<I>&nbsp;external</I>)&nbsp;-&gt;&nbsp;<I>byte-vector</I></CODE>
</UL>
These functions give access to values bound in the current process, and
are used for retrieving values from dynamically-loaded files.
<CODE>Get-external</CODE> returns an <I>external</I> object that contains the
value of <CODE><I>name</I></CODE>, raising an exception if there is no such
value in the current process.
<CODE>External?</CODE> is the predicate for externals, and
<CODE>external-name</CODE> and <CODE>external-value</CODE> return the name and
value of an external.
The value is returned as byte vector of length four (on 32-bit
architectures).
The value is that which was extant when <CODE>get-external</CODE> was
called.
The following two functions can be used to update the values of
externals.
<UL><LI><CODE>(lookup-external<I>&nbsp;external</I>)&nbsp;-&gt;&nbsp;<I>boolean</I></CODE>
<LI><CODE>(lookup-all-externals<I></I>)&nbsp;-&gt;&nbsp;<I>boolean</I></CODE>
</UL>
<CODE>Lookup-external</CODE> updates the value of <CODE><I>external</I></CODE> by looking its
name in the current process, returning <CODE>#t</CODE> if it is bound and <CODE>#f</CODE>
if it is not.
<CODE>Lookup-all-externals</CODE> calls <CODE>lookup-external</CODE> on all extant
externals, returning <CODE>#f</CODE> any are unbound.
<UL><LI><CODE>(call-external<I>&nbsp;external&nbsp;arg<I><sub>0</sub></I>&nbsp;...</I>)&nbsp;-&gt;&nbsp;<I>value</I></CODE>
</UL>
An external whose value is a C procedure can be called using
<CODE>call-external</CODE>.
See
the section on <A HREF="#8">calling C functions from Scheme</A>
for more information.
<P>In some versions of Unix retrieving a value from the current
process may require a non-trivial amount of computation.
We recommend that a dynamically-loaded file contain a single initialization
procedure that creates shared bindings for the values exported by the file.
<H1><A NAME="11">Compatibility</A></H1>
<P>Scheme&nbsp;48's old <CODE>external-call</CODE> function is still available in the structure
<CODE>externals</CODE>, which now also includes <CODE>external-name</CODE> and
<CODE>external-value</CODE>.
The old <CODE>scheme48.h</CODE> file has been renamed <CODE>old-scheme48.h</CODE>.
<H1><A NAME="12">Accessing Scheme data from C</A></H1>
<P>The C header file <CODE>scheme48.h</CODE> provides
access to Scheme&nbsp;48 data structures
(for compatibility, the old <CODE>scheme48.h</CODE> file is available
as <CODE>old-scheme48.h</CODE>).
The type <CODE>s48_value</CODE> is used for Scheme values.
When the type of a value is known, such as the integer returned
by <CODE>vector-length</CODE> or the boolean returned by <CODE>pair?</CODE>,
the corresponding C procedure returns a C value of the appropriate
type, and not a <CODE>s48_value</CODE>.
Predicates return <CODE>1</CODE> for true and <CODE>0</CODE> for false.
<H2><A NAME="13">Constants</A></H2>
<P>The following macros denote Scheme constants:
<DL><DT><B><CODE>S48_FALSE</CODE></B><DD> is <CODE>#f</CODE>.
<DT><B><CODE>S48_TRUE</CODE></B><DD> is <CODE>#t</CODE>.
<DT><B><CODE>S48_NULL</CODE></B><DD> is the empty list.
<DT><B><CODE>S48_UNSPECIFIC</CODE></B><DD> is a value used for functions which have no
meaningful return value
(in Scheme this value returned by the nullary procedure <CODE>unspecific</CODE>
in the structure <CODE>util</CODE>).
<DT><B><CODE>S48_EOF</CODE></B><DD> is the end-of-file object
(in Scheme this value is returned by the nullary procedure <CODE>eof-object</CODE>
in the structure <CODE>i/o-internal</CODE>).
</DL>
<H2><A NAME="14">Converting values</A></H2>
<P>The following functions convert values between Scheme and C
representations.
The `extract' ones convert from Scheme to C and the `enter's go the other
way.
<UL><LI><CODE>unsigned char s48_extract_char(s48_value)</CODE>
<LI><CODE>char * s48_extract_string(s48_value)</CODE>
<LI><CODE>long s48_extract_integer(s48_value)</CODE>
<LI><CODE>double s48_extract_double(s48_value)</CODE>
<LI><CODE>s48_value s48_enter_char(unsigned char)</CODE>
<LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
<tr> <td><CODE>s48_value s48_enter_string(char *)</CODE></td> <td align=right>(may GC)</td></tr></table>
<LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
<tr> <td><CODE>s48_value s48_enter_integer(long)</CODE></td> <td align=right>(may GC)</td></tr></table>
<LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
<tr> <td><CODE>s48_value s48_enter_double(double)</CODE></td> <td align=right>(may GC)</td></tr></table>
</UL>
<P>The value returned by <CODE>s48_extract_string</CODE> points to the actual
storage used by the string; it is valid only until the next
<A HREF="#gc">garbage collection</A>.
<P><CODE>s48_enter_integer()</CODE> needs to allocate storage when
its argument is too large to fit in a Scheme&nbsp;48 fixnum.
In cases where the number is known to fit within a fixnum (currently 30 bits
including the sign), the following procedures can be used.
These have the disadvantage of only having a limited range, but
the advantage of never causing a garbage collection.
<UL><LI><CODE>long s48_extract_fixnum(s48_value)</CODE>
<LI><CODE>s48_value s48_enter_fixnum(long)</CODE>
<LI><CODE>long S48_MAX_FIXNUM_VALUE</CODE>
<LI><CODE>long S48_MIN_FIXNUM_VALUE</CODE>
</UL>
<P>An error is signalled if <CODE>s48_extract_fixnum</CODE>'s argument
is not a fixnum or if the argument to <CODE>s48_enter_fixnum</CODE> is less than
<CODE>S48_MIN_FIXNUM_VALUE</CODE> or greater than <CODE>S48_MAX_FIXNUM_VALUE</CODE>
(<I>-2<sup>29</sup></I> and <I>2<sup>29</sup>-1</I> in the current system).
<H2><A NAME="15">C versions of Scheme procedures</A></H2>
<P>The following macros and procedures are C versions of Scheme procedures.
The names were derived by replacing `<CODE>-</CODE>' with `<CODE>_</CODE>',
`<CODE>?</CODE>' with `<CODE>p</CODE>', and dropping `<CODE>!</CODE>.
<UL><LI><CODE>int S48_EQ_P(s48_value)</CODE>
<LI><CODE>int S48_CHAR_P(s48_value)</CODE>
<LI><CODE>int S48_INTEGER_P(s48_value)</CODE>
</UL>
<UL><LI><CODE>int S48_PAIR_P(s48_value)</CODE>
<LI><CODE>s48_value S48_CAR(s48_value)</CODE>
<LI><CODE>s48_value S48_CDR(s48_value)</CODE>
<LI><CODE>void S48_SET_CAR(s48_value, s48_value)</CODE>
<LI><CODE>void S48_SET_CDR(s48_value, s48_value)</CODE>
<LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
<tr> <td><CODE>s48_value s48_cons(s48_value, s48_value)</CODE></td> <td align=right>(may GC)</td></tr></table>
<LI><CODE>long s48_length(s48_value)</CODE>
</UL>
<UL><LI><CODE>int S48_VECTOR_P(s48_value)</CODE>
<LI><CODE>long S48_VECTOR_LENGTH(s48_value)</CODE>
<LI><CODE>s48_value S48_VECTOR_REF(s48_value, long)</CODE>
<LI><CODE>void S48_VECTOR_SET(s48_value, long, s48_value)</CODE>
<LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
<tr> <td><CODE>s48_value s48_make_vector(long, s48_value)</CODE></td> <td align=right>(may GC)</td></tr></table>
</UL>
<UL><LI><CODE>int S48_STRING_P(s48_value)</CODE>
<LI><CODE>long S48_STRING_LENGTH(s48_value)</CODE>
<LI><CODE>char S48_STRING_REF(s48_value, long)</CODE>
<LI><CODE>void S48_STRING_SET(s48_value, long, char)</CODE>
<LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
<tr> <td><CODE>s48_value s48_make_string(long, char)</CODE></td> <td align=right>(may GC)</td></tr></table>
</UL>
<UL><LI><CODE>int S48_SYMBOL_P(s48_value)</CODE>
<LI><CODE>s48_value s48_SYMBOL_TO_STRING(s48_value)</CODE>
</UL>
<UL><LI><CODE>int S48_BYTE_VECTOR_P(s48_value)</CODE>
<LI><CODE>long S48_BYTE_VECTOR_LENGTH(s48_value)</CODE>
<LI><CODE>char S48_BYTE_VECTOR_REF(s48_value, long)</CODE>
<LI><CODE>void S48_BYTE_VECTOR_SET(s48_value, long, int)</CODE>
<LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
<tr> <td><CODE>s48_value s48_make_byte_vector(long, int)</CODE></td> <td align=right>(may GC)</td></tr></table>
</UL>
<H1><A NAME="16">Calling Scheme functions from C</A></H1>
<P>External code that has been called from Scheme can call back to Scheme
procedures using the following function.
<UL><LI><CODE>scheme_value s48_call_scheme(s48_value proc, long nargs, ...)</CODE>
</UL>
This calls the Scheme procedure <CODE>proc</CODE> on <CODE>nargs</CODE>
arguments, which are passed as additional arguments to <CODE>s48_call_scheme</CODE>.
There may be at most ten arguments.
The value returned by the Scheme procedure is returned by the C procedure.
Invoking any Scheme procedure may potentially cause a garbage collection.
<P>There are some complications that occur when mixing calls from C to Scheme
with continuations and threads.
C only supports downward continuations (via <CODE>longjmp()</CODE>).
Scheme continuations that capture a portion of the C stack have to follow the
same restriction.
For example, suppose Scheme procedure <CODE>s0</CODE> captures continuation <CODE>a</CODE>
and then calls C procedure <CODE>c0</CODE>, which in turn calls Scheme procedure
<CODE>s1</CODE>.
Procedure <CODE>s1</CODE> can safely call the continuation <CODE>a</CODE>, because that
is a downward use.
When <CODE>a</CODE> is called Scheme&nbsp;48 will remove the portion of the C stack used
by the call to <CODE>c0</CODE>.
On the other hand, if <CODE>s1</CODE> captures a continuation, that continuation
cannot be used from <CODE>s0</CODE>, because by the time control returns to
<CODE>s0</CODE> the C stack used by <CODE>c0</CODE> will no longer be valid.
An attempt to invoke an upward continuation that is closed over a portion
of the C stack will raise an exception.
<P>In Scheme&nbsp;48 threads are implemented using continuations, so the downward
restriction applies to them as well.
An attempt to return from Scheme to C at a time when the appropriate
C frame is not on top of the C stack will cause the current thread to
block until the frame is available.
For example, suppose thread <CODE>t0</CODE> calls a C procedure which calls back
to Scheme, at which point control switches to thread <CODE>t1</CODE>, which also
calls C and then back to Scheme.
At this point both <CODE>t0</CODE> and <CODE>t1</CODE> have active calls to C on the
C stack, with <CODE>t1</CODE>'s C frame above <CODE>t0</CODE>'s.
If thread <CODE>t0</CODE> attempts to return from Scheme to C it will block,
as its frame is not accessable.
Once <CODE>t1</CODE> has returned to C and from there to Scheme, <CODE>t0</CODE> will
be able to resume.
The return to Scheme is required because context switches can only occur while
C code is running.
<CODE>T0</CODE> will also be able to resume if <CODE>t1</CODE> uses a continuation to
throw past its call to C.
<H1><A NAME="gc">Interacting with the Scheme Heap</A></H1>
<P>Scheme&nbsp;48 uses a copying, precise garbage collector.
Any procedure that allocates objects within the Scheme&nbsp;48 heap may trigger
a garbage collection.
Variables bound to values in the Scheme&nbsp;48 heap need to be registered with
the garbage collector so that the value will be retained and so that the
variables will be updated if the garbage collector moves the object.
The garbage collector has no facility for updating pointers to the interiors
of objects, so such pointers, for example the ones returned by
<CODE>EXTRACT_STRING</CODE>, will likely become invalid when a garbage collection
occurs.
<H2><A NAME="18">Registering Objects with the GC</A></H2>
<P>A set of macros are used to manage the registration of local variables with the
garbage collector.
<UL><LI><CODE>S48_DECLARE_GC_PROTECT(<I>n</I>)</CODE>
<LI><CODE>void S48_GC_PROTECT_<I>n</I>(s48_value<I><sub>1</sub></I>, <I>...</I>, s48_value<I><sub>n</sub></I>)</CODE>
<LI><CODE>void S48_GC_UNPROTECT()</CODE>
</UL>
<P><CODE>S48_DECLARE_GC_PROTECT(<I>n</I>)</CODE>, where <I>1 &lt;= n &lt;= 9</I>, allocates
storage for registering <I>n</I> variables.
At most one use of <CODE>S48_DECLARE_GC_PROTECT</CODE> may occur in a block.
<CODE>S48_GC_PROTECT_<I>n</I>(<I>v<sub>1</sub></I>, <I>...</I>, <I>v<sub>n</sub></I>)</CODE> registers the
<I>n</I> variables (l-values) with the garbage collector.
It must be within scope of a <CODE>S48_DECLARE_GC_PROTECT(<I>n</I>)</CODE>
and be before any code which can cause a GC.
<CODE>S48_GC_UNPROTECT</CODE> removes the block's protected variables from
the garbage collectors list.
It must be called at the end of the block after
any code which may cause a garbage collection.
Omitting any of the three may cause serious and
hard-to-debug problems.
Notably, the garbage collector may relocate an object and
invalidate <CODE>s48_value</CODE> variables which are not protected.
<P>A <CODE>gc-protection-mismatch</CODE> exception is raised if, when a C
procedure returns to Scheme, the calls
to <CODE>S48_GC_PROTECT()</CODE> have not been matched by an equal number of
calls to <CODE>S48_GC_UNPROTECT()</CODE>.
<P>Global variables may also be registered with the garbage collector.
<UL><LI><CODE>void S48_GC_PROTECT_GLOBAL(<CODE><I>value</I></CODE>)</CODE>
</UL>
<P><CODE>S48_GC_PROTECT_GLOBAL</CODE> permanently registers the
variable <CODE><I>value</I></CODE> (an l-value) with the garbage collector.
There is no way to unregister the variable.
<H2><A NAME="19">Keeping C data structures in the Scheme heap</A></H2>
<P>C data structures can be kept in the Scheme heap by embedding them
inside byte vectors.
The following macros can be used to create and access embedded C objects.
<UL><LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
<tr> <td><CODE>s48_value S48_MAKE_VALUE(type)</CODE></td> <td align=right>(may GC)</td></tr></table>
<LI><CODE>type S48_EXTRACT_VALUE(s48_value, type)</CODE>
<LI><CODE>type * S48_EXTRACT_VALUE_POINTER(s48_value, type)</CODE>
<LI><CODE>void S48_SET_VALUE(s48_value, type, value)</CODE>
</UL>
<P><CODE>S48_MAKE_VALUE</CODE> makes a byte vector large enough to hold an object
whose type is <CODE><I>type</I></CODE>.
<CODE>S48_EXTRACT_VALUE</CODE> returns the contents of a byte vector cast to
<CODE><I>type</I></CODE>, and <CODE>S48_EXTRACT_VALUE_POINTER</CODE> returns a pointer
to the contents of the byte vector.
The value returned by <CODE>S48_EXTRACT_VALUE_POINTER</CODE> is valid only until
the next <A HREF="#gc">garbage collection</A>.
<P><CODE>S48_SET_VALUE</CODE> stores <CODE>value</CODE> into the byte vector.
<H2><A NAME="20">C code and heap images</A></H2>
<P>Scheme&nbsp;48 uses dumped heap images to restore a previous system state.
The Scheme&nbsp;48 heap is written into a file in a machine-independent and
operating-system-independent format.
The procedures described above may be used to create objects in the
Scheme heap that contain information specific to the current
machine, operating system, or process.
A heap image containing such objects may not work correctly on
when resumed.
<P>To address this problem, a record type may be given a `resumer'
procedure.
On startup, the resumer procedure for a type is applied to each record of
that type in the image being restarted.
This procedure can update the record in a manner appropriate to
the machine, operating system, or process used to resume the
image.
<UL><LI><CODE>(define-record-resumer<I>&nbsp;record-type&nbsp;procedure</I>)</CODE>
</UL>
<P><CODE>Define-record-resumer</CODE> defines <CODE><I>procedure</I></CODE>,
which should accept one argument, to be the resumer for
<I>record-type</I>.
The order in which resumer procedures are called is not specified.
<P>The <CODE><I>procedure</I></CODE> argument to <CODE>define-record-resumer</CODE> may
be <CODE>#f</CODE>, in which case records of the given type are
not written out in heap images.
When writing a heap image any reference to such a record is replaced by
the value of the record's first field, and an exception is raised
after the image is written.
<H1><A NAME="21">Using Scheme records in C code</A></H1>
<P>External modules can create records and access their slots
positionally.
<UL><LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
<tr> <td><CODE>s48_value S48_MAKE_RECORD(s48_value)</CODE></td> <td align=right>(may GC)</td></tr></table>
<LI><CODE>int S48_RECORD_P(s48_value)</CODE>
<LI><CODE>s48_value S48_RECORD_TYPE(s48_value)</CODE>
<LI><CODE>s48_value S48_RECORD_REF(s48_value, long)</CODE>
<LI><CODE>void S48_RECORD_SET(s48_value, long, s48_value)</CODE>
</UL>
The argument to <CODE>S48_MAKE_RECORD</CODE> should be a shared binding
whose value is a record type.
In C the fields of Scheme records are only accessible via offsets,
with the first field having offset zero, the second offset one, and
so forth.
If the order of the fields is changed in the Scheme definition of the
record type the C code must be updated as well.
<P>For example, given the following record-type definition
<BLOCKQUOTE><PRE>
(define-record-type thing :thing
(make-thing a b)
thing?
(a thing-a)
(b thing-b))
</PRE></BLOCKQUOTE>
the identifier <CODE>:thing</CODE> is bound to the record type and can
be exported to C:
<BLOCKQUOTE><PRE>
(define-exported-binding "thing-record-type" :thing)
</PRE></BLOCKQUOTE>
<CODE>Thing</CODE> records can then be made in C:
<BLOCKQUOTE><PRE>
static scheme_value thing_record_type_binding = SCHFALSE;
void initialize_things(void)
{
S48_GC_PROTECT_GLOBAL(thing_record_type_binding);
thing_record_type_binding =
s48_get_imported_binding("thing-record-type");
}
scheme_value make_thing(scheme_value a, scheme_value b)
{
s48_value thing;
s48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2(a, b);
thing = s48_make_record(thing_record_type_binding);
S48_RECORD_SET(thing, 0, a);
S48_RECORD_SET(thing, 1, b);
S48_GC_UNPROTECT();
return thing;
}
</PRE></BLOCKQUOTE>
Note that the variables <CODE>a</CODE> and <CODE>b</CODE> must be protected
against the possibility of a garbage collection occuring during
the call to <CODE>s48_make_record()</CODE>.
<H1><A NAME="22">Raising exceptions from external code</A></H1>
<P>The following macros explicitly raise certain errors, immediately
returning to Scheme&nbsp;48.
Raising an exception performs all
necessary clean-up actions to properly return to Scheme&nbsp;48, including
adjusting the stack of protected variables.
<UL><LI><CODE>s48_raise_scheme_exception(int type, int nargs, ...)</CODE>
</UL>
<P><CODE>s48_raise_scheme_exception</CODE> is the base procedure for
raising exceptions.
<CODE>type</CODE> is the type of exception, and should be one of the
<CODE>S48_EXCEPTION_</CODE>...constants defined in <CODE>scheme48arch.h</CODE>.
<CODE>nargs</CODE> is the number of additional values to be included in the
exception; these follow the <CODE>nargs</CODE> argument and should all have
type <CODE>s48_value</CODE>.
<CODE>s48_raise_scheme_exception</CODE> never returns.
<P>The following procedures are available for raising particular
types of exceptions.
Like <CODE>s48_raise_scheme_exception</CODE> these never return.
<UL><LI><CODE>s48_raise_argument_type_error(scheme_value)</CODE>
<LI><CODE>s48_raise_argument_number_error(int nargs, int min, int max)</CODE>
<LI><CODE>s48_raise_index_range_error(long value, long min, long max)</CODE>
<LI><CODE>s48_raise_closed_channel_error()</CODE>
<LI><CODE>s48_raise_os_error(int errno)</CODE>
<LI><CODE>s48_raise_out_of_memory_error()</CODE>
</UL>
<P>An argument type error indicates that the given value is of the wrong
type.
An argument number error is raised when the number of arguments, <CODE>nargs</CODE>,
should be, but isn't, between <CODE>min</CODE> and <CODE>max</CODE>, inclusive.
Similarly, and index range error is raised when <CODE>value</CODE> is not between
between <CODE>min</CODE> and <CODE>max</CODE>, inclusive.
<P>The following macros raise argument type errors if their argument does not
have the required type.
<UL><LI><CODE>void S48_CHECK_SYMBOL(s48_value)</CODE>
<LI><CODE>void S48_CHECK_PAIR(s48_value)</CODE>
<LI><CODE>void S48_CHECK_STRING(s48_value)</CODE>
<LI><CODE>void S48_CHECK_INTEGER(s48_value)</CODE>
<LI><CODE>void S48_CHECK_CHANNEL(s48_value)</CODE>
<LI><CODE>void S48_CHECK_BYTE_VECTOR(s48_value)</CODE>
<LI><CODE>void S48_CHECK_RECORD(s48_value)</CODE>
<LI><CODE>void S48_CHECK_SHARED_BINDING(s48_value)</CODE>
</UL>
<H1><A NAME="23">Unsafe functions and macros</A></H1>
<P>All of the C procedures and macros described above check that their
arguments have the appropriate types and that indexes are in range.
The following procedures and macros are identical to those described
above, except that they do not perform type and range checks.
They are provided for the purpose of writing more efficient code;
their general use is not recommended.
<UL><LI><CODE>char S48_UNSAFE_EXTRACT_CHAR(s48_value)</CODE>
<LI><CODE>char * S48_UNSAFE_EXTRACT_STRING(s48_value)</CODE>
<LI><CODE>long S48_UNSAFE_EXTRACT_INTEGER(s48_value)</CODE>
<LI><CODE>long S48_UNSAFE_EXTRACT_DOUBLE(s48_value)</CODE>
</UL>
<UL><LI><CODE>long S48_UNSAFE_EXTRACT_FIXNUM(s48_value)</CODE>
<LI><CODE>s48_value S48_UNSAFE_ENTER_FIXNUM(long)</CODE>
</UL>
<UL><LI><CODE>s48_value S48_UNSAFE_CAR(s48_value)</CODE>
<LI><CODE>s48_value S48_UNSAFE_CDR(s48_value)</CODE>
<LI><CODE>void S48_UNSAFE_SET_CAR(s48_value, s48_value)</CODE>
<LI><CODE>void S48_UNSAFE_SET_CDR(s48_value, s48_value)</CODE>
</UL>
<UL><LI><CODE>long S48_UNSAFE_VECTOR_LENGTH(s48_value)</CODE>
<LI><CODE>s48_value S48_UNSAFE_VECTOR_REF(s48_value, long)</CODE>
<LI><CODE>void S48_UNSAFE_VECTOR_SET(s48_value, long, s48_value)</CODE>
</UL>
<UL><LI><CODE>long S48_UNSAFE_STRING_LENGTH(s48_value)</CODE>
<LI><CODE>char S48_UNSAFE_STRING_REF(s48_value, long)</CODE>
<LI><CODE>void S48_UNSAFE_STRING_SET(s48_value, long, char)</CODE>
</UL>
<UL><LI><CODE>s48_value S48_UNSAFE_SYMBOL_TO_STRING(s48_value)</CODE>
</UL>
<UL><LI><CODE>long S48_UNSAFE_BYTE_VECTOR_LENGTH(s48_value)</CODE>
<LI><CODE>char S48_UNSAFE_BYTE_VECTOR_REF(s48_value, long)</CODE>
<LI><CODE>void S48_UNSAFE_BYTE_VECTOR_SET(s48_value, long, int)</CODE>
</UL>
<UL><LI><CODE>s48_value S48_UNSAFE_SHARED_BINDING_REF(s48_value s_b)</CODE>
<LI><CODE>int S48_UNSAFE_SHARED_BINDING_P(x)</CODE>
<LI><CODE>int S48_UNSAFE_SHARED_BINDING_IS_IMPORT_P(s48_value s_b)</CODE>
<LI><CODE>s48_value S48_UNSAFE_SHARED_BINDING_NAME(s48_value s_b)</CODE>
<LI><CODE>void S48_UNSAFE_SHARED_BINDING_SET(s48_value s_b, s48_value value)</CODE>
</UL>
<UL><LI><CODE>s48_value S48_UNSAFE_RECORD_TYPE(s48_value)</CODE>
<LI><CODE>s48_value S48_UNSAFE_RECORD_REF(s48_value, long)</CODE>
<LI><CODE>void S48_UNSAFE_RECORD_SET(s48_value, long, s48_value)</CODE>
</UL>
<UL><LI><CODE>type S48_UNSAFE_EXTRACT_VALUE(s48_value, type)</CODE>
<LI><CODE>type * S48_UNSAFE_EXTRACT_VALUE_POINTER(s48_value, type)</CODE>
<LI><CODE>void S48_UNSAFE_SET_VALUE(s48_value, type, value)</CODE>
</UL>
<HR ><ADDRESS><a href="http://www-pu.informatik.uni-tuebingen.de/users/sperber/">Mike
Sperber</a>, <a href="http://www.neci.nj.nec.com/homepages/kelsey/">Richard Kelsey</a></ADDRESS><BR>
</BODY></HTML>

315
doc/html/utilities.html Normal file
View File

@ -0,0 +1,315 @@
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final//EN">
<HTML>
<!-- HTML file produced from file: utilities.tex --
-- using Hyperlatex v 2.3.1 (c) Otfried Cheong--
-- on Emacs 19.34.1, Tue Feb 23 18:25:11 1999 -->
<HEAD>
<TITLE>Untitled</TITLE>
</HEAD><BODY>
<H1 ALIGN=CENTER>Scheme 48 User's Guide</H1>
<H2 ALIGN=CENTER>Richard A. Kelsey</H2>
<H3 ALIGN=CENTER>February 23, 1999</H3>
<H1><A NAME="1">ASCII character encoding</A></H1>
<P>These are in the structure <CODE>ascii</CODE>.
<UL><LI><CODE>(char-&gt;ascii<VAR> char</VAR>)&nbsp;-&gt;&nbsp;<VAR>integer</VAR></CODE>
<LI><CODE>(ascii-&gt;char<VAR> integer</VAR>)&nbsp;-&gt;&nbsp;<VAR>char</VAR></CODE>
</UL>
These are identical to <CODE>char-&gt;integer</CODE> and <CODE>integer-&gt;char</CODE> except that
they use the ASCII encoding.
<UL><LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
<tr> <td><CODE>ascii-limit</CODE></td> <td align=right>integer</td></tr></table>
<LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
<tr> <td><CODE>ascii-whitespaces</CODE></td> <td align=right>list of integers</td></tr></table>
</UL>
<CODE>Ascii-limit</CODE> is one more than the largest value that <CODE>char-&gt;ascii</CODE>
may return.
<CODE>Ascii-whitespaces</CODE> is a list of the ASCII values of whitespace characters
(space, tab, line feed, form feed, and carriage return).
<H1><A NAME="2">Bitwise integer operations</A></H1>
<P>These functions use the two's-complement representation for integers.
There is no limit to the number of bits in an integer.
They are in the structures <CODE>bitwise</CODE> and <CODE>big-scheme</CODE>.
<UL><LI><CODE>(bitwise-and<VAR> integer integer</VAR>)&nbsp;-&gt;&nbsp;<VAR>integer</VAR></CODE>
<LI><CODE>(bitwise-ior<VAR> integer integer</VAR>)&nbsp;-&gt;&nbsp;<VAR>integer</VAR></CODE>
<LI><CODE>(bitwise-xor<VAR> integer integer</VAR>)&nbsp;-&gt;&nbsp;<VAR>integer</VAR></CODE>
<LI><CODE>(bitwise-not<VAR> integer</VAR>)&nbsp;-&gt;&nbsp;<VAR>integer</VAR></CODE>
</UL>
These perform various logical operations on integers on a bit-by-bit
basis. `<CODE>ior</CODE>' is inclusive OR and `<CODE>xor</CODE>' is exclusive OR.
<UL><LI><CODE>(arithmetic-shift<VAR> integer bit-count</VAR>)&nbsp;-&gt;&nbsp;<VAR>integer</VAR></CODE>
</UL>
Shifts the integer by the given bit count, which must be an integer,
shifting left for positive counts and right for negative ones.
Shifting preserves the integer's sign.
<H1><A NAME="3">Arrays</A></H1>
<P>These are N-dimensional, zero-based arrays and
are in the structure <CODE>arrays</CODE>.
<P>The array interface is derived from one written by Alan Bawden.
<UL><LI><CODE>(make-array<VAR> value dimension<I><sub>0</sub></I> ...</VAR>)&nbsp;-&gt;&nbsp;<VAR>array</VAR></CODE>
<LI><CODE>(array<VAR> dimensions element<I><sub>0</sub></I> ...</VAR>)&nbsp;-&gt;&nbsp;<VAR>array</VAR></CODE>
<LI><CODE>(copy-array<VAR> array</VAR>)&nbsp;-&gt;&nbsp;<VAR>array</VAR></CODE>
</UL>
<CODE>Make-array</CODE> makes a new array with the given dimensions, each of which
must be a non-negative integer.
Every element is initially set to <CODE><VAR>value</VAR></CODE>.
<CODE>Array</CODE> Returns a new array with the given dimensions and elements.
<CODE><VAR>Dimensions</VAR></CODE> must be a list of non-negative integers,
The number of elements should be the equal to the product of the
dimensions.
The elements are stored in row-major order.
<BLOCKQUOTE><PRE>
(make-array 'a 2 3) <CODE>-&gt;</CODE> {Array 2 3}
(array '(2 3) 'a 'b 'c 'd 'e 'f)
<CODE>-&gt;</CODE> {Array 2 3}
</PRE></BLOCKQUOTE>
<P><CODE>Copy-array</CODE> returns a copy of <CODE><VAR>array</VAR></CODE>.
The copy is identical to the <CODE><VAR>array</VAR></CODE> but does not share storage with it.
<UL><LI><CODE>(array?<VAR> value</VAR>)&nbsp;-&gt;&nbsp;<VAR>boolean</VAR></CODE>
</UL>
Returns <CODE>#t</CODE> if <CODE><VAR>value</VAR></CODE> is an array.
<UL><LI><CODE>(array-ref<VAR> array index<I><sub>0</sub></I> ...</VAR>)&nbsp;-&gt;&nbsp;<VAR>value</VAR></CODE>
<LI><CODE>(array-set!<VAR> array value index<I><sub>0</sub></I> ...</VAR>)</CODE>
<LI><CODE>(array-&gt;vector<VAR> array</VAR>)&nbsp;-&gt;&nbsp;<VAR>vector</VAR></CODE>
<LI><CODE>(array-dimensions<VAR> array</VAR>)&nbsp;-&gt;&nbsp;<VAR>list</VAR></CODE>
</UL>
<CODE>Array-ref</CODE> returns the specified array element and <CODE>array-set!</CODE>
replaces the element with <CODE><VAR>value</VAR></CODE>.
<BLOCKQUOTE><PRE>
(let ((a (array '(2 3) 'a 'b 'c 'd 'e 'f)))
(let ((x (array-ref a 0 1)))
(array-set! a 'g 0 1)
(list x (array-ref a 0 1))))
<CODE>-&gt;</CODE> '(b g)
</PRE></BLOCKQUOTE>
<P><CODE>Array-&gt;vector</CODE> returns a vector containing the elements of <CODE><VAR>array</VAR></CODE>
in row-major order.
<CODE>Array-dimensions</CODE> returns the dimensions of
the array as a list.
<UL><LI><CODE>(make-shared-array<VAR> array linear-map dimension<I><sub>0</sub></I> ...</VAR>)&nbsp;-&gt;&nbsp;<VAR>array</VAR></CODE>
</UL>
<CODE>Make-shared-array</CODE> makes a new array that shares storage with <CODE><VAR>array</VAR></CODE>
and uses <CODE><VAR>linear-map</VAR></CODE> to map indicies to elements.
<CODE><VAR>Linear-map</VAR></CODE> must accept as many arguments as the number of
<CODE><VAR>dimension</VAR></CODE>s given and must return a list of non-negative integers
that are valid indicies into <CODE><VAR>array</VAR></CODE>.
<BLOCKQUOTE><PRE>
(array-ref (make-shared-array a f i0 i1 ...)
j0 j1 ...)
</PRE></BLOCKQUOTE>
is equivalent to
<BLOCKQUOTE><PRE>
(apply array-ref a (f j0 j1 ...))
</PRE></BLOCKQUOTE>
<P>As an example, the following function makes the transpose of a two-dimensional
array:
<BLOCKQUOTE><PRE>
(define (transpose array)
(let ((dimensions (array-dimensions array)))
(make-shared-array array
(lambda (x y)
(list y x))
(cadr dimensions)
(car dimensions))))
(array-&gt;vector
(transpose
(array '(2 3) 'a 'b 'c 'd 'e 'f)))
<CODE>-&gt;</CODE> '(a d b e c f)
</PRE></BLOCKQUOTE>
<H1><A NAME="4">Records</A></H1>
<P>New types can be constructed using the <CODE>define-record-type</CODE> macro
from the <CODE>define-record-types</CODE> structure
The general syntax is:
<BLOCKQUOTE><PRE>
(define-record-type <CODE><VAR>tag</VAR></CODE> <CODE><VAR>type-name</VAR></CODE>
(<CODE><VAR>constructor-name</VAR></CODE> <CODE><VAR>field-tag</VAR></CODE> ...)
<CODE><VAR>predicate-name</VAR></CODE>
(<CODE><VAR>field-tag</VAR></CODE> <CODE><VAR>accessor-name</VAR></CODE> [<CODE><VAR>modifier-name</VAR></CODE>])
...)
</PRE></BLOCKQUOTE>
This makes the following definitions:
<UL><LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
<tr> <td><CODE><CODE><VAR>type-name</VAR></CODE></CODE></td> <td align=right>type</td></tr></table>
<LI><CODE>(<CODE><VAR>constructor-name</VAR></CODE><VAR> field-init ...</VAR>)&nbsp;-&gt;&nbsp;<VAR>type-name</VAR></CODE>
<LI><CODE>(<CODE><VAR>predicate-name</VAR></CODE><VAR> value</VAR>)&nbsp;-&gt;&nbsp;<VAR>boolean</VAR></CODE>
<LI><CODE>(<CODE><VAR>accessor-name</VAR></CODE><VAR> type-name</VAR>)&nbsp;-&gt;&nbsp;<VAR>value</VAR></CODE>
<LI><CODE>(<CODE><VAR>modifier-name</VAR></CODE><VAR> type-name value</VAR>)</CODE>
</UL>
<CODE><VAR>Type-name</VAR></CODE> is the record type itself, and can be used to
specify a print method (see below).
<CODE><VAR>Constructor-name</VAR></CODE> is a constructor that accepts values
for the fields whose tags are specified.
<CODE><VAR>Predicate-name</VAR></CODE> to a predicate that can returns <CODE>#t</CODE> for
elements of the type and <CODE>#f</CODE> for everything else.
The <CODE><VAR>accessor-name</VAR></CODE>s retrieve the values of fields,
and the <CODE><VAR>modifier-name</VAR></CODE>'s update them.
The <CODE><VAR>tag</VAR></CODE> is used in printing instances of the record type and
the field tags are used in the inspector and to match
constructor arguments with fields.
<UL><LI><CODE>(define-record-discloser<VAR> type discloser</VAR>)</CODE>
</UL>
<CODE>Define-record-discloser</CODE> determines how
records of type <CODE><VAR>type</VAR></CODE> are printed.
<CODE><VAR>Discloser</VAR></CODE> should be procedure which takes a single
record of type <CODE><VAR>type</VAR></CODE> and returns a list whose car is
a symbol.
The record will be printed as the value returned by <CODE><VAR>discloser</VAR></CODE>
with curly braces used instead of the usual parenthesis.
<P>For example
<BLOCKQUOTE><PRE>
(define-record-type pare :pare
(kons x y)
pare?
(x kar set-kar!)
(y kdr))
</PRE></BLOCKQUOTE>
defines <CODE>kons</CODE> to be a constructor, <CODE>kar</CODE> and <CODE>kdr</CODE> to be
accessors, <CODE>set-kar!</CODE> to be a modifier, and <CODE>pare?</CODE> to be a predicate
for a new type of object.
The type itself is named <CODE>:pare</CODE>.
<CODE>Pare</CODE> is a tag used in printing the new objects.
<P>By default, the new objects print as <CODE>#Pare</CODE>.
The print method can be modified using DEFINE-RECORD-DISCLOSER:
<BLOCKQUOTE><PRE>
(define-record-discloser :pare
(lambda (p) `(pare ,(kar p) ,(kdr p))))
</PRE></BLOCKQUOTE>
will cause the result of <CODE>(kons 1 2)</CODE> to print as
<CODE>#{pare 1 2}</CODE>.
<H1><A NAME="5">Finite record types</A></H1>
<P>The structure <CODE>finite-types</CODE> has
two macros for defining `finite' record types.
These are record types for which there are a fixed number of instances,
which are created when the record type is defined.
The syntax for the defining a finite type is:
<BLOCKQUOTE><PRE>
(define-finite-type <CODE><VAR>tag</VAR></CODE> <CODE><VAR>type-name</VAR></CODE>
(<CODE><VAR>field-tag</VAR></CODE> ...)
<CODE><VAR>predicate-name</VAR></CODE>
<CODE><VAR>vector-of-elements-name</VAR></CODE>
<CODE><VAR>name-accessor</VAR></CODE>
<CODE><VAR>index-accessor</VAR></CODE>
(<CODE><VAR>field-tag</VAR></CODE> <CODE><VAR>accessor-name</VAR></CODE> [<CODE><VAR>modifier-name</VAR></CODE>])
...
((<CODE><VAR>element-name</VAR></CODE> <CODE><VAR>field-value</VAR></CODE> ...)
...))
</PRE></BLOCKQUOTE>
This differs from <CODE>define-record-type</CODE> in the following ways:
<UL><LI>No name is specified for the constructor, but the field arguments
to the constructor are listed.
<LI>The <CODE><VAR>vector-of-elements-name</VAR></CODE> is added; it will be bound
to a vector containing all of the elements of the type.
These are constructed by applying the (unnamed) constructor to the
initial field values at the end of the form.
<LI>There are names for accessors for two required fields, name
and index.
These fields are not settable, and are not to be included
in the argument list for the constructor.
<LI>The form ends with the names and the initial field values for
the elements of the type.
The name must be first.
The remaining values must match the <CODE><VAR>field-tag</VAR></CODE>s in the constructor's
argument list.
<LI><CODE><VAR>Tag</VAR></CODE> is bound to a macro that maps <CODE><VAR>element-name</VAR></CODE>s to the
the corresponding element of the vector.
The name lookup is done at macro-expansion time.
</UL>
<BLOCKQUOTE><PRE>
(define-finite-type color :color
(red green blue)
color?
colors
color-name
color-index
(red color-red)
(green color-green)
(blue color-blue)
((white 255 255 255)
(black 0 0 0)
(yellow 255 255 0)
(maroon 176 48 96)))
(color-name (vector-ref colors 0)) <CODE>-&gt;</CODE> white
(color-name (color black)) <CODE>-&gt;</CODE> black
(color-index (color yellow)) <CODE>-&gt;</CODE> 2
(color-red (color maroon)) <CODE>-&gt;</CODE> 176
</PRE></BLOCKQUOTE>
<P>Enumerated types are finite types whose only fields are the name
and the index.
The syntax for defining an enumerated type is:
<BLOCKQUOTE><PRE>
(define-enumerated-type <CODE><VAR>tag</VAR></CODE> <CODE><VAR>type-name</VAR></CODE>
<CODE><VAR>predicate-name</VAR></CODE>
<CODE><VAR>vector-of-elements-name</VAR></CODE>
<CODE><VAR>name-accessor</VAR></CODE>
<CODE><VAR>index-accessor</VAR></CODE>
(<CODE><VAR>element-name</VAR></CODE> ...))
</PRE></BLOCKQUOTE>
In the absence of any additional fields, both the constructor argument
list and the initial field values are not required.
<P>The above example of a finite type can be pared down to the following
enumerated type:
<BLOCKQUOTE><PRE>
(define-enumerated-type color :color
color?
colors
color-name
color-index
(white black yellow maroon))
(color-name (vector-ref colors 0)) <CODE>-&gt;</CODE> white
(color-name (color black)) <CODE>-&gt;</CODE> black
(color-index (color yellow)) <CODE>-&gt;</CODE> 2
</PRE></BLOCKQUOTE>
<H1><A NAME="6">Hash tables</A></H1>
<P>These are generic hash tables, and are in the structure <CODE>tables</CODE>.
Strictly speaking they are more maps than tables, as every table has a
value for every possible key (for that type of table).
All but a finite number of those values are <CODE>#f</CODE>.
<UL><LI><CODE>(make-table<VAR></VAR>)&nbsp;-&gt;&nbsp;<VAR>table</VAR></CODE>
<LI><CODE>(make-symbol-table<VAR></VAR>)&nbsp;-&gt;&nbsp;<VAR>symbol-table</VAR></CODE>
<LI><CODE>(make-string-table<VAR></VAR>)&nbsp;-&gt;&nbsp;<VAR>string-table</VAR></CODE>
<LI><CODE>(make-integer-table<VAR></VAR>)&nbsp;-&gt;&nbsp;<VAR>integer-table</VAR></CODE>
<LI><CODE>(make-table-maker<VAR> compare-proc hash-proc</VAR>)&nbsp;-&gt;&nbsp;<VAR>procedure</VAR></CODE>
<LI><CODE>(make-table-immutable!<VAR> table</VAR>)</CODE>
</UL>
The first four functions listed make various kinds of tables.
<CODE>Make-table</CODE> returns a table whose keys may be symbols, integer,
characters, booleans, or the empty list (these are also the values
that may be used in <CODE>case</CODE> expressions).
As with <CODE>case</CODE>, comparison is done using <CODE>eqv?</CODE>.
The comparison procedures used in symbol, string, and integer tables are
<CODE>eq?</CODE>, <CODE>string=?</CODE>, and <CODE>=</CODE>.
<P><CODE>Make-table-maker</CODE> takes two procedures as arguments and returns
a nullary table-making procedure.
<CODE><VAR>Compare-proc</VAR></CODE> should be a two-argument equality predicate.
<CODE><VAR>Hash-proc</VAR></CODE> should be a one argument procedure that takes a key
and returns a non-negative integer hash value.
If <CODE>(<CODE><VAR>compare-proc</VAR></CODE> <CODE><VAR>x</VAR></CODE> <CODE><VAR>y</VAR></CODE>)</CODE> returns true,
then <CODE>(= (<CODE><VAR>hash-proc</VAR></CODE> <CODE><VAR>x</VAR></CODE>) (<CODE><VAR>hash-proc</VAR></CODE> <CODE><VAR>y</VAR></CODE>))</CODE>
must also return true.
For example, <CODE>make-integer-table</CODE> could be defined
as <CODE>(make-table-maker = abs)</CODE>.
<P><CODE>Make-table-immutable!</CODE> prohibits future modification to its argument.
<UL><LI><CODE>(table?<VAR> value</VAR>)&nbsp;-&gt;&nbsp;<VAR>boolean</VAR></CODE>
<LI><CODE>(table-ref<VAR> table key</VAR>)&nbsp;-&gt;&nbsp;<VAR>value or <CODE>#f</CODE></VAR></CODE>
<LI><CODE>(table-set!<VAR> table key value</VAR>)</CODE>
<LI><CODE>(table-walk<VAR> procedure table</VAR>)</CODE>
</UL>
<CODE>Table?</CODE> is the predicate for tables.
<CODE>Table-ref</CODE> and <CODE>table-set!</CODE> access and modify the value of <CODE><VAR>key</VAR></CODE>
in <CODE><VAR>table</VAR></CODE>.
<CODE>Table-walk</CODE> applies <CODE><VAR>procedure</VAR></CODE>, which must accept two arguments,
to every associated key and non-<CODE>#f</CODE> value in <CODE>table</CODE>.
<UL><LI><CODE>(default-hash-function<VAR> value</VAR>)&nbsp;-&gt;&nbsp;<VAR>integer</VAR></CODE>
<LI><CODE>(string-hash<VAR> string</VAR>)&nbsp;-&gt;&nbsp;<VAR>integer</VAR></CODE>
</UL>
<CODE>default-hash-function</CODE> is the hash function used in the tables
returned by <CODE>make-table</CODE>, and <CODE>string-hash</CODE> it the one used
by <CODE>make-string-table</CODE>.
<HR >
</BODY></HTML>

159
doc/install.txt Normal file
View File

@ -0,0 +1,159 @@
-*- Mode: Indented-text; -*-
Here are some remarks to complement what's in the INSTALL file.
-----
When running "make", don't worry if the ".notify" target fails. Its
only purpose is to send an email message to
scheme-48-notifications@martigny.ai.mit.edu, so that we can get a
rough idea of how much Scheme 48 is being used and by whom. We
promise not to use your name or email address for any commercial
purpose. If you don't want us to know, just do "make -t .notify"
first.
-----
Customizing the installation
1. If you don't believe in configure scripts, or don't have a
/bin/sh that can handle the configure script, you can make
sysdep.h and Makefile manually from sysdep.h.in and Makefile.in.
The technique is fairly obvious. For Makefile, just give
reasonable values for all of the variables at the top that are
defined as "foo = @foo@", e.g. srcdir=., CC=cc, LIBS=-lm,
INSTALL=cp, etc. For sysdep.h, read the comments. If your OS is
Posix compliant, you should be able to copy sysdep.h.in to
sysdep.h unmodified and everything should work.
2. If you definitely won't be installing Scheme 48, you should set
libdir to the distribution directory (e.g. "make libdir=`pwd`").
This will make the ,open and ,load-package commands work for the
library packages defined in more-packages.scm.
3. If desired, customize the contents of the development environment
heap image by editing the definitions of USUAL-COMMANDS and/or
USUAL-FEATURES in more-packages.scm; see below.
4. If you're using a DEC MIPS, and want to use the foreign function
interface, specify LDFLAGS=-N (with e.g. "make LDFLAGS=-N").
-----
Customizing scheme48.image
By default, the image consists of a core Scheme system (Revised^5
Scheme plus a very minimal read-eval-print loop) together with a
standard set of "options" (command processor, debugging commands,
inspector, disassembler, generic arithmetic). The set of options is
controlled by the definitions of USUAL-COMMANDS and USUAL-FEATURES in
more-packages.scm. If you make the (open ...) clause empty, then
"make scheme48.image" will create a Scheme system without any extras
(such as error recovery), and the image will be smaller. The files
are listed in approximate order of decreasing desirability; you'll
probably want at least these:
package-commands, build
- necessary for the scheme48.image script to work
debuginfo, disclosers
- necessary if you want error messages to be at all helpful
debugging
- defines important debugging commands such as ,preview and ,trace
After editing the definition of usual-features, simply
make scheme48.image
to rebuild the image.
-----
Deeper changes to the system -- for example, edits to most of the
files in the rts/ directory -- will require using the static linker to
make a new initial.image. After you have a working scheme48.image
(perhaps a previous version of Scheme 48), you can create a linker
image with
make linker
after which you can say
make image
to get the linker to build a new initial.image and initial.debug.
scheme48.image will then be built from those.
You might think that "make scheme48.image" ought to do this, but the
circular dependencies
scheme48.image on initial.image
initial.image on link/linker.image
link/linker.image on scheme48.image
needs to be broken somewhere, or else make will (justifiably) barf. I
chose to break the cycle by making scheme48.image not depend on
initial.image, since this is most robust for installation purposes.
-----
Editor support
We recommend interacting with the Scheme 48 command processor using the
emacs/scheme interface written by Olin Shivers at CMU. Copies of the
relevant .el files, together with a "cmuscheme48.el", are in the
emacs/ subdirectory of the release. Usage information is in
doc/user-guide.txt.
You will probably want to byte-compile the .el files to get .elc
files. Use M-x byte-compile-file to do this.
-----
Performance
If you don't have a C compiler that optimizes as well as gcc does,
then performance may suffer. Take a look at the automatically
generated code in scheme48vm.c to find out why. With a good register
allocator, all those variables (including some of the virtual
machine's virtual registers) get allocated to hardware registers, and
it really flies. Without one, performance can be pretty bad.
The configure script automatically sets the Makefile variable CFLAGS
to -O2 -g if gcc is available, or to -O if it isn't. This can be
overriden by specifying a different CFLAGS, e.g. "make CFLAGS=-g" for
no optimization.
Even if you do have a good compiler, you should be able to improve
overall performance even more, maybe about 6-10%, by removing the
range check from the interpreter's instruction dispatch. To do this,
use the -S flag to get assembly code for scheme48vm.c, then find the
instructions in scheme48vm.s corresponding to the big dispatch in
restart():
L19173: {
code_pointer_83X = arg1K0;
switch ((*((unsigned char *) code_pointer_83X))) {
... }
There will be one or two comparison instructions to see whether the
opcode is in range; just remove them. For the 68000 I use a "sed"
script
/cmpl #137,d0/ N
/cmpl #137,d0\n jhi L/ d
but of course the constant will probably have to change when a new
release comes along.
See the user's guide for information on the ,bench command, which
makes programs run faster.
-----
filenames.make is "include"d by the Makefile, but is automatically
generated from the module dependencies laid out in the various
configuration files (*-packages.scm). If you edit any of these .scm
files, you may want to do a "make filenames.make" before you do any
further "make"s in order to update the depedencies. This step isn't
necessary if you're using Gnu make, because Gnu make will make
included files automatically.

201
doc/io.txt Normal file
View File

@ -0,0 +1,201 @@
There are two types of I/O objects in Scheme 48, channels and ports.
Channels are the raw, unbuffered ports of the operating system. The
only I/O operations the VM supports for channels are block reads and
writes. Ports are the actual Scheme ports and are implemented in Scheme,
with some support from the VM for READ-CHAR, PEEK-CHAR, and WRITE-CHAR
for efficiency. The run-time system provides ports that are buffered
versions of channels. Other sorts of ports are in big/more-port.scm.
Source files:
rts/port.scm port operations and port handlers
rts/current-port.scm current-input-port, etc.
rts/channel.scm blocking on channels and handling i/o interrupts
rts/channel-port.scm ports that read and write to channels
rts/low.scm CHANNEL-READ and CHANNEL-WRITE
big/more-port.scm additional kinds of ports
vm/arch.scm fields of ports and channels
vm/prim-io.scm VM i/o opcodes
vm/vmio.scm implementation of channels
----------------------------------------------------------------
CHANNELS
The VM instructions that deal with channels are:
(OPEN-CHANNEL <spec> <mode>) -> channel
<mode> is a from the enumeration OPEN-CHANNEL-OPTION in arch.scm.
<spec> is either a filename (as a string) or an OS port (as a one-word
code-vector), depending on the mode.
(CLOSE-CHANNEL <channel>) -> unspecific
(CHANNEL-MAYBE-READ <string-or-code-vector> <start-index> <count> <wait?>
<channel>)
-> number of bytes read or the eof-object
(CHANNEL-MAYBE-WRITE <string-or-code-vector> <start-index> <count> <channel>)
-> number of bytes written
These read or write up to the specified number of characters or bytes
from or to the string or code-vector, with the first character or byte
going at <start-index>.
(CHANNEL-ABORT <channel>) -> number of bytes read or written or
the eof-object
This aborts any pending read or write operation on the channel. The return
value reflects any partial completion.
CHANNEL-MAYBE-READ and CHANNEL-MAYBE-WRITE do not block. If the read or
write cannot be completed immediately a PENDING-CHANNEL-I/O exception is
raised. It is then up to the run-time system to either wait or run some
other thread. The VM raises an I/O-COMPLETION interrupt whenever an i/o
operation completes.
Because CHANNEL-MAYBE-READ and CHANNEL-MAYBE-WRITE are awkward to use,
the RTS defines somewhat simpler versions:
(CHANNEL-READ <buffer> <start> <needed> <channel>)
-> number of bytes read or the eof-object
(CHANNEL-WRITE <buffer> <start> <count> <channel>)
-> unspecified
<Buffer> is either a string or code vector and <start> is the index of the
first character read or written. <Needed> is one of:
N > 0 : the call returns when this many characters has been read or
an EOF is reached.
'IMMEDIATE : the call reads as many characters as are available and
returns immediately.
'ANY : the call returns as soon as at least one character has been read
or an EOF is reached.
<Count> is the number of characters to be written. CHANNEL-READ will read
the requested number of characters unless an EOF is reached. CHANNEL-WRITE
will write the requested number of characters.
----------------------------------------------------------------
PORTS
Ports are actual Scheme port and are (usually) buffered. They are fully
exposed to the run-time system. The VM instructions on ports could be
implemented in Scheme; they are in the VM for efficiency. Buffers are
code-vectors (this is a micro-hack; strings have a slightly higher overhead
because of the null terminating byte for C compatibility) (code-vectors are
just vectors of bytes).
The fields of a port are:
PORT-STATUS: a bit set represented as a fixnum.
Indices into this bit set are from the PORT-STATUS-OPTIONS
enumeration in arch.scm. The current bits are: input, output,
open-for-input, open-for-output (the last two are for things like
sockets, on which you need to block but which do not support
normal reading or writing).
PORT-HANDLER: a record containing three procedures. These handle
printing the port, closing the port, and filling (for input ports)
or emptying (for output ports) buffers.
PORT-DATA: ?
Whatever stuff the handler needs.
PORT-LOCKED?, PORT-LOCK: used by the system to guarentee the atomicity
of i/o operations.
PORT-BUFFER: a code-vector. The input or output buffer of the port.
PORT-INDEX: a fixnum. The index of the next byte to read or written.
PORT-LIMIT: a fixnum. One past the end of the valid/available buffer space.
PORT-PENDING-EOF?: true if the next read to this port should return EOF.
Additional operations on ports:
(READ-BLOCK string-or-code-vector start count input-port)
Read COUNT bytes into STRING-OR-CODE-VECTOR starting at index START.
Returns the number of bytes read. Only an end-of-file will prevent
the requested number of bytes from being read.
(WRITE-STRING string output-port)
Write the characters in the string to the port.
(WRITE-BLOCK string-or-code-vector start count output-port)
The output counterpart to READ-BLOCK. This always writes out the
requested number of bytes. Its return value is unspecified.
(FORCE_OUTPUT output-port)
Causes any buffered characters to be written out.
(CURRENT-ERROR-PORT)
The current error port, analogous to Scheme's CURRENT-INPUT-PORT
and CURRENT-OUTPUT-PORT.
The system maintains a list of output ports whose buffers should be
periodically flushed. The default output port and ports made by
OPEN-OUTPUT-FILE are on this list. (PERIODICALLY-FORCE-OUTPUT! <output-port>)
may be used to add others.
----------------------------------------------------------------
PORT HANDLERS
Every port has a handler with three procedures. The first two are used
for printing and closing ports and have the same type for all ports:
(DISCLOSE port-data) -> disclose list
(CLOSE port-data) -> unspecific
For CLOSE, The system takes care of modifying the port's status.
The third procedure is used to fill and empty buffers. Its arguments
and return values depend on the kind of port:
Buffered output ports:
(BUFFER-PROC port-data buffer start-index byte-count) -> unspecific
BYTE-COUNT bytes should be copied from the buffer beginning at
START-INDEX. The buffer may be either a string or a code-vector.
Unbuffered output ports:
(BUFFER-PROC port-data char) -> unspecific
Write out the given character. The system uses this for the default
error port.
Input ports:
(BUFFER-PROC data buffer start-index needed-bytes)
-> EOF or number of bytes read (before an EOF)
Bytes should be copied into the buffer starting at START-INDEX. The
buffer may be either a string or a code-vector. NEEDED-BYTES is one of:
'IMMEDIATE
The call should return immediately after transfering whatever number
of bytes are currently available, possibly none (this is used for
CHAR-READY?). The maximum number of characters is determined by the
length of BUFFER.
'ANY
The call should wait until at least one byte is available or an EOF
occurs (used for READ-CHAR and PEEK-CHAR). The maximum number of
characters is determined by the length of BUFFER.
N > 0
The call should wait until N bytes have been copied into the buffer
or an EOF occurs. If the return value is less than NEEDED-BYTES the
port code inserts an EOF after the last byte.
----------------------------------------------------------------
Ports and the Virtual Machine
Ports could be implemented entirely in Scheme, with no support from
the VM. For efficiency reasons VM instructions are supplied for
three port operations:
(READ-CHAR <port>)
(PEEK-CHAR <port>)
(WRITE-CHAR <char> <port>)
For each of these, if there is sufficient data or space in the
appropriate buffer the VM performs the operation. Otherwise a
buffer-full/empty exception is raised and the exception handler
uses the buffer procedure from the port's handler to fill or
empty the buffer.

1090
doc/meeting.ps Normal file
View File

File diff suppressed because it is too large Load Diff

1417
doc/module.ps Normal file
View File

File diff suppressed because it is too large Load Diff

700
doc/news.txt Normal file
View File

@ -0,0 +1,700 @@
-*- Mode: Indented-text; -*-
Recent changes to Scheme 48.
2/24/99 (version 0.53)
Additions:
DEFINE-FINITE-TYPE and DEFINE-ENUMERATED-TYPE (in structure
FINITE-TYPES; documented in doc/utilities.ps and
doc/html/utilities.html.
Added CHAR-SOURCE->INPUT-PORT, CHAR-SINK->OUTPUT-PORT,
MAKE-STRING-OUTPUT-PORT, STRING-OUTPUT-SOURCE-OUTPUT to
the extended-ports structure.
The structure BYTE-VECTORS is the same as CODE-VECTORS with `byte'
replacing `code' in all the names. The underlying datatype is the
same for both, and uses `byte' when printing.
There is a new and much improved interface to C code, thanks to
Mike Sperber. It is documented in in doc/external.ps and
doc/html/external.html.
Bug fixes:
Session-data and user-context records are no longer in the fluid env.
Lexical environments can now be nested up to 65k deep.
,expand no longer prints `definition in expression context' warnings.
Added ARRAY? and SEARCH-TREE? to the array and search tree structures.
Flat environments work again.
Templates of the form `var ... ...' now work in syntax rules.
Reinstated caching of SCHEMIFY results to greatly reduce the space
used by debugging info.
Added argument checking to STRING->NUMBER and NUMBER->STRING.
Fixed space blow-up in LOAD.
Unused ports are closed more reliably.
Changes:
The heap, gc, and image code is now in three separate modules.
The symbol table is now held in a VM register.
Inlined SHOWING-FOCUS-VALUES into the main command loop and moved
the sentinal call to reduce the noise at the base of ,preview output.
The tables returned by MAKE-TABLE now use EQV? for comparison (instead
of EQ?). This makes these tables about 50% slower when numbers are
used as keys, but significantly more accurate.
Floating-point numbers are no longer double boxed.
The channels structure has been split into channels and low-channels.
7/22/98 (version 0.52)
Bug fixes:
Fixed problems with unbound variables in SET! and the inliner.
Made macro expansion a bit less eager; this should reduce the amount
of heap space needed for compilation.
6/29/98 (version 0.51)
Incompatible changes:
BIG-SCHEME no longer exports its version of DEFINE-RECORD-TYPE (but
it is available from the structure DEFRECORD). I am slowly removing
all uses of this version of DEFINE-RECORD-TYPE from the sources.
The version of DEFINE-RECORD-TYPE exported by DEFINE-RECORD-TYPES
checks that every constructor argument corresponds to a field.
Uses of LAP must list their free variables (see env/assem.scm).
Changes:
The functions exported by BIG-SCHEME that were not available elsewhere
are now exported by BIG-UTIL as well.
MAKE-RANDOM now checks its argument (but is still a fairly poor
source of pseudo-randomness).
SIGPIPE no longer kills the S48 process (this was done earlier but
not listed here).
The macro/module/compiler code has been reorganized. Hopefully
the only noticable difference is in the babble written when loading
files and packages.
Added CODE-QUOTE (in its own structure of the same name) for use
in writing hygienic macro-generating macros. CODE-QUOTE is the
same as QUOTE except that it does not strip off any of the macro
system's name annotations.
The FLOATNUMS package now exports FLOATNUM?.
Bug fixes:
Fixed phony stack-overflow bug.
Fixed a bug in thread time-debit mechanism.
Made floating point numbers always print as inexact.
Got rid of bogus type-error warnings when using floatnums.
Fixed declaration of call_startup_procedure in c/main.c.
2/11/98 (version 0.50)
Fixed bug in closed-compiled version of READ-CHAR.
Fixed negative-key bug in integer tables.
11/18/97 (version 0.49)
Removed some non-portable Kali code that had been accidentally
included in c/extension.c.
10/29/97 (version 0.48)
The VM's calling convention now has the caller doing protocol checking,
instead of the callee. The *NARGS* register no longer exists.
Scheme's variable-arity procedures (APPLY, MAKE-VECTOR, +, -, etc.)
are usually handled without raising an exception. Calls with an
`atypical' number of arguments are now much faster.
Opcodes were added for >, <=, and >=.
Procedures can take up to about 8k arguments. The limit is determined
by the value of AVAILABLE-STACK-SPACE in scheme/vm/arch.scm.
Compiler detects wrong number of arguments in ((lambda ...) ...).
Removed the dynamic point from the dynamic environment to make
DYNAMIC-WIND behave reasonably with threads.
KILL-THREAD! should work more reliably.
The I/O primitives now pass OS error messages to the exception handlers.
I/O errors when flushing buffers no longer crash the system.
The Pre-Scheme compiler's hack for shadowing global variables with
local copies is no longer used.
Incompatible changes:
The internal thread interface was simplified.
There are some architecture changes; .image files will have to
be rebuilt.
ACCESS-SCHEME-48 and scheme/misc/slib-init.scm have been removed
(thanks to Mike Sperber's updating of slib).
1/27/97 (version 0.47)
Fixed ,exit and added ,exit-when-done.
CASE now uses EQV? exclusively.
11/5/96 (version 0.46)
Fixed a few minor thread problems.
opt/analyze.scm now writes to current-noise-port.
DELQ and DELETE now delete every instance, as the documentation claims.
There should be no more spurious heap-overflow interrupts.
Fixed bugs that caused the system to die if stdout blocked.
Template offsets have been increased to two bytes.
Disassembly of flat-lambda now works (fix from Michael Sperber).
8/23/96 (version 0.45)
Fixed various problems with thread termination and nested schedulers.
Changed thread-internal interface to make schedulers easier to write.
BITWISE-{AND,IOR,XOR} now take an arbitrary number of arguments.
Output ports have their buffers flushed when Scheme 48 terminates.
In keeping with RnRS, CLOSE-{IN,OUT}PUT-PORT are now idempotent.
MODULO now handles negative arguments properly.
6/20/96 (version 0.44)
The VM's byte-code interpreter and storage management code are
now compiled to separate C files.
The socket code works again.
5/10/96 (version 0.42-0.43)
Various fixes to the thread and I/O systems.
The Unix interface code is more portable.
EOF (control-D) now resumes running all non-broken threads on
resumed command level. Thus EOF after a keyboard interrupt
(control-C) resumes running the interrupted thread.
11/30/95 (version 0.41)
The distribution has been reorganized to reduce the number of files
in the top-level directory.
The threads implementation has been replaced with one based on engines
to allow for nested schedulers.
Threads are now included in the initial image.
The I/O system has been fixed and automatic periodic output buffer
flushing has been reinstalled.
Command levels have been integrated with the threads system to ensure
that at most one REPL is active at any time.
CONDVAR has been changed to PLACEHOLDER (condition variables being
something quite different).
,profile no longer works, it will be fixed in a later version.
MIN and MAX now do inexact contagion.
4/13/95 (version 0.40)
Renamed error-output-port to current-error-port.
Reinstated ".gdbinit"...
segment->template now takes parent templates debug data as an
argument.
Automatic periodic output buffer flushing has been
temporarily disabled. A future version of the I/O system
will fix it.
Fixed expansion of named LET.
The bummed-define-record-types structure is now gone; use
define-record-types instead.
There is somewhat better syntax checking now.
8/12/94 (versions 0.38-0.39)
,profile <command> prints out profiling information
An interrupt is raised after ever GC; the default handler checks
to see if some reasonable amount of storage was reclaimed.
Some of the standard Scheme procedures, including LENGTH, FOR-EACH,
VECTOR, and ASSQ, are now significantly faster.
Making, accessing, and setting records is faster.
tar file now includes the top-level directory
The "scheme-level-2-internal" structure has been renamed to
"usual-resumer".
` ( . ' is now illegal (as required by the R4RS grammar).
Made DELAY and FORCE comply with R4RS.
The EXPAND optimizer does a topological sort on definitions.
(optimize flat-environments) causes the compiler to produce
flat (instead of nested) lexical environments.
The I/O system has been rewritten to do its own buffering. There
are significant changes to unix.c to support this. See doc/io.txt.
(ERROR-OUTPUT) is now available from the structure i/o.
jar-defrecord has been replaced with a modified bummed-jar-defrecord
Files load about 25% faster, for a number of reasons.
Removed the copy of vm/arch.scm from the rts directory.
Threads and sockets work together; SOCKET-ACCEPT no longer blocks.
The compiler no longer prints out .'s as it compiles definitions.
7/5/94 (version 0.37)
I/O opcodes now raise an interrupt instead of blocking (they still
block if no corresponding interrupt handler has been installed).
The threads code has been rewritten; threads that block on I/O
do not busy wait and THREAD-READ-CHAR and THREAD-PEEK-CHAR have
been removed.
Attempting to obtain a lock twice or to release an unowned lock
now signal errors.
READ-CHAR-WITH-TIMEOUT returns #F if the timeout occurs.
The socket structure is back in more-packages.scm.
Renamed .gdbinit to gdbinit
tar file now contains a top-level directory
3/22/94 (version 0.36)
Removed doc/lsc.ps for copyright reasons.
Fixed (* 47123 46039) multiply bug.
Modified vm/README to make it easier to run the VM.
3/16/94 (version 0.35)
Fixed (exact->inexact 0.1) -> 0..1. bug.
Fixed VM bug that permitted the creation of stored objects with
negative sizes.
3/8/94 (version 0.34)
"make check" target tests out various features.
Fixes for SGI IRIX 4.0.5 and MIPS RISC/OS 4.51, courtesy
Bryan O'Sullivan.
debug/run.scm and the "medium system" work again now.
misc/static.scm should work on the 68000.
Command processor no longer fluid-binds (interaction-environment)
on recursive entry.
2/24/94 (version 0.33)
Fixed bug in VM's interrupt system.
Made non-local srcdir work in Makefile.
Added (load-package 'bigbit) to vm/README.
2/23/94 (version 0.32)
Some incompatible changes to the VM; .image files will have
to be rebuilt.
Improvements to configuration script and to unix.c to support
a wider variety of Unixes. The system should now work
under any Posix-compliant Unix (except maybe for
char-ready?; see comments in unix.c).
Upped the default heap size from 4 meg (2 per semispace) to 6
meg (3 per semispace).
New command line argument -s <size> for specifying size of
stack buffer. Default is 2500 (words).
$@ -> "$@" in script (thanks to Paul Stodghill for this fix).
Obscure interrupt/exception VM bug fixed.
It is now possible to put an initial heap image into static
memory (effectively allocated by OS process creation).
Immutable initial objects go into static read-only memory,
and mutable initial objects go into static read-write
memory. Initial objects not copied by the GC. There is no
documentation yet, but look at the rules for little and
debug/little.o in the Makefile if you're interested.
2/13/94 (version 0.31)
Incompatible changes:
In interfaces, all exported syntactic keywords must be
given type :syntax. For example,
(define-interface my-macros
(export (my-macro :syntax) ...))
Image entry procedures for the ,build command are now
passed a list of strings, not just a single string, for
the command line arguments following -a.
The names of the macros defined in scheme48.h
(pairp, car, string_length, etc.) are now all upper case.
New "configure" script generates Makefile from Makefile.in
and sysdep.h from sysdep.h.in (thanks to Gnu autoconf).
See INSTALL and doc/install.txt.
Bug fixes:
Can now make vectors (strings, etc.) as big as the amount
of heap space available (but you're still screwed if you
try to make one bigger than 2^23-1 bytes - don't do it).
Non-ANSI-ness fixed in scheme48vm.c (jump out of, then
back into, a block expected block-local variables to be
unchanged).
Fixed big/external.scm (had VECTOR-POSQ instead of ENUM).
In (define-syntax foo bar) you got an error if bar was a
variable reference.
Plugged a storage leak (file-environments table in
env/debug.scm). Images made with ,build were too large.
Flushed extraneous delay from make-reflective-tower.
Renamed variables in Makefile to resemble Gnu standards.
Fixed definition of LINKER_RUNNABLE in Makefile.
Added doc/call-back.txt.
Fixed define-enumerated documentation (doc/big-scheme.txt).
Environment maps no longer retained for things in initial.image
and scheme48.image. This makes scheme48.image about 170K
smaller.
2/3/94 (version 0.30)
Faster EXPT.
FLOATNUMS improvement: (inexact->exact <float>) should now
work, e.g.
(inexact->exact (/ 1. 3.)) => 6004799503160661/18014398509481984
Reinstated ACCESS-SCHEME-48 for the benefit of PSD (portable
scheme debugger) and a certain other software package that
shall remain nameless. It only knows about a small number of
procedures, including things like ERROR and FORCE-OUTPUT.
Various changes to support the Pre-Scheme compiler, notably
SET-REFLECTIVE-TOWER-MAKER!.
Incompatible change to the ENUMERATED structure: the names
foo/bar no longer become defined. Write (enum foo bar)
instead. This will macro expand into the correct small
integer.
1/30/94 (version 0.29)
Fixed ps_run_time() to call sysconf() to find out how many
ticks there are per second. It used to assume 60. This
affects the output of the ,time command, so don't try
comparing numbers from this version with numbers from older
versions.
,time command will now accept a command, e.g.
,time ,load foo.scm.
It appears that if multiple arguments follow -a on the
argument line, they are concatenated together with spaces
separating them and passed to the startup procedure. I
don't know how long this has worked. This will change in
the future so that the startup procedure gets a list of
strings.
Installed what used to be called the GENERAL-TABLES structure
as the TABLES structure used by the system. This allows
the use of other comparison predicates besides EQ?, and
eliminates some code that had a restrictive copyright
notice.
ENUM, NAME->ENUMERAND, and ENUMERAND->NAME are all macros.
Enumerated types themselves are now macros as well.
1/23/94 Fixed bad multiplication bug in VM: (* 214760876 10) was
returning 125112.
Moved RECORD-TYPE? and RECORD-TYPE-FIELD-NAMES from the
RECORDS-INTERNAL interface to the RECORDS interface, for
a somewhat closer approximation to MIT Scheme.
Various type system improvements.
Still no documentation for the ,exec package, but see
link/load-linker.exec for an example.
New generic function feature, exported by the METHODS
interface (see interfaces.scm), almost like in a certain
dynamic object-oriented language.
1/11/94 (version 0.27)
Change:
The isomorphism used by CHAR->INTEGER and INTEGER->CHAR is
no longer ASCII. This change was introduced in order to
assist the development of portable programs. If you need
ASCII encoding, you should open the ASCII structure and
use the procedures CHAR->ASCII and ASCII->CHAR.
Features:
The help system is somewhat improved.
New form DEFINE-STRUCTURE defines a single structure.
Incompatible changes to package system:
Renamed DEFINE-PACKAGE to DEFINE-STRUCTURES
Renamed DEFINE-STRUCTURE to DEFINE
Renamed all the base types from FOO to :FOO. E.g.
:SYNTAX, :VALUE, :PAIR, etc.
Other:
Removed socket support due to restrictive copyright on some
of the C code that was in extension.c.
12/21/93 ,take has been flushed in favor of ,exec ,load. Commands are
now accessed via a distinguished package instead of a table.
Documentation pending.
Postscript (.ps) files now included in doc/ subdirectory. (I
thought they had been there all along, but apparently I was
wrong.)
Enhanced, but still kludgey, floating point support. Use
,open floatnum.
12/12/93 (version 0.26)
NetBSD port.
Hacked write-level and write-depth for inspecting circular
structure.
Recursive FORCEs signal errors, e.g.
(force (letrec ((loser (delay (force loser)))) loser))
12/7/93 (version 0.25)
Bug fix:
filenames.make can now be remade using initial.image. This
means that you can snarf a distribution and then edit
USUAL-FEATURES before making scheme48.image.
12/6/93 Incompatible changes:
Change of terminology: "signature" --> "interface".
This means that DEFINE-SIGNATURE is now called
DEFINE-INTERFACE, etc.
Some structures have been renamed:
condition -> conditions
continuation -> continuations
exception -> exceptions
queue -> queues
port -> ports
record -> records, record-internal -> records-internal
table -> tables
template -> templates
The ,load-into command has been removed. Use ,in ... ,load
instead (see below), e.g.
,in mumble ,load myfile.scm
The heap size for -h is specified in words, not bytes. As
before, the size must account for both semispaces; -h 2n
means n words per semispace. This change was actually
made a while ago, but I was confused as to what it meant.
Bug fixes:
#e1.7 reads as 17/10, (exact? 1+1.0i) => #f, and 1.0+i prints.
Features:
Things like ((structure-ref scheme if) 1 2 3) work.
The following commands now take arbitrary commands to execute
in the specified package, not just forms:
,config ,user ,for-syntax ,in <package>
For example, you can say
,in mumble ,trace foo
This subsumes the functionality of the ,load-into and
,load-config commands.
Dynamic loading of shared libraries for System V systems
(untested).
Documentation:
Somewhat improved. user-guide.txt now lists most of the
interesting built-in packages. lsc.ps is a draft of "A
Tractable Scheme Implementation," a paper submitted to Lisp
and Symbolic Computation. See also doc/big-scheme.txt,
doc/thread.txt, and doc/external.txt.
10/30/93 LET-SYNTAX and LETREC-SYNTAX.
Arrays (see big/array.scm).
Lots of internal changes.
7/20/93 Features:
Type system. See doc/types.txt.
7/4/93 Features:
New define-package clause (for-syntax <clause>*).
E.g. (define-package ((my-package ...))
(open ...)
(for-syntax (open scheme my-utilities)
(files more-crud-for-syntax))
...)
A file name to package map is now used by the emacs
interface. Whenever you load a file, or zap from a file that
hasn't been previously loaded or zapped, the package in
which forms are being evaluated is remembered in a table.
The next time you zap some forms from the same file, they
will be evaluated in that package.
Sometimes you may get an association you don't want. In that
situation, you can use the ,forget command to delete an
entry in the table.
A new ,push command goes to a deeper command level.
Experimental "command preferred" command processor mode: if
you give the command ",form-preferred off", commands will
be "preferred" to forms, meaning that you don't need to
type a comma before giving a command. To see the value
of a variable FOO you have to say (begin foo).
Experimental "no levels" command processor mode: if you
give the command ",levels off", then an error will not
push a new command level. If you want to ignore an
error, you don't need to take any action - further
evaluations will happen at top level. If you want to
enter the inspector or get a preview, you can issue these
commands or a ,push command immediately after the error
occurs (more precisely, any time until the focus object
is set by some other command).
All of the mode-control commands (batch, bench,
break-on-warnings, form-preferred, and levels) take
an optional argument. When no argument is given, they
will toggle the corresponding mode. With an argument of
ON or OFF, they turn the mode on or off.
The ,flush and ,keep commands have been made more flexible
and verbose.
6/18/93 Incompatible changes:
The access-scheme48 procedure has gone away. Use ,open
or the module system instead.
The user, configuration, and for-syntax packages no longer
have variables bound to them in the configuration package.
Where previously you said: Now you should say:
,in user <form> ,user <form>
,in config <form> ,config <form>
,in for-syntax <form> ,for-syntax <form>
,load-into config <file> ,load-config <file>
,load-into for-syntax <file> ,for-syntax (load "file")
Features:
There is an ,expand <form> command for debugging macros.
The ,open command takes any number of structure names, and opens
them all (like ,new-package).
New procedure DEFINE-INDENTATION exported by the PP structure.
E.g. (define-indentation 'let-fluid 1) is like Gnu emacs's
(put 'let-fluid 'scheme-indent-hook 1).
The inspector simplifies generated names in continuation
source code display. E.g. when formerly it said
"Waiting for (#{Generated lambda} () (x->node (car exps)))"
now it says
"Waiting for (lambda () (x->node (car exps)))"
Macros can signal syntax errors by returning input expression
unchanged. (Comparison uses EQ?.)
Documentation:
The doc/ directory contains a draft of a "Scheme 48
Progress Report."
Cleanup:
Procedure NULL-TERMINATE added to structure EXTERNALS's
signature.
"Vulgar Scheme" renamed to "Big Scheme".
Two new subdirectories, env/ (for programming environment)
and big/ (for Big Scheme), now contain most of what was
in the misc/ directory.
Several source files that were in the top level and link/
directories have moved to the env/ and alt/ directories.
5/6/93 Bug fixes:
Fixed -h command line switch. The size was being improperly
divided by 4, so if you asked for an N megabyte heap, you'd
actually only get an N/4 megabyte heap.
Nested backquotes were broken for a while; should be fixed
now.
Features:
Quoted structure is read-only: e.g. (set-car! '(a b) 3) will
produce an exception.
,config [<form>] and ,user [<form>] are like ,in <struct> <form>.
Unix socket support; see misc/socket.scm.
Now using gzip instead of compress for distributions.
,open command offers to load packages.
A .gdbinit file sets a breakpoint at CM's exception raising
code, and defines a handy "preview" command.
1/18/93 Feature:
Scheme 48 distributions now have version numbers. The
version number is printed in the image startup message.
Please include it in bug reports.
The module system is now documented. See doc/module.tex.
12/17/92 Bug fixes:
Macro templates of the form (x ... y) are supported.
Macro templates are now less fussy about meta-variable
rank: you can do "(x y) ..." even when the rank of either
x or y (but not both) is too low; the low-ranking text
will be copied as many times as necessary. (A
meta-variable's "rank" is the number of ...'s it sits
under in the left-hand side of the rewrite rule.)
SYNTAX-RULES is now itself hygienic. This means you can
have a meta-variable named CAR, for instance.
New development environment features:
Commands now start with comma (",") instead of colon
(":"). (Easier to type since it's not shifted.)
values, call-with-values, dynamic-wind, eval,
interaction-environment, and scheme-report-environment
added per upcoming Revised^5 Scheme report. See
doc/meeting.tex.
Modifications to quoted structure will now be detected and
reported as errors.
An interrupt will occur if an insufficient amount of memory
is reclaimed by a garbage collection.
Inspector now accepts arbitrary command processor commands
(with or without leading comma)
,keep command controls retention of debugging information.
Features removed:
#\page and #\tab. These aren't in the Scheme report.
Their absence in Scheme 48 will encourage portability.
access-scheme48 works with fewer names than before. Use the
package system instead.
Complex numbers not in the system, by default. Get them
back by changing usual-features in more-packages.scm.
Features changed:
Many changes to package system. See doc/module.tex.
The :identify-image command is gone. Instead, supply a
second argument (optional) to the ,dump command.
The inspector's TEM command has been shortened to T.
Internal changes and features:
Stored objects types are now part of the virtual machine
architecture, i.e. known to the byte-code compiler.
Run-time system is split up into many little modules.
File names are retained in debug database. (But not used for
anything yet...)
Tweaks to table package reduce standard image size by 50K
and increase compiler speed by 7%.
Immutability bit in object headers.
Weak pointers.
7/18/92 Features removed:
Table package's default hash function no longer supports
string, pairs, or vectors.
7/9/92 Bug fixes:
(- 0 -536870912)
Inspector now uses command i/o ports instead of current ones
Inexact integers print as N. instead of #iN
Throwing back into a call-with-....put-port now produces a
warning instead of an error
Feature fixes:
In DEFINE-PACKAGE, OPEN no longer implies ACCESS.
misc/receive.scm renamed to rts/values.scm, made to conform
with Revised^5 Report, and installed internally.
Features:
New :load-package command. Uses file names in (file ...) clause
of a define-package. These are interpreted relative to the
directory in which the file containing the define-package
was found.
#\tab and #\page now print this way.
6/17/92 Bug fixes:
Fixed bug in modulo.
Flushed LAST-PAIR (which disappeared between R^3 and R^4).
DEFINE-SYNTAX and SYNTAX-RULES now exist.
CEILING, FLOOR, and ROUND now exist.
GCD and LCM are now n-ary.
STRING-CI=? and STRING-COPY fixed.
STRING->SYMBOL now copies its argument before handing it to
INTERN.
=, <, etc. now work with more than two arguments.
CHAR-READY? exists.
Calls via APPLY are now tail-recursive.
DISPLAY of vectors and lists works (ugh).
Development environment improvements:
Type ? at inspector to get list of inspector commands.
Inspector D command goes to next continuation.
Inspector M command shows more of a long menu.
Inspector TEM command goes to a continuation's or closure's
template.
For closures and continuations, inspector displays local
variables with their names.
For continuations, inspector displays source code for
expression into which control will return.
Multiple command loop levels. EOF (control-D) now only pops
out a single level. :reset pops all the way out. :level n
goes out to level n.
Can disable benchmark mode.
Procedures made with (let ((f (lambda ...))) ...) now print
with names.
Features:
Package system: special forms define-package and package-ref;
command processor commands :set-package, :load-into,
:clear-package, :new-package, :export, :open-package, etc.
In misc directory: threads, queues, extended ports, format, etc.
Changes to system environment:
user-initial-environment -> user-package
record-updator -> record-modifier
primitive-throw superseded by with-continuation
ash -> arithmetic-shift
New bootstrap regime.
Support for threads: alarm clock interrupt, etc.
Etc.:
Liberal COPYRIGHT file, and a little notice in each source file.
INSTALL and NEWS split off from README.
doc.txt renamed to user-guide.txt.
The Makefile now provides two ways to make "s48" for
installation. One depends on the exec #! script execution
feature and the other doesn't.
"make" targets for testsys.image and little.image.
Runs Jaffer's test suite and library.
Flushed s48.el. Use cmuscheme instead.
9/5/90 Command processor argument parser revamped.
:load, :trace, and :untrace commands take arbitrary number
of arguments. Argument to :proceed is optional.
New (but undocumented) :identify-image command.
Better error messages: wrong number of arguments, undefined
variable.
+, *, min, max, apply are now n-ary; -, /, make-string,
make-vector, read-char, peek-char, write-char have
appropriate argument optionality.
Better internal support for macros; not yet ready for release.
Added STRING as per R^3.99RS.
More testing of Scheme version of bytecode interpreter.
Better scoping of ##; files can't see command processor context.
OR and CASE don't cons closures.
VM checks for non-existent heap image file, gives error
message instead of "bus error".
Numerous internal changes in compiler and exception system.
Fixed char<?.
Fixed -.5 bug in string->number.
8/26/90 Tested (link-system) inside of T; seems to work.
Benchmark mode available via :BENCH command.
System is 15K bigger due to new fatter global environment
representations.
Inspector abbreviation improved.
Disassembler now works on continuations, sort of.
7/26/90 ((lambda ...) ...) no longer makes a closure
Features now in default system:
:inspect
:dis[assemble]
Generic arithmetic: bignums, rationals, complexes
rationalize
:time command is more verbose
MOREFILES variable in Makefile for loading extra stuff
Default heap size increased to 2 megabytes per semispace

175
doc/no-leaf-env.txt Normal file
View File

@ -0,0 +1,175 @@
Return-Path: <kelsey@ccs.neu.edu>
Date: Mon, 14 Jun 93 14:34:40 -0400
To: jar@cs.cornell.edu
Subject: environments for leaf procedures
From: kelsey@flora.ccs.neu.edu
Sender: kelsey@ccs.neu.edu
I merged the no-leaf-environments code back into the system, and this
time it may be worth it. Loading pp.scm sped up by 2%, even though
the compiler is doing more work. Benchmark times (in seconds):
old new speedup
quicksort 1.48 1.39 6%
towers 1.05 1.05 0%
matrix-multiply 3.32 3.10 7%
matrix-multiply2 1.94 1.80 7%
Local variable names are screwed up:
> (define (f x) (let ((y 4)) (+ x y)))
> (f 'a)
Error: exception
(+ 'a 4)
1> ,debug
'#{Continuation (pc 13) f}
[0] 4
[1: y] 'a
inspect:
There is probably a simple fix for this.
Here is the diff:
% diff comp.scm comp.scm.save
26d25
< (define $compiling-leaf (make-fluid 'no))
28,33d26
< (define (note-not-leaf!)
< (set-fluid! $compiling-leaf 'no))
<
< (define (compiling-leaf?)
< (eq? 'yes (fluid $compiling-leaf)))
<
63,82c56,66
< (deliver-value (if (env-ref? den)
< (local-variable den cenv depth #f)
< (instruction-with-variable op/global exp den #f))
< cont)))
<
< (define (local-variable den cenv depth set?)
< (let ((back (env-ref-back den cenv))
< (over (env-ref-over den)))
< (if (and (compiling-leaf?)
< (= back 0))
< (instruction (if set? op/stack-set! op/stack-ref)
< (+ (- over 1) depth))
< (let ((back (if (compiling-leaf?) (- back 1) back)))
< (if set?
< (instruction op/set-local! back over)
< (case back
< ((0) (instruction op/local0 over)) ;+++
< ((1) (instruction op/local1 over)) ;+++
< ((2) (instruction op/local2 over)) ;+++
< (else (instruction op/local back over))))))))
---
> (if (env-ref? den)
> (let ((back (env-ref-back den cenv))
> (over (env-ref-over den)))
> (deliver-value (case back
> ((0) (instruction op/local0 over)) ;+++
> ((1) (instruction op/local1 over)) ;+++
> ((2) (instruction op/local2 over)) ;+++
> (else (instruction op/local back over)))
> cont))
> (deliver-value (instruction-with-variable op/global exp den #f)
> cont))))
143,145c127,132
< (if (env-ref? den)
< (local-variable den cenv depth #t)
< (instruction-with-variable op/set-global! name den #t)))
---
> (cond ((env-ref? den)
> (instruction op/set-local!
> (env-ref-back den cenv)
> (env-ref-over den)))
> (else
> (instruction-with-variable op/set-global! name den #t))))
203d189
< (note-not-leaf!) ; this isn't strictly necessary, but it keeps things simpler
222,231c208,215
< (cond ((return-cont? cont)
< code)
< (else
< (note-not-leaf!) ; this isn't strictly necessary, but it keeps things simpler
< (sequentially (instruction-with-offset&byte op/make-cont
< (segment-size code)
< depth)
< (note-source-code (cont-source-info cont)
< code)
< (cont-segment cont)))))
---
> (if (return-cont? cont)
> code
> (sequentially (instruction-with-offset&byte op/make-cont
> (segment-size code)
> depth)
> (note-source-code (cont-source-info cont)
> code)
> (cont-segment cont))))
264d247
< (note-not-leaf!)
280,315c263,284
< (let-fluids $compiling-leaf 'maybe
< (lambda ()
< (let ((code (really-compile-lambda-code formals body cenv name)))
< (if (eq? (fluid $compiling-leaf) 'maybe)
< (let-fluids $compiling-leaf 'yes
< (lambda ()
< (really-compile-lambda-code formals body cenv name)))
< code)))))
<
< (define (really-compile-lambda-code formals body cenv name)
< (let* ((nargs (number-of-required-args formals))
< (vars (normalize-formals formals))
< (cenv (if (null? formals)
< cenv ;+++
< (bind-vars vars cenv))))
< (sequentially
< (cond ((n-ary? formals)
< (sequentially
< (instruction op/make-rest-list nargs)
< (instruction op/push)
< (if (compiling-leaf?)
< empty-segment
< (instruction op/make-env (+ nargs 1)))))
< ((null? formals)
< (note-not-leaf!) ; no point if no variables
< empty-segment)
< ((compiling-leaf?)
< empty-segment)
< (else
< (instruction op/make-env nargs)))
< (note-environment
< vars
< (compile-body body
< cenv
< 0
< (return-cont name))))))
---
> (if (null? formals)
> (compile-body body ;+++ Don't make null environment
> cenv
> 0
> (return-cont name))
> (sequentially
> (let ((nargs (number-of-required-args formals)))
> (if (n-ary? formals)
> (sequentially
> (instruction op/make-rest-list nargs)
> (instruction op/push)
> (instruction op/make-env (+ nargs 1)))
> (instruction op/make-env nargs)))
> (let* ((vars (normalize-formals formals))
> (cenv (bind-vars vars cenv)))
> (note-environment
> vars
> (compile-body body
> cenv
> 0
> (return-cont name)))))))
>

81
doc/package.txt Normal file
View File

@ -0,0 +1,81 @@
-- this file is probably obsolete --
The package system interface. Much too complicated.
Signatures
make-simple-signature
make-compound-signature
signature?
signature-ref
signature-walk
Structures
make-structure
structure?
structure-signature
structure-package
structure-name
Packages
make-package
make-simple-package ;start.scm
Lookup and definition operations
package-lookup
package-lookup-type ;comp.scm
package-find-location ;rts/env.scm
package-lookup-location ;segment.scm
probe-package
package-check-assigned
package-check-variable
package-define!
package-define-type! ;hmm.
package-ensure-defined!
Things needed by the form/file/package scanner
for-each-definition ;for integrate-all-primitives!
package-accesses ;for scan-package
package-clauses ;for scan-package
package-file-name ;for scan-package
package-opens ;for scan-package
package-evaluator ;for define-syntax
package-for-syntax ;for define-syntax
Miscellaneous
$note-undefined ;eval.scm
noting-undefined-variables ;eval.scm, etc.
package-uid ;eval.scm
set-shadow-action! ;eval.scm
verify-later! ;for the define-structures macro
reset-packages-state! ;Makefile - for linker
initialize-reified-package! ;for reification
transform-for-structure-ref ;for reification ?
Inessential (for package mutation, programming environment)
check-structure
package-integrate? ;env/debug.scm
set-package-integrate?! ;env/debug.scm
package-loaded? ;env/load-package.scm
set-package-loaded?! ;env/load-package.scm
package-name ;env/command.scm
package-name-table ;env/debuginfo.scm
package-open! ;env/debug.scm
package-system-sentinel ;env/command.scm
package-unstable? ;env/pacman.scm
package? ;env/command.scm
undefined-variables ;env/debug.scm
Location names (also inessential)
flush-location-names
location-name
location-name-table
location-package-name

81
doc/scheme48.man Normal file
View File

@ -0,0 +1,81 @@
.TH LS48 1
.\" File scheme48.man: Manual page template for Scheme 48.
.\" Replace LS48 with the name of your default image and LLIB with the
.\" directory containing scheme48vm and default image.
.SH NAME
LS48 \- a Scheme interpreter
.SH SYNOPSIS
.B LS48
[-i image] [-h heapsize] [-a argument]
.SH DESCRIPTION
.B LS48
is an implementation of the Scheme programming language as described in
the
.I "Revised^4 Report on the Algorithmic Language Scheme."
A runnable system requires two parts, an executable program that implements
the Scheme 48 virtual machine, and an image that is used to initialize
the store of the virtual machine.
.B LS48
is a shell script that starts the virtual machine with an image that runs
in a Scheme command loop.
.PP
The
.B LS48
command loop reads Scheme expressions,
evaluates them, and prints their results.
It also executes commands, which are identified by an initial comma character.
Type the command
.I ,help
to receive a list of available commands.
.PP
The
.B \-h
option causes
.IR heapsize
words to be allocated for both semispaces of the copying garbage
collector. One word is four bytes. Cons cells are currently 3 words,
so if you want to make sure you can allocate, say, a million cons
cells, you should specify
.B \-h
6000000 (actually a little more, to account for the initial heap
image and breathing room).
.PP
The
.I ,dump
and
.I ,build
commands put heap images in files.
The
.B \-i
option causes the initial heap image to be taken from file
.IR image .
The
.B \-a
option causes a list of strings to be passed as the argument
to an image generated using the
.I ,build
command. The first argument to
.I ,build
is a procedure that is passed
the arguments following
.B \-a
and which should return an integer (which is the
return value of the Scheme 48 process).
.PP
.nf
> ,build (lambda (a) (display a) (newline) 0) foo.image
> ,exit
$ LS48 -i foo.image -a mumble
mumble
$
.PP
.fi
.SH FILES
.TP 40
.B LLIB/scheme48vm
the virtual machine.
.TP
.B LLIB/LS48.image
the default image.
.SH BUGS
Procedure calls with more than 63 explicit arguments might not work.

94
doc/src/code.tex Normal file
View File

@ -0,0 +1,94 @@
% Latex Macros for Lisp code in text.
% Based on macros found in C. Rich's library.
\makeatletter
% \vobeyspaces turns all spaces into non-breakable spaces.
% Note: this is like \@vobeyspaces except without spurious space in defn.
{\catcode`\ =\active\gdef\vobeyspaces{\catcode`\ =\active\let =\@xobeysp}}
% \def\vobeytabs turns all tabs into 8 non-breakable spaces
{\catcode`\^^I=\active\gdef\vobeytabs{\catcode`\^^I=\active\let^^I=\xvobeytabs}}
\def\xvobeytabs{\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp}
% \vobeylines turns all cr's into non-breakable \par's
{\catcode`\^^M=\active\gdef\vobeylines{\catcode`\^^M=\active\let^^M=\xvobeylines}}
\def\xvobeylines{\par\penalty10000}
% \obeycrsp turns cr's into non-breakable spaces
{\catcode`\^^M=\active\gdef\obeycrsp{\catcode`\^^M=\active\let^^M=\@xobeysp}}
%% \@noligs prevents ?` and !` from being treated as ligatures
%% added 19 April 86 [copied from Latex sources]
\begingroup
\catcode``=13
\gdef\@noligs{\let`=\@lquote}
\endgroup
% Set up code environment, in which most of the common special characters
% appearing in code are treated verbatim, namely: _ # & ^ $ ~ @ " %
% *** JAR NEEDED $ AND _ IN SOME CODE ***
% Note: \ { } are still enabled so that macros can be called in this
% environment. Use \\, \{ and \} to use these characters verbatim
% in this environment.
% Note: this environment allows no breaking of lines whatsoever; not
% at spaces or hypens. To arrange for a break use the standard \- macro,
% or the \= macro which breaks, but inserts nothing. This is useful,
% for example for allowing hypenated identifiers to be broken, e.g.
% FOO-\=BAR.
\def\setupcode{\parsep=0pt\parindent=0pt
\tt\frenchspacing\catcode``=13\@noligs%
\def\\{\char`\\}%
\@makeother\#\@makeother\&\@makeother\^%\@makeother\_\@makeother\$%
\@makeother\`\@makeother\'%
\@makeother\~\@makeother\@\@makeother\"\@makeother\%\vobeytabs\vobeyspaces}
% Code environment as described above. Note that blank lines are
% not preserved, and lines are not kept on one page. Code is
% indented by the same amount as quotes.
% Note: to increase left margin, use \leftmargini=1in.
% was {\list{}{\parsep=0pt}\item[]\setupcode\obeylines}%
% then {\list{\parsep=0pt\listparindent=0pt\leftmargin=0pt}{}\item[]\setupcode%
\newenvironment{bigcode}%
{\list{}{\parsep=0pt\leftmargin=0pt\labelwidth=0pt\itemindent=0pt%
\listparindent=0pt}\item[]\setupcode%
\obeylines}%
{\endlist}
% Code is just like bigcode, but everything inside is kept on one page
% Note: This actually works by setting a huge penalty for breaking
% between lines of code.
% was {\list{}{\parsep=0pt}\item[]\setupcode\vobeylines}%
\newenvironment{code}%
{\list{}{\parsep=0pt\leftmargin=0pt\labelwidth=0pt\itemindent=0pt%
\listparindent=0pt}\item[]\setupcode%
\vobeylines}%
{\endlist}
% Reasonable separation between lines of code
\newcommand{\codeskip}{\penalty0\vspace{2ex}}
% \cd is used to build a code environment in the middle of text.
% Note: only difference from display code is that cr's are taken
% as unbreakable spaces instead of \par's.
\newcommand{\cd}{\begingroup\setupcode\obeycrsp\startcode}
\newcommand{\startcode}[1]{#1\endgroup}
%\setbox0\hbox{\@xobeysp}\hline{43\wd0}
\makeatother

888
doc/src/external.tex Normal file
View File

@ -0,0 +1,888 @@
\documentclass{article}
\usepackage{hyperlatex}
\include{proto}
% Make each section be a separate HTML file.
\setcounter{htmldepth}{1}
\W\newcommand{\langle}{<}
\W\newcommand{\rangle}{>}
\newcommand{\meta}[1]{{\noindent\mbox{\textrm{$\langle$#1$\rangle$}}}}
\newcommand{\hyper}[1]{\meta{#1}}
\newcommand{\hyperi}[1]{\hyper{#1$_1$}}
\newcommand{\hyperii}[1]{\hyper{#1$_2$}}
\newcommand{\hyperj}[1]{\hyper{#1$_i$}}
\newcommand{\hypern}[1]{\hyper{#1$_n$}}
\renewcommand{\var}[1]{\noindent\mbox{\textit{#1}}}
\newcommand{\vari}[1]{\var{#1$_1$}}
\newcommand{\varii}[1]{\var{#1$_2$}}
\newcommand{\variii}[1]{\var{#1$_3$}}
\newcommand{\variv}[1]{\var{#1$_4$}}
\newcommand{\varj}[1]{\var{#1$_j$}}
\newcommand{\varn}[1]{\var{#1$_n$}}
\W\newcommand{\frenchspacing}{}
\W\newcommand{\textnormal}[1]{#1}
\newcommand{\defining}[1]{{\emph{#1}}}
\newcommand{\exprtype}{syntax}
\W\newcommand{\unskip}{}
\W\newcommand{\textrm}[1]{#1}
\newcommand{\dotsfoo}{\ldots\texonly{\thinspace}}
\htmltitle{Mixing Scheme 48 and C}
\htmladdress{\begin{rawhtml}<a href="http://www-pu.informatik.uni-tuebingen.de/users/sperber/">Mike
Sperber</a>, <a href="http://www.neci.nj.nec.com/homepages/kelsey/">Richard Kelsey</a>\end{rawhtml}}
\title{Using C code with Scheme 48}
\author{Mike Sperber\\\texttt{\small sperber@informatik.uni-tuebingen.de}\\
Richard Kelsey\\\texttt{\small kelsey@research.nj.nec.com}
}
\makeindex
\begin{document}
\maketitle
\begin{abstract}
This document describes an interface for calling C functions
from Scheme, calling Scheme functions from C, and allocating
storage in the Scheme heap.
These facilities are designed to link
existing C libraries into Scheme~48 in order to use them from Scheme.
To this end, Scheme~48 manages stub functions in C that
negotiate between the calling conventions of Scheme and C and the
memory allocation policies of both worlds.
No stub generator is available yet, but writing them is a straightforward task.
\end{abstract}
\section{Available Facilities}
\label{sec:facilities}
The following facilities are available for interfacing between
Scheme~48 and C:
%
\begin{itemize}
\item Scheme code can call C functions.
\item The external interface provides full introspection for all
Scheme objects. External code may inspect, modify, and allocate
Scheme objects arbitrarily.
\item External code may raise exceptions back to Scheme~48 to
signal errors.
\item External code may call back into Scheme. Scheme~48
correctly unrolls the process stack on non-local exits.
\item External modules may register bindings of names to values with a
central registry accessible from
Scheme. Conversely, Scheme code can register shared
bindings for access by C code.
\end{itemize}
%
This document has three parts: the first describes how bindings are
moved from Scheme to C and vice versa, the second tells how to call
C functions from Scheme, and the third covers the C interface
to Scheme objects, including calling Scheme procedures, using the
Scheme heap, and so forth.
\subsection{Scheme structures}
The structure \code{external-calls} has
most of the Scheme functions described here.
The others are in
\code{dynamic-externals}, which has the functions for dynamic loading and
name lookup from
\texonly{Section~\ref{dynamic-externals},}
\htmlonly{the section on \link{Dynamic Loading}{dynamic-externals},}
and \code{shared-bindings}, which has the additional shared-binding functions
described in
\texonly{Section~\ref{more-shared-bindings}.}
\htmlonly{the section on the \link{complete shared-binding interface}{more-shared-bindings}.}
\subsection{C naming conventions}
The names of all of Scheme~48's visible C bindings begin
with `\code{s48\_}' (for procedures and variables) or
`\code{S48\_}' (for macros).
Whenever a C name is derived from a Scheme identifier, we
replace `\code{-}' with `\code{\_}' and convert letters to lowercase
for procedures and uppercase for macros.
A final `\code{?}' converted to `\code{\_p}' (`\code{\_P}' in C macro names).
A final `\code{!}' is dropped.
Thus the C macro for Scheme's \code{pair?} is \code{S48\_PAIR\_P} and
the one for \code{set-car!} is \code{S48\_SET\_CAR}.
Procedures and macros that do not check the types of their arguments
have `\code{unsafe}' in their names.
All of the C functions and macros described have prototypes or definitions
in the file \code{c/scheme48.h}.
The C type for Scheme values is defined there to be \code{s48\_value}.
\section{Shared bindings}
\label{sec:shared-bindings}
Shared bindings are the means by which named values are shared between Scheme
code and C code.
There are two separate tables of shared bindings, one for values defined in
Scheme and accessed from C and the other for values going the other way.
Shared bindings actually bind names to cells, to allow a name to be looked
up before it has been assigned.
This is necessary because C initialization code may be run before or after
the corresponding Scheme code, depending on whether the Scheme code is in
the resumed image or is run in the current session.
\subsection{Exporting Scheme values to C}
\begin{protos}
\proto{define-exported-binding}{ name value}{shared-binding}
\end{protos}
\begin{protos}
\cproto{s48\_value s48\_get\_imported\_binding(char *name)}
\cproto{s48\_value S48\_SHARED\_BINDING\_REF(s48\_value shared\_binding)}
\end{protos}
\noindent\code{Define-exported-binding} makes \cvar{value} available to C code
under as \cvar{name} which must be a \cvar{string}, creating a new shared
binding if necessary.
The C function \code{s48\_get\_imported\_binding} returns the shared binding
defined for \code{name}, again creating it if necessary.
The C macro \code{S48\_SHARED\_BINDING\_REF} dereferences a shared binding,
returning its current value.
\subsection{Exporting C values to Scheme}
\begin{protos}
\cproto{void s48\_define\_exported\_binding(char *name, s48\_value value)}
\end{protos}
\begin{protos}
\proto{lookup-imported-binding}{ string}{shared-binding}
\proto{shared-binding-ref}{ shared-binding}{value}
\end{protos}
\noindent These are used to define shared bindings from C and to access them
from Scheme.
Again, if a name is looked up before it has been defined, a new binding is
created for it.
The common case of exporting a C function to Scheme can be done using
the macro \code{S48\_EXPORT\_FUNCTION(\emph{name})}.
This expands into
\code{s48\_define\_exported\_binding("\cvar{name}", %
s48\_enter\_pointer(\cvar{name}))}
\noindent which boxes the function into a Scheme byte vector and then
exports it.
Note that \code{s48\_enter\_pointer} allocates space in the Scheme heap
and might trigger a
\link{garbage collection}[; see Section~\ref{gc}]{gc}.
\begin{protos}
\syntaxprotonoresult{import-definition}{ \cvar{name}}
\syntaxprotonoresult{import-definition}{ \cvar{name c-name}}
\end{protos}
These macros simplify importing definitions from C to Scheme.
They expand into
\code{(define \cvar{name} (lookup-imported-binding \cvar{c-name}))}
\noindent{}where \cvar{c-name} is as supplied for the second form.
For the first form \cvar{c-name} is derived from \cvar{name} by
replacing `\code{-}' with `\code{\_}' and converting letters to lowercase.
For example, \code{(import-definition my-foo)} expands into
\code{(define my-foo (lookup-imported-binding "my\_foo"))}
\subsection{Complete shared binding interface}
\label{more-shared-bindings}
There are a number of other Scheme functions related to shared bindings;
these are in the structure \code{shared-bindings}.
\begin{protos}
\proto{shared-binding?}{ x}{boolean}
\proto{shared-binding-name}{ shared-binding}{string}
\proto{shared-binding-is-import?}{ shared-binding}{boolean}
\protonoresult{shared-binding-set!}{ shared-binding value}
\protonoresult{define-imported-binding}{ string value}
\protonoresult{lookup-exported-binding}{ string}
\protonoresult{undefine-imported-binding}{ string}{}
\protonoresult{undefine-exported-binding}{ string}{}
\end{protos}
\noindent\code{Shared-binding?} is the predicate for shared-bindings.
\code{Shared-binding-name} returns the name of a binding.
\code{Shared-binding-is-import?} is true if the binding was defined from C.
\code{Shared-binding-set!} changes the value of a binding.
\code{Define-imported-binding} and \code{lookup-exported-binding} are
Scheme versions of \code{s48\_define\_exported\_binding}
and \code{s48\_lookup\_imported\_binding}.
The two \code{undefine-} procedures remove bindings from the two tables.
They do nothing if the name is not found in the table.
The following C macros correspond to the Scheme functions above.
\begin{protos}
\cproto{int\ \ \ \ \ \ \ S48\_SHARED\_BINDING\_P(x)}
\cproto{int\ \ \ \ \ \ \ S48\_SHARED\_BINDING\_IS\_IMPORT\_P(s48\_value s\_b)}
\cproto{s48\_value S48\_SHARED\_BINDING\_NAME(s48\_value s\_b)}
\cproto{void\ \ \ \ \ \ S48\_SHARED\_BINDING\_SET(s48\_value s\_b, s48\_value value)}
\end{protos}
\section{Calling C Functions from Scheme}
\label{sec:external-call}
There are three different ways to call C functions from Scheme, depending on
how the C function was obtained.
\begin{protos}
\proto{call-imported-binding}{ binding arg$_0$ \ldots}{value}
\proto{call-external}{ external arg$_0$ \ldots}{value}
\proto{call-external-value}{ value name arg$_0$ \ldots}{value}
\end{protos}
\noindent
Each of these applies its first argument, a C function, to the rest of
the arguments.
For \code{call-imported-binding} the function argument must be an
imported binding.
For \code{call-external} the function argument must be an external
bound in the current process
(see
\texonly{Section~\ref{dynamic-externals}).}
\htmlonly{the section on \link{Dynamic Loading}{dynamic-externals}).}
For \code{call-external-value} \cvar{value} must be a byte vector
whose contents is a pointer to a C function and \cvar{name} should be
a string naming the function.
The \cvar{name} argument is used only for printing error messages.
For all of these, the C function is passed the \cvar{arg$_i$} values
and the value returned is that returned by C procedure.
Up to twelve arguments may be passed.
There is no method supplied for returning multiple values to
Scheme from C (or vice versa) (mainly because C does not have multiple return
values).
Keyboard interrupts that occur during a call to a C function are ignored
until the function returns to Scheme (this is clearly a
problem; we are working on a solution).
\begin{protos}
\syntaxprotonoresult{import-lambda-definition}
{ \cvar{name} (\cvar{formal} \ldots)}
\syntaxprotonoresult{import-lambda-definition}
{ \cvar{name} (\cvar{formal} \ldots)\ \cvar{c-name}}
\end{protos}
\noindent{}These macros simplify importing functions from C.
They define \cvar{name} to be a function with the given formals that
applies those formals to the corresponding C binding.
\cvar{C-name}, if supplied, should be a string.
These expand into
\begin{example}
(define temp (lookup-imported-binding \cvar{c-name}))
(define \cvar{name}
(lambda (\cvar{formal} \ldots)
(external-apply temp \cvar{formal} \ldots)))
\end{example}
\noindent{}
If \cvar{c-name} is not supplied, it is derived from \cvar{name} by converting
all letters to lowercase and replacing `\code{-}' with `\code{\_}'.
\section{Adding external modules to the \code{Makefile}}
\label{sec:external-modules}
Getting access to C bindings from Scheme requires that the C code be
compiled an linked in with the Scheme~48 virtual machine and that the
relevent shared-bindings be created.
The Scheme~48 makefile has rules for compiling and linking external code
and for specifying initialization functions that should be called on
startup.
There are three Makefile variables that control which external modules are
included in the executable for the virutal machine (\code{scheme48vm}).
\code{EXTERNAL\_OBJECTS} lists the object files to be included in
\code{scheme48vm},
\code{EXTERNAL\_FLAGS} is a list of \code{ld} flags to be used when
creating \code{scheme48vm}, and
\code{EXTERNAL\_INITIALIZERS} is a list of C procedures to be called
on startup.
The procedures listed in \code{EXTERNAL\_INITIALIZERS} should take no
arguments and have a return type of \code{void}.
After changing the definitions of any of these variables you should
do \code{make scheme48vm} to rebuild the virtual machine.
\section{Dynamic Loading}
\label{dynamic-externals}
External code can be loaded into a running Scheme~48 process
and C object-file bindings can be dereferenced at runtime and
their values called
(although not all versions of Unix support all of this).
The required Scheme functions are in the structure \code{dynamic-externals}.
\begin{protos}
\protonoresult{dynamic-load}{ string}{}
\end{protos}
\noindent
\code{Dynamic-load} loads the named file into the current
process, raising an exception if the file cannot be found or if dynamic
loading is not supported by the operating system.
The file must have been compiled and linked appropriately.
For Linux, the following commands compile \code{foo.c} into a
file \code{foo.so} that can be loaded dynamically.
\begin{example}
\% gcc -c -o foo.o foo.c
\% ld -shared -o foo.so foo.o
\end{example}
\begin{protos}
\proto{get-external}{ string}{external}
\proto{external?}{ x}{boolean}
\proto{external-name}{ external}{string}
\proto{external-value}{ external}{byte-vector}
\end{protos}
\noindent
These functions give access to values bound in the current process, and
are used for retrieving values from dynamically-loaded files.
\code{Get-external} returns an \var{external} object that contains the
value of \cvar{name}, raising an exception if there is no such
value in the current process.
\code{External?} is the predicate for externals, and
\code{external-name} and \code{external-value} return the name and
value of an external.
The value is returned as byte vector of length four (on 32-bit
architectures).
The value is that which was extant when \code{get-external} was
called.
The following two functions can be used to update the values of
externals.
\begin{protos}
\proto{lookup-external}{ external}{boolean}
\proto{lookup-all-externals}{}{boolean}
\end{protos}
\noindent
\code{Lookup-external} updates the value of \cvar{external} by looking its
name in the current process, returning \code{\#t} if it is bound and \code{\#f}
if it is not.
\code{Lookup-all-externals} calls \code{lookup-external} on all extant
externals, returning \code{\#f} any are unbound.
\begin{protos}
\proto{call-external}{ external arg$_0$ \ldots}{value}
\end{protos}
\noindent
An external whose value is a C procedure can be called using
\code{call-external}.
See
\texonly{Section~\ref{sec:external-call}}
\htmlonly{the section on \link{calling C functions from Scheme}{sec:external-call}}
for more information.
In some versions of Unix retrieving a value from the current
process may require a non-trivial amount of computation.
We recommend that a dynamically-loaded file contain a single initialization
procedure that creates shared bindings for the values exported by the file.
\section{Compatibility}
Scheme~48's old \code{external-call} function is still available in the structure
\code{externals}, which now also includes \code{external-name} and
\code{external-value}.
The old \code{scheme48.h} file has been renamed \code{old-scheme48.h}.
\section{Accessing Scheme data from C}
\label{sec:scheme-data}
The C header file \code{scheme48.h} provides
access to Scheme~48 data structures
(for compatibility, the old \code{scheme48.h} file is available
as \code{old-scheme48.h}).
The type \code{s48\_value} is used for Scheme values.
When the type of a value is known, such as the integer returned
by \code{vector-length} or the boolean returned by \code{pair?},
the corresponding C procedure returns a C value of the appropriate
type, and not a \code{s48\_value}.
Predicates return \code{1} for true and \code{0} for false.
\subsection{Constants}
\label{sec:constants}
The following macros denote Scheme constants:
%
\begin{description}
\item[\code{S48\_FALSE}] is \verb|#f|.
\item[\code{S48\_TRUE}] is \verb|#t|.
\item[\code{S48\_NULL}] is the empty list.
\item[\code{S48\_UNSPECIFIC}] is a value used for functions which have no
meaningful return value
(in Scheme this value returned by the nullary procedure \code{unspecific}
in the structure \code{util}).
\item[\code{S48\_EOF}] is the end-of-file object
(in Scheme this value is returned by the nullary procedure \code{eof-object}
in the structure \code{i/o-internal}).
\end{description}
\subsection{Converting values}
The following functions convert values between Scheme and C
representations.
The `extract' ones convert from Scheme to C and the `enter's go the other
way.
\begin{protos}
\cproto{unsigned char s48\_extract\_char(s48\_value)}
\cproto{char * \ \ \ s48\_extract\_string(s48\_value)}
\cproto{long \ \ \ \ \ s48\_extract\_integer(s48\_value)}
\cproto{double \ \ \ s48\_extract\_double(s48\_value)}
\cproto{s48\_value s48\_enter\_char(unsigned char)}
\cgcproto{s48\_value s48\_enter\_string(char *)}
\cgcproto{s48\_value s48\_enter\_integer(long)}
\cgcproto{s48\_value s48\_enter\_double(double)}
\end{protos}
\noindent{}The value returned by \code{s48\_extract\_string} points to the actual
storage used by the string; it is valid only until the next
\link{garbage collection}[; see Section~\ref{gc}]{gc}.
\code{s48\_enter\_integer()} needs to allocate storage when
its argument is too large to fit in a Scheme~48 fixnum.
In cases where the number is known to fit within a fixnum (currently 30 bits
including the sign), the following procedures can be used.
These have the disadvantage of only having a limited range, but
the advantage of never causing a garbage collection.
\begin{protos}
\cproto{long \ \ \ \ \ s48\_extract\_fixnum(s48\_value)}
\cproto{s48\_value s48\_enter\_fixnum(long)}
\cproto{long \ \ \ \ \ S48\_MAX\_FIXNUM\_VALUE}
\cproto{long \ \ \ \ \ S48\_MIN\_FIXNUM\_VALUE}
\end{protos}
\noindent An error is signalled if \code{s48\_extract\_fixnum}'s argument
is not a fixnum or if the argument to \code{s48\_enter\_fixnum} is less than
\code{S48\_MIN\_FIXNUM\_VALUE} or greater than \code{S48\_MAX\_FIXNUM\_VALUE}
($-2^{29}$ and $2^{29}-1$ in the current system).
\subsection{C versions of Scheme procedures}
The following macros and procedures are C versions of Scheme procedures.
The names were derived by replacing `\code{-}' with `\code{\_}',
`\code{?}' with `\code{p}', and dropping `\code{!}.
\begin{protos}
\cproto{int \ \ \ \ \ \ S48\_EQ\_P(s48\_value)}
\cproto{int \ \ \ \ \ \ S48\_CHAR\_P(s48\_value)}
\cproto{int \ \ \ \ \ \ S48\_INTEGER\_P(s48\_value)}
\end{protos}
\begin{protos}
\cproto{int \ \ \ \ \ \ S48\_PAIR\_P(s48\_value)}
\cproto{s48\_value S48\_CAR(s48\_value)}
\cproto{s48\_value S48\_CDR(s48\_value)}
\cproto{void \ \ \ \ \ S48\_SET\_CAR(s48\_value, s48\_value)}
\cproto{void \ \ \ \ \ S48\_SET\_CDR(s48\_value, s48\_value)}
\cgcproto{s48\_value s48\_cons(s48\_value, s48\_value)}
\cproto{long \ \ \ \ \ s48\_length(s48\_value)}
\end{protos}
\begin{protos}
\cproto{int \ \ \ \ \ \ S48\_VECTOR\_P(s48\_value)}
\cproto{long \ \ \ \ \ S48\_VECTOR\_LENGTH(s48\_value)}
\cproto{s48\_value S48\_VECTOR\_REF(s48\_value, long)}
\cproto{void \ \ \ \ \ S48\_VECTOR\_SET(s48\_value, long, s48\_value)}
\cgcproto{s48\_value s48\_make\_vector(long, s48\_value)}
\end{protos}
\begin{protos}
\cproto{int \ \ \ \ \ \ S48\_STRING\_P(s48\_value)}
\cproto{long \ \ \ \ \ S48\_STRING\_LENGTH(s48\_value)}
\cproto{char \ \ \ \ \ S48\_STRING\_REF(s48\_value, long)}
\cproto{void \ \ \ \ \ S48\_STRING\_SET(s48\_value, long, char)}
\cgcproto{s48\_value s48\_make\_string(long, char)}
\end{protos}
\begin{protos}
\cproto{int \ \ \ \ \ \ S48\_SYMBOL\_P(s48\_value)}
\cproto{s48\_value s48\_SYMBOL\_TO\_STRING(s48\_value)}
\end{protos}
\begin{protos}
\cproto{int \ \ \ \ \ \ S48\_BYTE\_VECTOR\_P(s48\_value)}
\cproto{long \ \ \ \ \ S48\_BYTE\_VECTOR\_LENGTH(s48\_value)}
\cproto{char \ \ \ \ \ S48\_BYTE\_VECTOR\_REF(s48\_value, long)}
\cproto{void \ \ \ \ \ S48\_BYTE\_VECTOR\_SET(s48\_value, long, int)}
\cgcproto{s48\_value s48\_make\_byte\_vector(long, int)}
\end{protos}
\section{Calling Scheme functions from C}
\label{sec:external-callback}
External code that has been called from Scheme can call back to Scheme
procedures using the following function.
\begin{protos}
\cproto{scheme\_value s48\_call\_scheme(s48\_value proc, long nargs, \ldots)}
\end{protos}
\noindent{}This calls the Scheme procedure \code{proc} on \code{nargs}
arguments, which are passed as additional arguments to \code{s48\_call\_scheme}.
There may be at most ten arguments.
The value returned by the Scheme procedure is returned by the C procedure.
Invoking any Scheme procedure may potentially cause a garbage collection.
There are some complications that occur when mixing calls from C to Scheme
with continuations and threads.
C only supports downward continuations (via \code{longjmp()}).
Scheme continuations that capture a portion of the C stack have to follow the
same restriction.
For example, suppose Scheme procedure \code{s0} captures continuation \code{a}
and then calls C procedure \code{c0}, which in turn calls Scheme procedure
\code{s1}.
Procedure \code{s1} can safely call the continuation \code{a}, because that
is a downward use.
When \code{a} is called Scheme~48 will remove the portion of the C stack used
by the call to \code{c0}.
On the other hand, if \code{s1} captures a continuation, that continuation
cannot be used from \code{s0}, because by the time control returns to
\code{s0} the C stack used by \code{c0} will no longer be valid.
An attempt to invoke an upward continuation that is closed over a portion
of the C stack will raise an exception.
In Scheme~48 threads are implemented using continuations, so the downward
restriction applies to them as well.
An attempt to return from Scheme to C at a time when the appropriate
C frame is not on top of the C stack will cause the current thread to
block until the frame is available.
For example, suppose thread \code{t0} calls a C procedure which calls back
to Scheme, at which point control switches to thread \code{t1}, which also
calls C and then back to Scheme.
At this point both \code{t0} and \code{t1} have active calls to C on the
C stack, with \code{t1}'s C frame above \code{t0}'s.
If thread \code{t0} attempts to return from Scheme to C it will block,
as its frame is not accessable.
Once \code{t1} has returned to C and from there to Scheme, \code{t0} will
be able to resume.
The return to Scheme is required because context switches can only occur while
C code is running.
\code{T0} will also be able to resume if \code{t1} uses a continuation to
throw past its call to C.
\section{Interacting with the Scheme Heap}
\label{sec:heap-allocation}
\label{gc}
Scheme~48 uses a copying, precise garbage collector.
Any procedure that allocates objects within the Scheme~48 heap may trigger
a garbage collection.
Variables bound to values in the Scheme~48 heap need to be registered with
the garbage collector so that the value will be retained and so that the
variables will be updated if the garbage collector moves the object.
The garbage collector has no facility for updating pointers to the interiors
of objects, so such pointers, for example the ones returned by
\code{EXTRACT\_STRING}, will likely become invalid when a garbage collection
occurs.
\subsection{Registering Objects with the GC}
\label{sec:gc-register}
A set of macros are used to manage the registration of local variables with the
garbage collector.
\begin{protos}
\cproto{S48\_DECLARE\_GC\_PROTECT($n$)}
\cproto{void S48\_GC\_PROTECT\_$n$(s48\_value$_1$, $\ldots$, s48\_value$_n$)}
\cproto{void S48\_GC\_UNPROTECT()}
\end{protos}
\code{S48\_DECLARE\_GC\_PROTECT($n$)}, where $1\leq n\leq 9$, allocates
storage for registering $n$ variables.
At most one use of \code{S48\_DECLARE\_GC\_PROTECT} may occur in a block.
\code{S48\_GC\_PROTECT\_$n$($v_1$, $\ldots$, $v_n$)} registers the
$n$ variables (l-values) with the garbage collector.
It must be within scope of a \code{S48\_DECLARE\_GC\_PROTECT($n$)}
and be before any code which can cause a GC.
\code{S48\_GC\_UNPROTECT} removes the block's protected variables from
the garbage collectors list.
It must be called at the end of the block after
any code which may cause a garbage collection.
Omitting any of the three may cause serious and
hard-to-debug problems.
Notably, the garbage collector may relocate an object and
invalidate \code{s48\_value} variables which are not protected.
A \code{gc-protection-mismatch} exception is raised if, when a C
procedure returns to Scheme, the calls
to \code{S48\_GC\_PROTECT()} have not been matched by an equal number of
calls to \code{S48\_GC\_UNPROTECT()}.
Global variables may also be registered with the garbage collector.
\begin{protos}
\cproto{void S48\_GC\_PROTECT\_GLOBAL(\cvar{value})}
\end{protos}
\noindent{}\code{S48\_GC\_PROTECT\_GLOBAL} permanently registers the
variable \cvar{value} (an l-value) with the garbage collector.
There is no way to unregister the variable.
\subsection{Keeping C data structures in the Scheme heap}
\label{sec:external-data}
C data structures can be kept in the Scheme heap by embedding them
inside byte vectors.
The following macros can be used to create and access embedded C objects.
\begin{protos}
\cgcproto{s48\_value S48\_MAKE\_VALUE(type)}
\cproto{type \ \ \ \ \ S48\_EXTRACT\_VALUE(s48\_value, type)}
\cproto{type * \ \ \ S48\_EXTRACT\_VALUE\_POINTER(s48\_value, type)}
\cproto{void \ \ \ \ \ S48\_SET\_VALUE(s48\_value, type, value)}
\end{protos}
\noindent{}
\code{S48\_MAKE\_VALUE} makes a byte vector large enough to hold an object
whose type is \cvar{type}.
\code{S48\_EXTRACT\_VALUE} returns the contents of a byte vector cast to
\cvar{type}, and \code{S48\_EXTRACT\_VALUE\_POINTER} returns a pointer
to the contents of the byte vector.
The value returned by \code{S48\_EXTRACT\_VALUE\_POINTER} is valid only until
the next \link{garbage collection}[(see Section~\ref{gc})]{gc}.
\code{S48\_SET\_VALUE} stores \code{value} into the byte vector.
%There are some convenient macros for external objects that hold
% arrays:
%
%\begin{itemize}
%\item \code{S48\_MAKE\_ARRAY($b$, $s$)} returns an external object
% which holds an array with base type $b$ and size $s$.
%\item \code{S48\_EXTRACT\_ARRAY(\cvar{value}, $b$)} returns the address of the
% array with base type $b$ inside external object \cvar{value}. It does not
% check if \cvar{value} is actually an external object. Note that the address
% returned by \code{S48\_EXTRACT\_ARRAY} is only valid until the next
% \link{heap allocation}[ (see
% Sec.~\ref{sec:heap-allocation})]{sec:heap-allocation}.
%\end{itemize}
\subsection{C code and heap images}
\label{sec:hibernation}
Scheme~48 uses dumped heap images to restore a previous system state.
The Scheme~48 heap is written into a file in a machine-independent and
operating-system-independent format.
The procedures described above may be used to create objects in the
Scheme heap that contain information specific to the current
machine, operating system, or process.
A heap image containing such objects may not work correctly on
when resumed.
To address this problem, a record type may be given a `resumer'
procedure.
On startup, the resumer procedure for a type is applied to each record of
that type in the image being restarted.
This procedure can update the record in a manner appropriate to
the machine, operating system, or process used to resume the
image.
\begin{protos}
\protonoresult{define-record-resumer}{ record-type procedure}
\end{protos}
\noindent{}\code{Define-record-resumer} defines \cvar{procedure},
which should accept one argument, to be the resumer for
\var{record-type}.
The order in which resumer procedures are called is not specified.
The \cvar{procedure} argument to \code{define-record-resumer} may
be \code{\#f}, in which case records of the given type are
not written out in heap images.
When writing a heap image any reference to such a record is replaced by
the value of the record's first field, and an exception is raised
after the image is written.
\section{Using Scheme records in C code}
External modules can create records and access their slots
positionally.
\begin{protos}
\cgcproto{s48\_value S48\_MAKE\_RECORD(s48\_value)}
\cproto{int \ \ \ \ \ \ S48\_RECORD\_P(s48\_value)}
\cproto{s48\_value S48\_RECORD\_TYPE(s48\_value)}
\cproto{s48\_value S48\_RECORD\_REF(s48\_value, long)}
\cproto{void \ \ \ \ \ S48\_RECORD\_SET(s48\_value, long, s48\_value)}
\end{protos}
%
The argument to \code{S48\_MAKE\_RECORD} should be a shared binding
whose value is a record type.
In C the fields of Scheme records are only accessible via offsets,
with the first field having offset zero, the second offset one, and
so forth.
If the order of the fields is changed in the Scheme definition of the
record type the C code must be updated as well.
For example, given the following record-type definition
\begin{example}
(define-record-type thing :thing
(make-thing a b)
thing?
(a thing-a)
(b thing-b))
\end{example}
the identifier \code{:thing} is bound to the record type and can
be exported to C:
\begin{example}
(define-exported-binding "thing-record-type" :thing)
\end{example}
\code{Thing} records can then be made in C:
\begin{example}
static scheme_value thing_record_type_binding = SCHFALSE;
void initialize_things(void)
\{
S48_GC_PROTECT_GLOBAL(thing_record_type_binding);
thing_record_type_binding =
s48_get_imported_binding("thing-record-type");
\}
scheme_value make_thing(scheme_value a, scheme_value b)
\{
s48_value thing;
s48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2(a, b);
thing = s48_make_record(thing_record_type_binding);
S48_RECORD_SET(thing, 0, a);
S48_RECORD_SET(thing, 1, b);
S48_GC_UNPROTECT();
return thing;
\}
\end{example}
Note that the variables \code{a} and \code{b} must be protected
against the possibility of a garbage collection occuring during
the call to \code{s48\_make\_record()}.
\section{Raising exceptions from external code}
\label{sec:exceptions}
The following macros explicitly raise certain errors, immediately
returning to Scheme~48.
Raising an exception performs all
necessary clean-up actions to properly return to Scheme~48, including
adjusting the stack of protected variables.
\begin{protos}
\cproto{s48\_raise\_scheme\_exception(int type, int nargs, \ldots)}
\end{protos}
\noindent{}\code{s48\_raise\_scheme\_exception} is the base procedure for
raising exceptions.
\code{type} is the type of exception, and should be one of the
\code{S48\_EXCEPTION\_}\ldots constants defined in \code{scheme48arch.h}.
\code{nargs} is the number of additional values to be included in the
exception; these follow the \code{nargs} argument and should all have
type \code{s48\_value}.
\code{s48\_raise\_scheme\_exception} never returns.
The following procedures are available for raising particular
types of exceptions.
Like \code{s48\_raise\_scheme\_exception} these never return.
\begin{protos}
\cproto{s48\_raise\_argument\_type\_error(scheme\_value)}
\cproto{s48\_raise\_argument\_number\_error(int nargs, int min, int max)}
\cproto{s48\_raise\_index\_range\_error(long value, long min, long max)}
\cproto{s48\_raise\_closed\_channel\_error()}
\cproto{s48\_raise\_os\_error(int errno)}
\cproto{s48\_raise\_out\_of\_memory\_error()}
\end{protos}
\noindent{}An argument type error indicates that the given value is of the wrong
type.
An argument number error is raised when the number of arguments, \code{nargs},
should be, but isn't, between \code{min} and \code{max}, inclusive.
Similarly, and index range error is raised when \code{value} is not between
between \code{min} and \code{max}, inclusive.
The following macros raise argument type errors if their argument does not
have the required type.
\begin{protos}
\cproto{void S48\_CHECK\_SYMBOL(s48\_value)}
\cproto{void S48\_CHECK\_PAIR(s48\_value)}
\cproto{void S48\_CHECK\_STRING(s48\_value)}
\cproto{void S48\_CHECK\_INTEGER(s48\_value)}
\cproto{void S48\_CHECK\_CHANNEL(s48\_value)}
\cproto{void S48\_CHECK\_BYTE\_VECTOR(s48\_value)}
\cproto{void S48\_CHECK\_RECORD(s48\_value)}
\cproto{void S48\_CHECK\_SHARED\_BINDING(s48\_value)}
\end{protos}
\section{Unsafe functions and macros}
All of the C procedures and macros described above check that their
arguments have the appropriate types and that indexes are in range.
The following procedures and macros are identical to those described
above, except that they do not perform type and range checks.
They are provided for the purpose of writing more efficient code;
their general use is not recommended.
\begin{protos}
\cproto{char \ \ \ \ \ S48\_UNSAFE\_EXTRACT\_CHAR(s48\_value)}
\cproto{char * \ \ \ S48\_UNSAFE\_EXTRACT\_STRING(s48\_value)}
\cproto{long \ \ \ \ \ S48\_UNSAFE\_EXTRACT\_INTEGER(s48\_value)}
\cproto{long \ \ \ \ \ S48\_UNSAFE\_EXTRACT\_DOUBLE(s48\_value)}
\end{protos}
\begin{protos}
\cproto{long \ \ \ \ \ S48\_UNSAFE\_EXTRACT\_FIXNUM(s48\_value)}
\cproto{s48\_value S48\_UNSAFE\_ENTER\_FIXNUM(long)}
\end{protos}
\begin{protos}
\cproto{s48\_value S48\_UNSAFE\_CAR(s48\_value)}
\cproto{s48\_value S48\_UNSAFE\_CDR(s48\_value)}
\cproto{void \ \ \ \ \ S48\_UNSAFE\_SET\_CAR(s48\_value, s48\_value)}
\cproto{void \ \ \ \ \ S48\_UNSAFE\_SET\_CDR(s48\_value, s48\_value)}
\end{protos}
\begin{protos}
\cproto{long \ \ \ \ \ S48\_UNSAFE\_VECTOR\_LENGTH(s48\_value)}
\cproto{s48\_value S48\_UNSAFE\_VECTOR\_REF(s48\_value, long)}
\cproto{void \ \ \ \ \ S48\_UNSAFE\_VECTOR\_SET(s48\_value, long, s48\_value)}
\end{protos}
\begin{protos}
\cproto{long \ \ \ \ \ S48\_UNSAFE\_STRING\_LENGTH(s48\_value)}
\cproto{char \ \ \ \ \ S48\_UNSAFE\_STRING\_REF(s48\_value, long)}
\cproto{void \ \ \ \ \ S48\_UNSAFE\_STRING\_SET(s48\_value, long, char)}
\end{protos}
\begin{protos}
\cproto{s48\_value S48\_UNSAFE\_SYMBOL\_TO\_STRING(s48\_value)}
\end{protos}
\begin{protos}
\cproto{long \ \ \ \ \ S48\_UNSAFE\_BYTE\_VECTOR\_LENGTH(s48\_value)}
\cproto{char \ \ \ \ \ S48\_UNSAFE\_BYTE\_VECTOR\_REF(s48\_value, long)}
\cproto{void \ \ \ \ \ S48\_UNSAFE\_BYTE\_VECTOR\_SET(s48\_value, long, int)}
\end{protos}
\begin{protos}
\cproto{s48\_value S48\_UNSAFE\_SHARED\_BINDING\_REF(s48\_value s\_b)}
\cproto{int\ \ \ \ \ \ \ S48\_UNSAFE\_SHARED\_BINDING\_P(x)}
\cproto{int\ \ \ \ \ \ \ S48\_UNSAFE\_SHARED\_BINDING\_IS\_IMPORT\_P(s48\_value s\_b)}
\cproto{s48\_value S48\_UNSAFE\_SHARED\_BINDING\_NAME(s48\_value s\_b)}
\cproto{void\ \ \ \ \ \ S48\_UNSAFE\_SHARED\_BINDING\_SET(s48\_value s\_b, s48\_value value)}
\end{protos}
\begin{protos}
\cproto{s48\_value S48\_UNSAFE\_RECORD\_TYPE(s48\_value)}
\cproto{s48\_value S48\_UNSAFE\_RECORD\_REF(s48\_value, long)}
\cproto{void \ \ \ \ \ S48\_UNSAFE\_RECORD\_SET(s48\_value, long, s48\_value)}
\end{protos}
\begin{protos}
\cproto{type \ \ \ \ \ S48\_UNSAFE\_EXTRACT\_VALUE(s48\_value, type)}
\cproto{type * \ \ \ S48\_UNSAFE\_EXTRACT\_VALUE\_POINTER(s48\_value, type)}
\cproto{void \ \ \ \ \ S48\_UNSAFE\_SET\_VALUE(s48\_value, type, value)}
\end{protos}
\end{document}

253
doc/src/hyperlatex.sty Normal file
View File

@ -0,0 +1,253 @@
%%
%% LaTeX style to handle hyperlatex files, version 2.3
%%
%% $Modified: Fri May 9 13:40:27 1997 by otfried $
%%
%% This code has GNU copyleft, 1994-1998 Otfried Cheong
%%
\NeedsTeXFormat{LaTeX2e}
\ProvidesPackage{hyperlatex}
[1998/09/08 v2.3 LaTeX2e package for Hyperlatex mode]
\typeout{Package: 'hyperlatex' v2.3 Otfried Cheong}
\RequirePackage{verbatim}
\chardef\other=12
%%
%% Comments,
%%
{\obeylines\gdef\Hlx@W#1^^M{\endgroup\ignorespaces}}
\def\W{\begingroup\obeylines\catcode`\{=\other\catcode`\}=\other\Hlx@W}
\newcommand{\htmlonly}[1]{}
\newcommand{\texorhtml}[2]{#1}
\newenvironment{iftex}{}{}
\newenvironment{latexonly}{}{}
\newcommand{\texonly}[1]{#1}
\newcommand{\T}{}
%%
%% Treatment of special characters
%%
\def\Hlx@nonspecials{}
\def\NotSpecial{\def\Hlx@nonspecials}
\def\Hlx@turnon{\let\do=\@makeother\Hlx@nonspecials}
\AtBeginDocument{\Hlx@turnon}
\let\htmltab=&
%%
%% \begin{tex} ... \end{tex} escapes into raw Tex temporarily.
%% you can write {\tex .....} as well, if already escaped from Html
%%
\newenvironment{tex}{\catcode `\$=3 \catcode `\&=4 \catcode `\#=6
\catcode `\^=7 \catcode `\_=8 \catcode `\%=14}{}
%%
%% \back
%%
\newcommand{\back}{{\tt\char`\\}}
%%
%% \math
%%
\def\math{\@ifnextchar [{\@math}{\@math[]}}
\def\@math[#1]{\begingroup\tex\@@math}
\def\@@math#1{$#1$\endgroup}
%%
%% Commands that don't do anything interesting in Latex
%%
\def\Hlx@pass{\begingroup\let\protect\@unexpandable@noexpand\@sanitize}
\def\Hlx@directory{.}
\newcommand{\htmldirectory}[1]{\gdef\Hlx@directory{#1}}
\newcommand{\htmlname}[1]{}
\newcommand{\htmldepth}[1]{}
\newcommand{\htmltopname}[1]{}
\newcounter{htmldepth}
\newcommand{\htmltitle}[1]{}
\newcommand{\htmladdress}[1]{}
\newcommand{\html}{\Hlx@pass\@html}
\def\@html#1{\endgroup}
\newcommand{\htmlsym}[1]{}
\def\htmlrule{\@ifnextchar [{\@htmlrule}{\@htmlrule[]}}
\def\@htmlrule{\Hlx@pass\@@htmlrule}
\def\@@htmlrule[#1]{\endgroup}
\newcommand{\htmllevel}[1]{}
\newcommand{\htmlmenu}[1]{}
\newcommand{\htmlautomenu}[1]{}
\newcounter{htmlautomenu}
\newcommand{\htmlprintindex}{}
\newcommand{\htmlfootnotes}{}
\newcommand{\htmlmathitalic}[1]{}
\def\htmlimage{\@ifnextchar [{\@htmlimage}{\@htmlimage[]}}
\def\@htmlimage{\Hlx@pass\@@htmlimage}
\def\@@htmlimage[#1]#2{\endgroup}
\newcommand{\xname}{\Hlx@pass\Hlx@ignore}
\def\Hlx@ignore#1{\endgroup}
\newcommand{\htmlpanel}[1]{}
\newcommand{\htmlheading}{\@ifnextchar[{\@htmlheading}{\@htmlheading[]}}
\def\@htmlheading[#1]#2{}
\newcommand{\htmlcaption}[1]{}
\def\htmlattributes{\@ifstar{\@htmlattributes}{\@htmlattributes}}
\def\@htmlattributes{\Hlx@pass\@@htmlattributes}
\def\@@htmlattributes#1#2{\endgroup}
%%
%% GIF environment,
%% will generate bitmaps when `\makegifs' is defined
%%
\newif\if@makegifs
\@ifundefined{makegifs}{\@makegifsfalse}{\@makegifstrue}
\def\gif{\@ifnextchar[{\@gif}{\@gif[b]}}
\def\@gif[#1]{\@ifnextchar[{\@@gif}{\@@gif[100]}}
\def\@@gif[#1]{\gdef\gif@resolution{#1}\@ifnextchar[{\@@@gif}{\@@@gif[300]}}
\def\@@@gif[#1]#2{\gdef\gif@dpi{#1}\gdef\gif@name{#2}\@@@@gif}
\if@makegifs
\typeout{**********************************************}
\typeout{* Making GIF bitmaps from Hyperlatex source! *}
\typeout{**********************************************}
\newwrite\@makegifcmds
\immediate\openout\@makegifcmds=\jobname.makegif
\newbox\@gifbox
\newcount\@gifcount\@gifcount=10000
\def\@@@@gif{\setbox\@gifbox=\vbox\bgroup\tex}
\def\endgif{\egroup
{\global\advance\@gifcount by 1\count0=\@gifcount
\immediate\write\@makegifcmds{dvips\space -f\space -p\space
\the\@gifcount\space -n\space 1\space -E\space -D\space \gif@dpi\space
\jobname.dvi\space>\space\gif@name.ps^^J%
ps2gif\space -res\space \gif@resolution\space \gif@name.ps^^J%
mv\space \gif@name.gif\space \Hlx@directory^^J}
\shipout\copy\@gifbox}\unvbox\@gifbox}
\else
\def\@@@@gif{\tex}
\def\endgif{}
\fi
%%
%% Font style definitions
%%
\let\cit=\textit
\let\code=\texttt
\let\kbd=\texttt
\let\samp=\texttt
\let\strong=\textbf
\let\var=\textsl
\let\dfn=\textit
\let\file=\textit
%%
%% \begin{example} ... \end{example} obeys spaces and lines
%%
%% the indent can be controlled by \exampleindent
%%
\newdimen\exampleindent
\setlength{\exampleindent}{7mm}
\def\Hlx@example{\do\$\do\&\do\#\do\^\do\_\do\~}
{\obeyspaces
\gdef\turnon@spaces{\let =\ \obeyspaces\catcode``=\active\@noligs}}
{\obeylines%
\gdef\turnon@lines{\obeylines\def^^M{\par\def^^M{\leavevmode\par}}}}
\def\example{\list{}{\leftmargin\exampleindent
\itemindent\z@ \rightmargin\z@ \parsep \z@ plus\p@}\item[]\tt
\turnon@spaces\turnon@lines\let\do\@makeother\Hlx@example}
\let\endexample=\endlist
%%
%% font problem: math in example environment seems to need this:
%%
\DeclareFontFamily{OMS}{cmtt}{}
\DeclareFontShape{OMS}{cmtt}{m}{n}{ <-> ssub * cmsy/m/n }{}
\newenvironment{menu}{\list{$\bullet$}{\itemsep0pt\parsep0pt}}{\endlist}
\newenvironment{ifhtml}{\comment}{\endcomment}
\newenvironment{rawhtml}{\comment}{\endcomment}
\def\htmlinclude#1{}
\def\Hlx@empty{}
\def\Hlx@zero{0}
\newif\if@Hlx
\def\Hlx@setclear#1{\@ifundefined{#1}{\@Hlxfalse}{%
\expandafter\ifx\csname#1\endcsname\Hlx@empty\@Hlxfalse
\else\expandafter\ifx\csname#1\endcsname\Hlx@zero\@Hlxfalse
\else\@Hlxtrue\fi\fi}}
\def\ifclear#1{\Hlx@setclear{#1}
\if@Hlx
%% arg empty -> skip
\let\endifset\endcomment\let\Hlx@comment\comment
\else
%% arg set -> ignore begin and end
\let\endifset\relax\let\Hlx@comment\relax
\fi\Hlx@comment}
\def\ifset#1{\Hlx@setclear{#1}
\if@Hlx
% arg empty -> ignore begin and end
\let\endifclear\relax\let\Hlx@comment\relax
\else
% arg set -> skip environment
\let\endifclear\endcomment\let\Hlx@comment\comment
\fi\Hlx@comment}
%%
%% Define \link and \xlink macros
%%
\newcommand{\Hlx@label}{}
\newcommand{\Ref}{\ref{\Hlx@label}}
\newcommand{\Pageref}{\pageref{\Hlx@label}}
\newcommand{\Cite}{\cite{\Hlx@label}}
\newenvironment{Label}[1]{\def\Hlx@Label@label{\label{#1}}\ignorespaces}%
{\Hlx@Label@label\ignorespaces}
\newcommand{\htmlcite}[1]{\cite{#1}}
\def\link{\@ifstar{\@star@link}{\@@link}}
\def\@@link#1{#1\@@@link}
\def\@star@link#1{\@@@link}
\def\@@@link{\@ifnextchar [{\@link}% ] balance
{\@link[]}}
\def\@link[#1]#2{\gdef\Hlx@label{#2}#1}
\def\xlink{\@ifstar{\@star@xlink}{\@@xlink}}
\def\@@xlink#1{\@@@xlink{#1}}
\def\@star@xlink#1{\@@@xlink{}}
\def\@@@xlink#1{\@ifnextchar [{\@xlink{#1}}{\@xlink{#1}[]}}
\def\@xlink#1[#2]#3{\formatxlink{#1#2}{#3}}
\newcommand{\formatxlink}[2]{#1}
%
% index from latex.tex, and changed to include optional argument
%
\def\cindex{\@bsphack\begingroup
\let\protect\@unexpandable@noexpand
\@sanitize
\@ifnextchar [{\Hlx@argwrindex}% balance ]
{\@wrindex}}
\def\Hlx@argwrindex[#1]#2{\@wrindex{#1@#2}}
%% end of hyperlatex.sty

439
doc/src/meeting.tex Normal file
View File

@ -0,0 +1,439 @@
\documentstyle[11pt,twoside]{article}
\input{code}
\input{latex-stuff}
\advance \textheight by 2ex
\begin{document}
\begin{center}
{\Large\bf The Scheme of Things:} \\
\vspace{2ex}
{\Large\bf The June 1992 Meeting$^{\hbox{\scriptsize 1}}$} \\
\vspace{3ex}
Jonathan Rees \\
Cornell University \\
{\tt jar@cs.cornell.edu}
\end{center}
\vspace{3ex}
\footnotetext[1]{To appear in {\em Lisp Pointers} V(4),
October--December 1992.}
An informally constituted group of people interested in the future of
the Scheme programming language met at the Xerox Palo Alto Research
Center on 25 June 1992. The main purpose of the meeting was to work
on the technical content of the next revision of the Scheme report.
We made progress on several fronts:
\begin{itemize}
\item Some differences with the IEEE Scheme standard were resolved.
\item Proposals for multiple return values and {\tt dynamic-wind} were
adopted.
\item A proposal for an {\tt eval} procedure was adopted.
\item The high-level macro facility described in the
Revised$^4$ Report's appendix will be moved into the report proper.
\end{itemize}
Two subcommittees were formed: one to work on exceptions, and one to
charter the formation of a standard library. The subcommittees will
report back to the group with proposals for inclusion in the report.
It had been hoped that there would be progress on some other fronts
(user-defined types, dynamic binding, improvements to ``rest''
parameters), but after inconclusive discussion these topics were
dropped. These topics will probably be taken up again in the future.
Norman Adams was appointed the Revised$^5$ Report's editor. It is
hoped that it will be ready by early 1993, so as to precede the
reconstitution of the IEEE standard group.
This article is my own interpretation of what transpired, and should
not be construed as definitive.
\piece{Agreement with the IEEE Scheme standard}
Until now, the Scheme reports have encouraged but not required the
empty list {\tt()} and the boolean false value {\tt\#f} to be
distinct. It has been the intent ever since the Revised Revised
Report, however, that this distinction would eventually be required.
The IEEE Scheme standard bit the bullet in 1990, and now the
Revised$^5$ report follows.
The standard also dropped the distinction between essential and
not-essential language features; most features that were formerly not
essential, such as n-ary {\tt+} and {\tt apply}, are now required.
The Revised$^5$ Report will adopt this stance, at least as regards
language features that are shared with the IEEE standard.
Non-essential non-IEEE oddities such as {\tt transcript-on} and {\tt
transcript-off} and the proposed {\tt interaction-\ok{}environment} (see
below) were not discussed at the meeting, however, and consensus on
their status will have to be reached via electronic mail.
A third aspect of the standard that was adopted was a certain obscure
paragraph regarding assignments to top-level variables (section 6,
paragraph 2). The effect of this is that if a program contains an
assignment to any top-level variable, then the program must contain a
{\tt define} for that variable; it is not sufficient that the variable
be bound. This has been the case for most variables, but the rule
applies as well to variables such as {\tt car} that have built-in
bindings. In addition, it is clarified that if a program makes such a
definition or assignment, then the behavior of built-in procedures
will not be affected. For example, redefining {\tt length} cannot
affect the behavior of the built-in {\tt list->vector} procedure.
If in some particular implementation {\tt list->vector} is written
in Scheme and calls {\tt length}, then it must be sure to call the
built-in {\tt length} procedure, not whatever happens to be the value
of the variable {\tt length}.
\piece{Multiple return values}
The {\tt call-with-values} and {\tt values} procedures were described
in an earlier Scheme of Things ({\em Lisp Pointers}, volume IV, number
1), but I'll review them here. The following is adapted from John Ramsdell's
concise description:
\begin{list}{}{}{}\item
{\tt(values \var{object} $\ldots$)}
\hfill {\rm essential procedure}
{\tt values} delivers all of its arguments to its continuation.
\vspace{2ex}
{\tt(call-with-values \var{thunk} \var{receiver})}
\hfill {\rm essential procedure}
{\tt call-with-values} calls its \var{thunk} argument with a
continuation that, when passed some values, calls the
\var{receiver} procedure with those values as arguments.
The continuation for the call to \var{receiver} is the
continuation of the call to {\tt call-with-values}.
\end{list}
Except for continuations created by the {\tt call-with-values}
procedure, all continuations take exactly one value, as now; the
effect of passing no value or more than one value to continuations
that were not created by {\tt call-with-values} is unspecified (as
indeed it is unspecified now).
{\tt values} might be defined as follows:
\begin{code}
(define (values . things)
(call-with-current-continuation
(lambda (cont) (apply cont things))))
\end{code}
That is, the procedures supplied by {\tt
call-with-current-continuation} must be passed the same number of
arguments as values expected by the continuation.
Because the behavior of a number-of-values mismatch between a
continuation and its invoker is unspecified, some implementations may
assign some specific meaning to such situations; for example, extra
values might be ignored, or defaults might be supplied for missing
values. Thus this multiple return value proposal is compatible with
Common Lisp's multiple values, but strictly more conservative than it.
The behavior of programs in such situations was a point of contention
among the authors, which is why only the least common denominator
behavior was specified.
\piece{Unwind/wind protection}
{\tt dynamic-wind}, which was described previously in this column (when it
was The Scheme Environment; {\em Lisp Pointers}, volume I, number 2),
is already implemented in many Scheme dialects. {\tt dynamic-wind}
takes three arguments, all of which are thunks (procedures of no arguments).
It behaves as if it were defined with
\begin{code}
(define (dynamic-wind before during after)
(before)
(call-with-values during
(lambda results
(after)
(apply values results))))
\end{code}
except that the execution of the {\tt during} thunk is ``protected''
against non-local entries and exits: a throw out of the execution
of {\tt during} will cause the {\tt after} thunk to be invoked, and a
throw from outside back in will cause the {\tt before} thunk to be
invoked. (By ``throw'' I mean an invocation of an explicit
continuation as obtained from {\tt call-with-current-continuation}.)
For details, the earlier Scheme Environment column refers the reader
to Friedman and Haynes's paper ``Constraining Control'' in POPL 1985,
but to save you the trouble of looking that up, I have supplied a more
direct implementation of {\tt dynamic-wind} in an appendix to the
present column.
{\tt dynamic-wind} was adopted with the following clarifications: The
semantics of {\tt(dynamic-wind \var{before} \var{during} \var{after})}
should leave unspecified what happens if a throw occurs out of {\em
before} or {\em after}\/; and it is best to defer interrupts during {\em
before} and {\em after}.
\piece{Evaluating computed expressions}
The original 1975 memo on Scheme described {\tt evaluate},
which was analogous to Lisp's traditional {\tt eval} function. {\tt
evaluate} took a single argument, an S-expression, and invoked an
interpreter on it. For example:
\begin{code}
(let ((name '+)) (evaluate (list name 2 3)))
\ev 5
\end{code}
Scheme being lexically scoped, however, there was some confusion over
which environment the expression was to be evaluated in. Should
\begin{code}
(let ((name '+))
(let ((+ *))
(evaluate (list name 2 3))))
\end{code}
evaluate to 5 or to 6?
To clarify matters, the Revised Report replaced {\tt evaluate} with
{\tt enclose}, which took two arguments, a {\tt lambda}-expression and
a representation of an environment from which to supply bindings of the
{\tt lambda}-expression's free variables. For example:
\begin{code}
(let ((name '+))
(let ((+ *))
((enclose (list 'lambda '() (list name 2 3))
(list (cons '+ +))))))
\ev 6
\end{code}
This forced the programmer to be explicit about the {\tt
lambda}-expression's enclosing environment.
For various technical and practical reasons, there was no {\tt eval}
analogue in subsequent Scheme reports. The major stumbling blocks
were how to describe {\tt eval} formally and how to define something
that makes sense in all extant variants of the language. Some Scheme
implementations contain a distinguished top-level environment, while
others extend the language by providing ways to create multiple
environments, any of which might serve equally well.
The {\tt eval} proposal adopted at the June meeting, which I reproduce
here, is one that comes from Bill Rozas.
\begin{list}{}{}{}\item
{\tt(eval \var{expression} \var{environment-specifier})}
\hfill {\rm essential procedure}
{\tt eval} evaluates \var{expression} in the environment indicated
by {\em environment-\discretionary{}{}{}specifier}. {\em
environment-specifier} may be the return value of one of the three
procedures described below, or implementation-specific extensions.
No other operations on environment specifiers are defined by this
proposal.
Implementations may allow non-expression programs (i.e.\
definitions) as the first argument to {\tt eval} \var{only} when
the second argument is the return value of {\tt interaction-environment}
or some implementation extension. In other words, {\tt eval} will never
create new bindings in the return value of {\tt null-environment} or
{\tt scheme-report-environment}.
\vspace{2ex}
{\tt(scheme-report-environment \var{version})}
\hfill {\rm essential procedure}
{\em Version} must be an exact non-negative integer corresponding to a
version of one of the Revised$^n$ Reports on Scheme. This procedure
returns a specifier for an environment that contains exactly the
set of bindings specified in the corresponding report that the
implementation supports. Not all versions may be available in all
implementations at all times. However, an implementation that
conforms to version $n$ of the Revised$^n$ Reports on Scheme must
accept version $n$. If {\tt scheme-report-environment} is
available, but the specified version is not, the procedure will
signal an error.
The effect of assigning (through the use of {\tt eval}) a variable
bound in a {\tt scheme-report-environment} (e.g.\ {\tt car}) is
unspecified. Thus the environments specified by the return
values of {\tt scheme-report-environment} may be immutable.
\vspace{2ex}
{\tt(null-environment)}
\hfill {\rm essential procedure}
This procedure returns a specifier for an environment that contains no
variable bindings, but contains (syntactic) bindings for all the
syntactic keywords defined in the report, and no others.
\vspace{2ex}
%\newpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
{\tt(interaction-environment)}
\hfill {\rm procedure}
This procedure returns a specifier for an environment that
contains imple\-men\-ta\-tion-defined bindings, typically a superset of
those listed in the report. The intent is that this procedure
will return a specifier for the environment in which the
implementation would evaluate expressions dynamically typed by the
user.
\end{list}
Rozas explains:
``The proposal does not imply the existence or support of first-class
environments, although it is compatible with them.
The proposal only requires a way of associating tags with a finite set
of distinguished environments which the implementations can maintain
implicitly (without reification).
``\,`Pascal-like' implementations can support both {\tt null-environment} and
%\penalty0
{\tt scheme-report-environment} since the environments specified by
the return values of these procedures need not share any bindings with
the current program. A version of {\tt eval} that supports these but
not {\tt interaction-environment} can be written portably,
but can be better written by the implementor, since it can share code
with the default evaluator or compiler.''
Here ``Pascal-like'' refers to implementations that are restricted to
static compilation and linking. Because an {\tt eval} that doesn't
support
\penalty0
{\tt interaction-\discretionary{}{}{}environment} can be written
entirely in the Scheme language described by the rest of the report,
it raises no troublesome questions about its formal semantics.
\piece{Macros}
The consensus of the meeting was that {\tt define-syntax}, {\tt
syntax-rules}, {\tt let-\discretionary{}{}{}syntax}, and {\tt
letrec-syntax} should be moved out of the report's appendix into the
main body of the report. Although everyone agrees that a low-level
macro facility is important, the subject is too contentious at
present, with three or more competing proposals at present. The
disposition of the rest of the appendix and of the other low-level
proposals will be left up to the report's editor.
\piece{Committee work}
There is a strong sense that some kind of exception system is needed.
However, no specific proposal was ready at the time of the meeting. A
committee has been formed to work on one. What seems to be in the
air might be described as a highly distilled version of the condition
system that Kent Pitman developed for Common Lisp. I hope that I'll
be able to report on this in a future column.
On the subject of libraries, Will Clinger's minutes report that
``the authors perceive a need to give some library official status. In
fact, we need to give official sanction to multiple libraries. There
is reason to distinguish between accepted (or standard) libraries,
experimental libraries, and proposals. The accepted libraries can
reduce the intellectual size of the language by removing things like
{\tt string->list} from the report. The experimental libraries would
contain solid implementations of experimental features, including
things that might never deserve to be in the report. The proposal
libraries could contain anything implemented in portable Scheme.''
Among the content of the accepted libraries, some features (such as
those that may be moved out of the body of the report) may be required
to be built in to implementations, while others will be expected to be
available on demand (perhaps using something similar to, but not the
same as, {\tt require} as found in Common Lisp and GNU Emacs).
A librarian was appointed (Rees), and a library committee is
developing proposals for the charter, structure, and content of the
libraries.
\separator
I would like to acknowledge Will Clinger, who prepared the minutes of
the meeting, and the various people who contributed proposals,
including Bill Rozas and John Ramsdell. Any errors here are my
responsibility, however. Thanks also to Norman Adams and Richard
Kelsey for corrections to a draft of this article.
I would also like to belatedly acknowledge Norman Adams, Pavel
Curtis, Bruce Donald, and Richard Kelsey for their comments on drafts of
my previous column.
For future columns, I am entertaining various topic possibilities,
including {\tt eval}, threads, {\tt amb}, and monads.
If you have other ideas, and particularly if you think the written
record on the language is particularly poor in certain areas, please
write and let me know.
\vspace{2ex}
%\newpage
%\bgroup \small
\piece{Appendix: An implementation of {\tt dynamic-wind}}
This program is based on my vague recollection of an ancient
manuscript by Chris Hanson and John Lamping. I apologize for the lack
of data abstraction, but the code is more concise this way.
A state space is a tree with the current state at the root. Each node other
than the root is a triple $\langle\var{before}, \var{after},
\var{parent}\rangle$, represented in this implementation as two pairs
{\tt((\var{before} .\ \var{after}) .\ \var{parent})}.
Navigating between states requires re-rooting the tree by reversing
parent-child links.
Since {\tt dynamic-wind} interacts with {\tt
call-with-current-continuation}, this implementation must replace the
usual definition of the latter.
\begin{code}
(define *here* (list #f))
\codeskip
(define original-cwcc call-with-current-continuation)
\codeskip
(define (call-with-current-continuation proc)
(let ((here *here*))
(original-cwcc (lambda (cont)
(proc (lambda results
(reroot! here)
(apply cont results)))))))
\codeskip
(define (dynamic-wind before during after)
(let ((here *here*))
(reroot! (cons (cons before after) here))
(call-with-values during
(lambda results
(reroot! here)
(apply values results)))))
\codeskip
(define (reroot! there)
(if (not (eq? *here* there))
(begin (reroot! (cdr there))
(let ((before (caar there))
(after (cdar there)))
(set-car! *here* (cons after before))
(set-cdr! *here* there)
(set-car! there #f)
(set-cdr! there '())
(set! *here* there)
(before)))))
\end{code}
%\egroup
\end{document}

728
doc/src/module.tex Normal file
View File

@ -0,0 +1,728 @@
\documentstyle[11pt]{article}
\include{code}
\include{latex-stuff}
\newcommand{\goesto}{\hbox{$\longrightarrow$}}
\newcommand{\alt}{$\vert$}
\newcommand{\arbno}[1]{{{#1}$^*$}}
\newcommand{\hack}{Scheme~48}
\begin{document}
\begin{center}
{\Large\bf Another Module System for Scheme}
\vspace{2ex}
Jonathan Rees \\
3 January 1993 (updated 15 January 1994)
\end{center}
\vspace{3ex}
This memo describes a module system for the Scheme programming
language. The module system is unique in the extent to which it
supports both static linking and rapid turnaround during program
development. The design was influenced by Standard ML
modules\cite{MacQueen:Modules} and by the module system for Scheme
Xerox\cite{Curtis-Rauen:Modules}. It has also been shaped by the
needs of \hack{}, a virtual-machine-based Scheme implementation
designed to run both on workstations and on relatively small (less
than 1 Mbyte) embedded controllers.
Except where noted, everything described here is implemented in
\hack{}, and exercised by the \hack{} implementation and a few
application programs.
Unlike the Common Lisp package system, the module system described
here controls the mapping of names to denotations, not the
mapping of strings to symbols.
\subsection*{Introduction}
The module system supports the structured division of a corpus of
Scheme software into a set of modules. Each module has its own
isolated namespace, with visibility of bindings controlled by module
descriptions written in a special {\em configuration language.}
A module may be instantiated multiple times, producing several {\em
packages}, just as a lambda-expression can be instantiated multiple
times to produce several different procedures. Since single
instantiation is the normal case, I will defer discussion of multiple
instantiation until a later section. For now you can think of a
package as simply a module's internal environment mapping names to
denotations.
A module exports bindings by providing views onto the underlying
package. Such a view is called a {\em structure} (terminology from
Standard ML). One module may provide several different views. A
structure is just a subset of the package's bindings. The particular
set of names whose bindings are exported is the structure's {\em
interface}.
A module imports bindings from other modules by either {\em opening}
or {\em accessing} some structures that are built on other packages.
When a structure is opened, all of its exported bindings are visible
in the client package. On the other hand, bindings from an accessed
structure require explicitly qualified references written with the
{\tt structure-ref} operator.
For example:
\begin{code}
(define-structure foo (export a c cons)
(open scheme)
(begin (define a 1)
(define (b x) (+ a x))
(define (c y) (* (b a) y))))
\codeskip
(define-structure bar (export d)
(open scheme foo)
(begin (define (d w) (+ a (c w)))))
\end{code}
This configuration defines two structures, {\tt foo} and {\tt bar}.
{\tt foo} is a view on a package in which the {\tt scheme} structure's
bindings (including {\tt define} and {\tt +}) are visible, together
with bindings for {\tt a}, {\tt b},
and {\tt c}. {\tt foo}'s interface is {\tt (export a c cons)}, so of
the bindings in its underlying package, {\tt foo} only exports those
three. Similarly, structure {\tt bar} consists of the binding of {\tt
d} from a package in which both {\tt scheme}'s and {\tt foo}'s
bindings are visible. {\tt foo}'s binding of {\tt cons} is imported
from the Scheme structure and then re-exported.
A module's body, the part following {\tt begin} in the above example,
is evaluated in an isolated lexical scope completely specified by the
package definition's {\tt open} and {\tt access} clauses. In
particular, the binding of the syntactic operator {\tt define-structure}
is not visible unless it comes from some opened structure. Similarly,
bindings from the {\tt scheme} structure aren't visible unless they
become so by {\tt scheme} (or an equivalent structure) being opened.
\subsection*{The configuration language}
The configuration language consists of top-level defining forms for
modules and interfaces. Its syntax is given in figure~1.
\setbox0\hbox{\goesto}
\newcommand{\altz}{\hbox to 1\wd0{\hfil\alt}}
%%%%% Put the figure inside a box ?
\begin{figure}
%\begin{frameit}
\begin{tabbing}
\syn{configuration} \=\goesto{}~\arbno{\syn{definition}} \\
\syn{definition} \=\goesto{}~
\tt(define-structure \syn{name} \syn{interface}
\arbno{\syn{clause}}) \\
\>\altz{}~ \tt(define-structures (\arbno{(\syn{name} \syn{interface})})
\arbno{\syn{clause}}) \\
\>\altz{}~ \tt(define-interface \syn{name} \syn{interface}) \\
\>\altz{}~ \tt(define-syntax \syn{name} \syn{transformer-spec}) \\
\syn{clause} \=\goesto{}~ \tt(open \arbno{\syn{name}}) \\
\>\altz{}~ \tt(access \arbno{\syn{name}}) \\
\>\altz{}~ \tt(begin \syn{program}) \\
\>\altz{}~ \tt(files \arbno{\syn{filespec}}) \\
\>\altz{}~ \tt(optimize \arbno{\syn{optimize-spec}}) \\
\>\altz{}~ \tt(for-syntax \arbno{\syn{clause}}) \\
\syn{interface} \=\goesto{}~ \tt(export \arbno{\syn{item}}) \\
\>\altz{}~ \syn{name} \\
\>\altz{}~ \tt(compound-interface \arbno{\syn{interface}}) \\
\syn{item} \=\goesto{}~ \syn{name}~
\alt{}~ \tt(\syn{name} \syn{type})
\alt{}~ \tt((\arbno{\syn{name}}) \syn{type})
\end{tabbing}
\caption{The configuration language.}
%\end{frameit}
\end{figure}
A {\tt define-structure} form introduces a binding of a name to a
structure. A structure is a view on an underlying package which is
created according to the clauses of the {\tt define-structure} form.
Each structure has an interface that specifies which bindings in the
structure's underlying package can be seen via that structure in other
packages.
An {\tt open} clause specifies which structures will be opened up for
use inside the new package. At least one package must be specified or
else it will be impossible to write any useful programs inside the
package, since {\tt define}, {\tt lambda}, {\tt cons}, {\tt
structure-ref}, etc.\ will be unavailable. Typical packages to list
in the {\tt open} clause are {\tt scheme}, which exports all bindings
appropriate to Revised$^5$ Scheme, and {\tt structure-refs}, which
exports the {\tt structure-ref} operator (see below). For building
structures that export structures, there is a {\tt defpackage} package
that exports the operators of the configuration language. Many other
structures, such as record and hash table facilities, are also
available in the \hack{} implementation.
An {\tt access} clause specifies which bindings of names to structures
will be visible inside the package body for use in {\tt structure-ref}
forms. {\tt structure-\ok{}ref} has the following syntax:
\begin{tabbing}
\qquad \syn{expression} \goesto{}~
\tt(structure-ref \syn{struct-name} \syn{name})
\end{tabbing}
The \syn{struct-name} must be the name of an {\tt access}ed structure,
and \syn{name} must be something that the structure exports. Only
structures listed in an {\tt access} clause are valid in a {\tt
structure-ref}. If a package accesses any structures, it should
probably open the {\tt structure-refs} structure so that the {\tt
structure-ref} operator itself will be available.
The package's body is specified by {\tt begin} and/or {\tt files}
clauses. {\tt begin} and {\tt files} have the same semantics, except
that for {\tt begin} the text is given directly in the package
definition, while for {\tt files} the text is stored somewhere in the
file system. The body consists of a Scheme program, that is, a
sequence of definitions and expressions to be evaluated in order. In
practice, I always use {\tt files} in preference to {\tt begin}; {\tt
begin} exists mainly for expository purposes.
A name's imported binding may be lexically overridden or {\em shadowed}
by simply defining the name using a defining form such as {\tt define}
or {\tt define-\ok{}syntax}. This will create a new binding without having
any effect on the binding in the opened package. For example, one can
do {\tt(define car 'chevy)} without affecting the binding of the name
{\tt car} in the {\tt scheme} package.
Assignments (using {\tt set!})\ to imported and undefined variables
are not allowed. In order to {\tt set!}\ a top-level variable, the
package body must contain a {\tt define} form defining that variable.
Applied to bindings from the {\tt scheme} structure, this restriction
is compatible with the requirements of the Revised$^5$ Scheme report.
It is an error for two of a package's opened structures to export two
different bindings for the same name. However, the current
implementation does not check for this situation; a name's binding is
always taken from the structure that is listed first within the {\tt
open} clause. This may be fixed in the future.
File names in a {\tt files} clause can be symbols, strings, or lists
(Maclisp-style ``namelists''). A ``{\tt.scm}'' file type suffix is
assumed. Symbols are converted to file names by converting to upper
or lower case as appropriate for the host operating system. A
namelist is an operating-system-indepedent way to specify a file
obtained from a subdirectory. For example, the namelist {\tt(rts
record)} specifies the file {\tt record.scm} in the {\tt rts}
subdirectory.
If the {\tt define-structure} form was itself obtained from a file,
then file names in {\tt files} clauses are interpreted relative to the
directory in which the file containing the {\tt define-structure} form
was found. You can't at present put an absolute path name in the {\tt
files} list.
\subsection*{Interfaces}
An interface can be thought of as the type of a structure. In its
basic form it is just a list of variable names, written {\tt(export
\var{name} \etc)}. However, in place of
a name one may write {\tt(\var{name} \var{type})}, indicating the type
of \var{name}'s binding. Currently the type field is ignored, except
that exported macros must be indicated with type {\tt :syntax}.
Interfaces may be either anonymous, as in the example in the
introduction, or they may be given names by a {\tt define-interface}
form, for example
\begin{code}
(define-interface foo-interface (export a c cons))
(define-structure foo foo-interface \etc)
\end{code}
In principle, interfaces needn't ever be named. If an interface
had to be given at the point of a structure's use as well as at the
point of its definition, it would be important to name interfaces in
order to avoid having to write them out twice, with risk of mismatch
should the interface ever change. But they don't.
Still, there are several reasons to use {\tt define-interface}:
\begin{enumerate}
\item It is important to separate the interface definition from the
package definitions when there are multiple distinct structures that
have the same interface --- that is, multiple implementations of the
same abstraction.
\item It is conceptually cleaner, and useful for documentation
purposes, to separate a module's specification (interface) from its
implementation (package).
\item My experience is that configurations that are separated into
interface definitions and package definitions are easier to read; the
long lists of exported bindings just get in the way most of the time.
\end{enumerate}
The {\tt compound-interface} operator forms an interface that is the
union of two or more component interfaces. For example,
\begin{code}
(define-interface bar-interface
(compound-interface foo-interface (export mumble)))
\end{code}
defines {\tt bar-interface} to be {\tt foo-interface} with the name
{\tt mumble} added.
\subsection*{Macros}
Hygienic macros, as described in
\cite{Clinger-Rees:Macros,Clinger-Rees:R4RS}, are implemented.
Structures may export macros; auxiliary names introduced into the
expansion are resolved in the environment of the macro's definition.
For example, the {\tt scheme} structure's {\tt delay} macro
is defined by the rewrite rule
\begin{code}
(delay \var{exp}) \xform (make-promise (lambda () \var{exp}))\rm.
\end{code}
The variable {\tt make-promise} is defined in the {\tt scheme}
structure's underlying package, but is not exported. A use of the
{\tt delay} macro, however, always accesses the correct definition
of {\tt make-promise}. Similarly, the {\tt case} macro expands into
uses of {\tt cond}, {\tt eqv?}, and so on. These names are exported
by {\tt scheme}, but their correct bindings will be found even if they
are shadowed by definitions in the client package.
\subsection*{Higher-order modules}
There are {\tt define-module} and {\tt define} forms for
defining modules that are intended to be instantiated multiple times.
But these are pretty kludgey --- for example, compiled code isn't
shared between the instantiations --- so I won't describe them yet.
If you must know, figure it out from the following grammar.
\begin{tabbing}
\qquad
\syn{definition} \=\goesto{}~
\tt(d\=\tt{}efine-module (\syn{name} \arbno{(\syn{name} \syn{interface})}) \\
\> \>\arbno{\syn{definition}} \\
\> \>\syn{name}\tt) \\
\>\altz{}~ \tt(define \syn{name}
(\syn{name} \arbno{\syn{name}}))
\end{tabbing}
\subsection*{Compiling and linking}
\hack{} has a static linker that produces stand-alone heap images
from module descriptions. One specifies a particular procedure in a
particular structure to be the image's startup procedure (entry
point), and the linker traces dependency links as given by {\tt open}
and {\tt access} clauses to determine the composition of the heap
image.
There is not currently any provision for separate compilation; the
only input to the static linker is source code. However, it will not
be difficult to implement separate compilation. The unit of
compilation is one module (not one file). Any opened or accessed
structures from which macros are obtained must be processed to the
extent of extracting its macro definitions. The compiler knows from
the interface of an opened or accessed structure which of its exports
are macros. Except for macros, a module may be compiled without any
knowledge of the implementation of its opened and accessed structures.
However, inter-module optimization will be available as an option.
The main difficulty with separate compilation is resolution of
auxiliary bindings introduced into macro expansions. The module
compiler must transmit to the loader or linker the search path by
which such bindings are to be resolved. In the case of the {\tt delay}
macro's auxiliary {\tt make-promise} (see example above), the loader
or linker needs to know that the desired binding of {\tt make-promise}
is the one apparent in {\tt delay}'s defining package, not in the
package being loaded or linked.
[I need to describe structure reification.]
\subsection*{Semantics of configuration mutation}
During program development it is often desirable to make changes to
packages and interfaces. In static languages it may be necessary to
recompile and re-link a program in order for such changes to be
reflected in a running system. Even in interactive Common Lisp
implementations, a change to a package's exports often requires
reloading clients that have already mentioned names whose bindings
change. Once {\tt read} resolves a use of a name to a symbol, that
resolution is fixed, so a change in the way that a name resolves to a
symbol can only be reflected by re-{\tt read}ing all such references.
The \hack{} development environment supports rapid turnaround in
modular program development by allowing mutations to a program's
configuration, and giving a clear semantics to such mutations. The
rule is that variable bindings in a running program are always
resolved according to current structure and interface bindings, even
when these bindings change as a result of edits to the configuration.
For example, consider the following:
\begin{code}
(define-interface foo-interface (export a c))
(define-structure foo foo-interface
(open scheme)
(begin (define a 1)
(define (b x) (+ a x))
(define (c y) (* (b a) y))))
(define-structure bar (export d)
(open scheme foo)
(begin (define (d w) (+ (b w) a))))
\end{code}
This program has a bug. The variable {\tt b}, which is free in the
definition of {\tt d}, has no binding in {\tt bar}'s package. Suppose
that {\tt b} was supposed to be exported by {\tt foo}, but was omitted
from {\tt foo-interface} by mistake. It is not necessary to
re-process {\tt bar} or any of {\tt foo}'s other clients at this point.
One need only change {\tt foo-interface} and inform the development
system of that one change (using, say, an appropriate Emacs command),
and {\tt foo}'s binding of {\tt b} will be found when procedure {\tt
d} is called.
Similarly, it is also possible to replace a structure; clients of the
old structure will be modified so that they see bindings from the new
one. Shadowing is also supported in the same way. Suppose that a
client package $C$ opens a structure {\tt foo} that exports a name
{\tt x}, and {\tt foo}'s implementation obtains the binding of {\tt x}
as an import from some other structure {\tt bar}. Then $C$ will see
the binding from {\tt bar}. If one then alters {\tt foo} so that it
shadows {\tt bar}'s binding of {\tt x} with a definition of its own,
then procedures in $C$ that reference {\tt x} will automatically see
{\tt foo}'s definition instead of the one from {\tt bar} that they saw
earlier.
This semantics might appear to require a large amount of computation
on every variable reference: The specified behavior requires scanning
the package's list of opened structures, examining their interfaces,
on every variable reference, not just at compile time. However, the
development environment uses caching with cache invalidation to make
variable references fast.
\subsection*{Command processor support}
While it is possible to use the \hack{} static linker for program
development, it is far more convenient to use the development
environment, which supports rapid turnaround for program changes. The
programmer interacts with the development environment through a {\em
command processor}. The command processor is like the usual Lisp
read-eval-print loop in that it accepts Scheme forms to evaluate.
However, all meta-level operations, such as exiting the Scheme system
or requests for trace output, are handled by {\em commands,} which are
lexically distinguished from Scheme forms. This arrangement is
borrowed from the Symbolics Lisp Machine system, and is reminiscent of
non-Lisp debuggers. Commands are a little easier to type than Scheme
forms (no parentheses, so you don't have to shift), but more
importantly, making them distinct from Scheme forms ensures that
programs' namespaces aren't clutterred with inappropriate bindings.
Equivalently, the command set is available for use regardless of what
bindings happen to be visible in the current program. This is
especially important in conjunction with the module system, which puts
strict controls on visibility of bindings.
The \hack{} command processor supports the module system with a
variety of special commands. For commands that require structure
names, these names are resolved in a designated configuration package
that is distinct from the current package for evaluating Scheme forms
given to the command processor. The command processor interprets
Scheme forms in a particular current package, and there are commands
that move the command processor between different packages.
Commands are introduced by a comma ({\tt,}) and end at the end of
line. The command processor's prompt consists of the name of the
current package followed by a greater-than ({\tt>}).
\begin{list}{}{}{}
\item
\begin{code}
,config
\end{code}
The {\tt,config} command sets the command processor's current
package to be the current configuration package. Forms entered at
this point are interpreted as being configuration language forms,
not Scheme forms.
\item
\begin{code}
,config \var{command}
\end{code}
This form of the {\tt,config} command executes another command in
the current configuration package. For example,
\begin{code}
,config ,load foo.scm
\end{code}
interprets configuration language forms from the file {\tt
foo.scm} in the current configuration package.
\item
\begin{code}
,in \var{struct-name}
\end{code}
The {\tt ,in} command moves the command processor to a specified
structure's underlying package. For example:
\begin{code}
user> ,config
config> (define-structure foo (export a)
(open scheme))
config> ,in foo
foo> (define a 13)
foo> a
13
\end{code}
In this example the command processor starts in a package called
{\tt user}, but the {\tt ,config} command moves it into the
configuration package, which has the name {\tt config}. The {\tt
define-structure} form binds, in {\tt config}, the name {\tt foo} to
a structure that exports {\tt a}. Finally, the command {\tt ,in
foo} moves the command processor into structure {\tt foo}'s
underlying package.
A package's body isn't executed (evaluated) until the package is
{\em loaded}, which is accomplished by the {\tt ,load-package}
command.
\item
\begin{code}
,in \var{struct-name} \var{command}
\end{code}
This form of the {\tt,in} command executes a single command in the
specified package without moving the command processor into that
package. Example:
\begin{code}
,in mumble (cons 1 2)
,in mumble ,trace foo
\end{code}
\item
\begin{code}
,user $[$\var{command}$]$
\end{code}
This is similar to the {\tt ,config} and {\tt ,in} commands. It
moves to or executes a command in the user package (which is the
default package when the \hack{} command processor starts).
\item
\begin{code}
,for-syntax $[$\var{command}$]$
\end{code}
This is similar to the {\tt ,config} and {\tt ,in} commands. It
moves to or executes a command in the current package's ``package
for syntax,'' which is the package in which the forms $f$ in
{\tt (define-syntax \var{name} $f$)} are evaluated.
\item
\begin{code}
,load-package \var{struct-name}
\end{code}
The {\tt,load-package} command ensures that the specified structure's
underlying package's program has been loaded. This
consists of (1) recursively ensuring that the packages of any
opened or accessed structures are loaded, followed by (2)
executing the package's body as specified by its definition's {\tt
begin} and {\tt files} forms.
\item
\begin{code}
,reload-package \var{struct-name}
\end{code}
This command re-executes the structure's package's program. It
is most useful if the program comes from a file or files, when
it will update the package's bindings after mutations to its
source file.
\item
\begin{code}
,load \var{filespec} \etc
\end{code}
The {\tt,load} command executes forms from the specified file or
files in the current package. {\tt,load \var{filespec}} is similar
to {\tt(load "\var{filespec}")}
except that the name {\tt load} needn't be bound in the current
package to Scheme's {\tt load} procedure.
\item
\begin{code}
,structure \var{name} \var{interface}
\end{code}
The {\tt,structure} command defines \var{name} in the
configuration package to be a structure with interface
\var{interface} based on the current package.
\item
\begin{code}
,open \arbno{\var{struct-name}}
\end{code}
The {\tt,open} command opens a new structure in the current
package, as if the package's definition's {\tt open} clause
had listed \var{struct-name}.
\end{list}
\subsection*{Configuration packages}
It is possible to set up multiple configuration packages. The default
configuration package opens the following structures:
\begin{itemize}
\item {\tt module-system}, which exports {\tt define-structure} and the
other configuration language keywords, as well as standard types
and type constructors ({\tt :syntax}, {\tt :value}, {\tt proc}, etc.).
\item {\tt built-in-structures}, which exports structures that are
built into the initial \hack{} image; these include {\tt
scheme}, {\tt tables}, and {\tt records}.
\item {\tt more-structures}, which exports additional structures that
are available in the development environment; these include
{\tt sort}, {\tt random}, and {\tt threads}.
\end{itemize}
Note that it does not open {\tt scheme}.
You can define other configuration packages by simply making a package
that opens {\tt module-system} and, optionally, {\tt
built-in-\ok{}structures}, {\tt more-\ok{}structures}, or other structures that
export structures and interfaces.
For example:
\begin{code}
> ,config (define-structure foo (export )
(open module-system
built-in-structures
more-structures))
> ,in foo
foo> (define-structure x (export a b)
(open scheme)
(files x))
foo>
\end{code}
\begin{list}{}{}{}
\item
\begin{code}
,config-package-is \var{struct-name}
\end{code}
The {\tt,config-package-is} command designates a new configuration
package for use by the {\tt,config} command and resolution of
\var{struct-name}s for other commands such as {\tt,in} and
{\tt,open}.
\end{list}
\subsection*{Discussion}
This module system was not designed as the be-all and end-all of
Scheme module systems; it was only intended to help Richard Kelsey and
me to organize the \hack{} system. Not only does the module system
help avoid name clashes by keeping different subsystems in different
namespaces, it has also helped us to tighten up and generalize
\hack{}'s internal interfaces. \hack{} is unusual among Lisp
implementations in admitting many different possible modes of
operation. Examples of such multiple modes include the following:
\begin{itemize}
\item Linking can be either static or dynamic.
\item The development environment (compiler, debugger, and command
processor) can run either in the same address space as the program
being developed or in a different address space. The environment and
user program may even run on different processors under different
operating systems\cite{Rees-Donald:Program}.
\item The virtual machine can be supported by either
of two implementations of its implementation language, Prescheme.
\end{itemize}
The module system has been helpful in organizing these multiple modes.
By forcing us to write down interfaces and module dependencies, the
module system helps us to keep the system clean, or at least to keep
us honest about how clean or not it is.
The need to make structures and interfaces second-class instead of
first-class results from the requirements of static program analysis:
it must be possible for the compiler and linker to expand macros and
resolve variable bindings before the program is executed. Structures
could be made first-class (as in FX\cite{Sheldon-Gifford:Static}) if a
type system were added to Scheme and the definitions of exported
macros were defined in interfaces instead of in module bodies, but
even in that case types and interfaces would remain second-class.
The prohibition on assignment to imported bindings makes substitution
a valid optimization when a module is compiled as a block. The block
compiler first scans the entire module body, noting which variables
are assigned. Those that aren't assigned (only {\tt define}d) may be
assumed never assigned, even if they are exported. The optimizer can
then perform a very simple-minded analysis to determine automatically
that some procedures can and should have their calls compiled in line.
The programming style encouraged by the module system is consistent
with the unextended Scheme language. Because module system features
do not generally show up within module bodies, an individual module
may be understood by someone who is not familiar with the module
system. This is a great aid to code presentation and portability. If
a few simple conditions are met (no name conflicts between packages,
no use of {\tt structure-ref}, and use of {\tt files} in preference to
{\tt begin}), then a multi-module program can be loaded into a Scheme
implementation that does not support the module system. The \hack{}
static linker satisfies these conditions, and can therefore run in
other Scheme implementations. \hack{}'s bootstrap process, which is
based on the static linker, is therefore nonincestuous. This
contrasts with most other integrated programming environments, such as
Smalltalk-80, where the system can only be built using an existing
version of the system itself.
Like ML modules, but unlike Scheme Xerox modules, this module system
is compositional. That is, structures are constructed by single
syntactic units that compose existing structures with a body of code.
In Scheme Xerox, the set of modules that can contribute to an
interface is open-ended --- any module can contribute bindings to any
interface whose name is in scope. The module system implementation is
a cross-bar that channels definitions from modules to interfaces. The
module system described here has simpler semantics and makes
dependencies easier to trace. It also allows for higher-order
modules, which Scheme Xerox considers unimportant.
%[Discuss use of module system in the \hack{} implementation? Maybe
%give an extended excerpt from \hack{}'s configuration files?]
%
%[Discuss or flush OPTIMIZE clause.]
%
%[Future work: ideas for anonymous structures and more of a module
%calculus; dealing with name conflicts; interface subtraction.]
\begin{thebibliography}{10}
\bibitem{Clinger-Rees:Macros}
William Clinger and Jonathan~Rees.
\newblock Macros that work.
\newblock {\em Principles of Programming Languages}, January 1991.
\bibitem{Clinger-Rees:R4RS}
William Clinger and Jonathan~Rees (editors).
\newblock Revised${}^4$ report on the algorithmic language {S}cheme.
\newblock {\em LISP Pointers} IV(3):1--55, July-September 1991.
\bibitem{Curtis-Rauen:Modules}
Pavel Curtis and James Rauen.
\newblock A module system for Scheme.
\newblock {\em ACM Conference on Lisp and Functional Programming,}
pages 13--19, 1990.
\bibitem{MacQueen:Modules}
David MacQueen.
\newblock Modules for Standard ML.
\newblock {\em ACM Conference on Lisp and Functional Programming,}
1984.
\bibitem{Rees-Donald:Program}
Jonathan Rees and Bruce Donald.
\newblock Program mobile robots in Scheme.
\newblock {\em International Conference on Robotics and
Automation,} IEEE, 1992.
\bibitem{Sheldon-Gifford:Static}
Mark A.~Sheldon and David K.~Gifford.
\newblock Static dependent types for first-class modules.
\newblock {\em ACM Conference on Lisp and Functional Programming,}
pages 20--29, 1990.
\end{thebibliography}
\end{document}

97
doc/src/proto.tex Normal file
View File

@ -0,0 +1,97 @@
\newcommand{\xsubsection}[1]{%
\texonly{\subsection{#1}}%
\htmlonly{\strong{#1}\\}%
}
\newcommand{\evalsto}{%
\texonly{$\rightarrow$}%
\htmlonly{\code{->}}%
}
\newcommand{\cvar}[1]{%
\texonly{{\rm\em{#1}}}%
\htmlonly{\code{\var{#1}}}%
}
%%%%%%%%%%%%%%%% Latex prototypes
\texonly{
\newenvironment{protos}{\list{$\bullet$}
{\leftmargin1.2em\rightmargin0pt\itemsep0pt\parsep0pt\partopsep-2pt}}
{\endlist}
% The following is for prototypes that have return types.
% (foo int int) -> int
\newcommand{\proto}[3]{\item\noindent\unskip%
\cindex{\code{#1}}%
\hbox{\spaceskip=0.5em\code{({#1}{\it#2\/})} {$\rightarrow$} {\it#3}}}
\newcommand{\cproto}[1]{\item\noindent\unskip%
\hbox{\spaceskip=0.5em\code{{#1}}}}
\newcommand{\cgcproto}[1]{\item\noindent\unskip%
\hbox{\spaceskip=0.5em\code{{#1}}}\hfill\penalty 0%
\hbox{ }\nobreak\hfill\hbox{\rm (may GC)}}
\newcommand{\protonoresult}[2]{\item\noindent\unskip%
\hbox{\spaceskip=0.5em\code{(\hbox{#1}{\it#2\/})}}}
% Syntax prototypes
\newcommand{\syntaxprotonoresult}[2]{\item\noindent\unskip%
\hbox{\spaceskip=0.5em\code{(\hbox{#1}{#2})}}\hfill\penalty 0%
\hbox{ }\nobreak\hfill\hbox{\rm syntax}}
\newcommand{\syntaxproto}[3]{\syntaxprotonoresult{#1}{#2}%
\hspace*{24pt}{$\rightarrow$} {\it#3}}
% This can be reduced
\newcommand{\pconstproto}[2]{\item\noindent\unskip%
\hbox{\spaceskip=0.5em#1}\code\hfill\penalty 0%
\hbox{ }\nobreak\hfill\hbox{\rm #2}}
% Variable prototype
\newcommand{\constproto}[2]{\pconstproto{#1}{#2}}
}
%%%%%%%%%%%%%%%% end of Latex proto definitions
%%%%%%%%%%%%%%%% HTML prototypes
\htmlonly{
\newenvironment{protos}{\begin{itemize}}{\end{itemize}}
% The following is for prototypes that have return types.
% (foo int int) -> int
\newcommand{\proto}[3]{%
%\cindex{\code{#1}}%
\item\noindent\code{({#1}{\var{#2}\/})~-->~{\var{#3}}}}
\newcommand{\protonoresult}[2]{%
%\cindex{\code{#1}}%
\item\noindent\code{({#1}{\var{#2}\/})}}
\newcommand{\constproto}[2]{%
\item\noindent\prototagstart\code{{#1}}\prototag{{#2}}}
\newcommand{\cproto}[1]{%
\item\noindent\code{{#1}}}
\newcommand{\cgcproto}[1]{%
\item\noindent\prototagstart\code{{#1}}\prototag{(may GC)}}
\newcommand{\syntaxprotonoresult}[2]{%
\item\noindent\prototagstart\code{({#1}{#2})}\prototag{syntax}}
\newcommand{\prototagstart}{%
\begin{rawhtml}<table border=0 cellspacing=0 cellpadding=0 width=80%>
<tr> <td>\end{rawhtml}}
\newcommand{\prototag}[1]{%
\begin{rawhtml}</td> <td align=right>\end{rawhtml}%
{#1}%
\begin{rawhtml}</td></tr></table>\end{rawhtml}}
}
%%%%%%%%%%%%%%%% end of HTML proto definitions

83
doc/src/summary.tex Normal file
View File

@ -0,0 +1,83 @@
\documentstyle[11pt]{article}
\pagestyle{empty}
\setlength{\textheight}{9in}
\setlength{\footheight}{0.0in}
\setlength{\topmargin}{0in}
%Defaults from art10.sty:
%\textwidth 345pt \columnsep 10pt \columnseprule 0pt
%\oddsidemargin 63pt
\advance\textwidth by 0.5in
\advance\oddsidemargin by -0.25in
\begin{document}
\vspace*{-0.3in}
\begin{center}
{\large\bf Scheme 48} \\
\vspace{1ex}
Richard Kelsey ({\tt kelsey@corwin.ccs.northeastern.edu}) \\
Jonathan Rees ({\tt jar@cs.cornell.edu}) \\
June 1992
\end{center}
\vspace{1ex}
Scheme 48 is an implementation of the Scheme programming language based
on a virtual machine architecture. The following is an overview of
the project.
\paragraph{Goals}
\begin{itemize}
\setlength{\itemsep}{0pt}
\item Straightforward, minimal implementation.
\item Flexible experimental apparatus for research in programming
language design and implementation.
\item Easy to make changes to internal data representations, memory
management, and compilation strategy.
\item High reliability.
\item Fast and complete enough to be a good
development environment for Scheme programs.
\end{itemize}
\paragraph{Virtual machine}
The virtual machine executes a simple byte-code instruction set
similar to the target of the Scheme 311 compiler [Clinger, LFP 1984].
The interpreter for the virtual instruction set is itself written in
PreScheme, a systems programming dialect of Scheme. A PreScheme
compiler applies intensive source-to-source rewrites to the
interpreter source code and emits low-level C code. When the output
is then compiled by an optimizing C compiler such as gcc, the result
is a very efficient and portable emulator.
\paragraph{Run-time system}
The virtual machine is initialized from a specified memory image
containing byte-compiled Scheme code and data. Images (including
small stand-alone applications) are built either by a linker or by
writing out the state of an executing program. A standard memory
image contains a Scheme run-time library ({\tt append}, {\tt read},
{\tt write}, etc.), a compiler from Scheme to the virtual instruction
set, and a command processor and debugger. In this way Scheme 48 can
be configured to look like a conventional Lisp interpreter.
In addition to the Scheme run-time library and development
environment, library software includes support for multitasking,
modules (packages), hygienic macros (as described in the Revised$^4$
Scheme report), records, and exception handling.
\paragraph{Applications}
The Scheme 48 system is being used at several sites for research in
memory management, embedded systems, multiprocessing, and computer
system verification. Scheme 48 was chosen as the platform for these
projects because of its internal tractability and flexibility.
\end{document}

383
doc/src/utilities.tex Normal file
View File

@ -0,0 +1,383 @@
\documentclass{article}
\usepackage{hyperlatex}
\include{proto}
% Make a few big HTML files, and not a lot of small ones.
\setcounter{htmldepth}{1}
\makeindex
\title{Scheme 48 User's Guide}
\author{Richard A. Kelsey}
%\date{}
\begin{document}
\maketitle
\section{ASCII character encoding}
These are in the structure \code{ascii}.
\begin{protos}
\proto{char->ascii}{ char}{integer}
\proto{ascii->char}{ integer}{char}
\end{protos}
\noindent
These are identical to \code{char->integer} and \code{integer->char} except that
they use the ASCII encoding.
\begin{protos}
\constproto{ascii-limit}{integer}
\constproto{ascii-whitespaces}{list of integers}
\end{protos}
\code{Ascii-limit} is one more than the largest value that \code{char->ascii}
may return.
\code{Ascii-whitespaces} is a list of the ASCII values of whitespace characters
(space, tab, line feed, form feed, and carriage return).
\section{Bitwise integer operations}
These functions use the two's-complement representation for integers.
There is no limit to the number of bits in an integer.
They are in the structures \code{bitwise} and \code{big-scheme}.
\begin{protos}
\proto{bitwise-and}{ integer integer}{integer}
\proto{bitwise-ior}{ integer integer}{integer}
\proto{bitwise-xor}{ integer integer}{integer}
\proto{bitwise-not}{ integer} {integer}
\end{protos}
\noindent
These perform various logical operations on integers on a bit-by-bit
basis. `\code{ior}' is inclusive OR and `\code{xor}' is exclusive OR.
\begin{protos}
\proto{arithmetic-shift}{ integer bit-count}{integer}
\end{protos}
\noindent Shifts the integer by the given bit count, which must be an integer,
shifting left for positive counts and right for negative ones.
Shifting preserves the integer's sign.
\section{Arrays}
These are N-dimensional, zero-based arrays and
are in the structure \code{arrays}.
The array interface is derived from one written by Alan Bawden.
\begin{protos}
\proto{make-array}{ value dimension$_0$ \ldots}{array}
\proto{array}{ dimensions element$_0$ \ldots}{array}
\proto{copy-array}{ array}{array}
\end{protos}
\noindent
\code{Make-array} makes a new array with the given dimensions, each of which
must be a non-negative integer.
Every element is initially set to \cvar{value}.
\code{Array} Returns a new array with the given dimensions and elements.
\cvar{Dimensions} must be a list of non-negative integers,
The number of elements should be the equal to the product of the
dimensions.
The elements are stored in row-major order.
\begin{example}
(make-array 'a 2 3) \evalsto \{Array 2 3\}
(array '(2 3) 'a 'b 'c 'd 'e 'f)
\evalsto \{Array 2 3\}
\end{example}
\code{Copy-array} returns a copy of \cvar{array}.
The copy is identical to the \cvar{array} but does not share storage with it.
\begin{protos}
\proto{array?}{ value}{boolean}
\end{protos}
\noindent
Returns \code{\#t} if \cvar{value} is an array.
\begin{protos}
\proto{array-ref}{ array index$_0$ \ldots}{value}
\protonoresult{array-set!}{ array value index$_0$ \ldots}
\proto{array->vector}{ array}{vector}
\proto{array-dimensions}{ array}{list}
\end{protos}
\noindent
\code{Array-ref} returns the specified array element and \code{array-set!}
replaces the element with \cvar{value}.
\begin{example}
(let ((a (array '(2 3) 'a 'b 'c 'd 'e 'f)))
(let ((x (array-ref a 0 1)))
(array-set! a 'g 0 1)
(list x (array-ref a 0 1))))
\evalsto '(b g)
\end{example}
\code{Array->vector} returns a vector containing the elements of \cvar{array}
in row-major order.
\code{Array-dimensions} returns the dimensions of
the array as a list.
\begin{protos}
\proto{make-shared-array}{ array linear-map dimension$_0$ \ldots}{array}
\end{protos}
\noindent
\code{Make-shared-array} makes a new array that shares storage with \cvar{array}
and uses \cvar{linear-map} to map indicies to elements.
\cvar{Linear-map} must accept as many arguments as the number of
\cvar{dimension}s given and must return a list of non-negative integers
that are valid indicies into \cvar{array}.
\begin{example}
(array-ref (make-shared-array a f i0 i1 ...)
j0 j1 ...)
\end{example}
is equivalent to
\begin{example}
(apply array-ref a (f j0 j1 ...))
\end{example}
As an example, the following function makes the transpose of a two-dimensional
array:
\begin{example}
(define (transpose array)
(let ((dimensions (array-dimensions array)))
(make-shared-array array
(lambda (x y)
(list y x))
(cadr dimensions)
(car dimensions))))
(array->vector
(transpose
(array '(2 3) 'a 'b 'c 'd 'e 'f)))
\evalsto '(a d b e c f)
\end{example}
\section{Records}
New types can be constructed using the \code{define-record-type} macro
from the \code{define-record-types} structure
The general syntax is:
\begin{example}
(define-record-type \cvar{tag} \cvar{type-name}
(\cvar{constructor-name} \cvar{field-tag} \ldots)
\cvar{predicate-name}
(\cvar{field-tag} \cvar{accessor-name} [\cvar{modifier-name}])
\ldots)
\end{example}
This makes the following definitions:
\begin{protos}
\constproto{\cvar{type-name}}{type}
\proto{\cvar{constructor-name}}{ field-init \ldots}{type-name}
\proto{\cvar{predicate-name}}{ value}{boolean}
\proto{\cvar{accessor-name}}{ type-name}{value}
\protonoresult{\cvar{modifier-name}}{ type-name value}
\end{protos}
\noindent
\cvar{Type-name} is the record type itself, and can be used to
specify a print method (see below).
\cvar{Constructor-name} is a constructor that accepts values
for the fields whose tags are specified.
\cvar{Predicate-name} to a predicate that can returns \code{\#t} for
elements of the type and \code{\#f} for everything else.
The \cvar{accessor-name}s retrieve the values of fields,
and the \cvar{modifier-name}'s update them.
The \cvar{tag} is used in printing instances of the record type and
the field tags are used in the inspector and to match
constructor arguments with fields.
\begin{protos}
\protonoresult{define-record-discloser}{ type discloser}
\end{protos}
\noindent
\code{Define-record-discloser} determines how
records of type \cvar{type} are printed.
\cvar{Discloser} should be procedure which takes a single
record of type \cvar{type} and returns a list whose car is
a symbol.
The record will be printed as the value returned by \cvar{discloser}
with curly braces used instead of the usual parenthesis.
For example
\begin{example}
(define-record-type pare :pare
(kons x y)
pare?
(x kar set-kar!)
(y kdr))
\end{example}
defines \code{kons} to be a constructor, \code{kar} and \code{kdr} to be
accessors, \code{set-kar!} to be a modifier, and \code{pare?} to be a predicate
for a new type of object.
The type itself is named \code{:pare}.
\code{Pare} is a tag used in printing the new objects.
By default, the new objects print as \code{\#{Pare}}.
The print method can be modified using DEFINE-RECORD-DISCLOSER:
\begin{example}
(define-record-discloser :pare
(lambda (p) `(pare ,(kar p) ,(kdr p))))
\end{example}
will cause the result of \code{(kons 1 2)} to print as
\code{\#\{pare 1 2\}}.
\section{Finite record types}
The structure \code{finite-types} has
two macros for defining `finite' record types.
These are record types for which there are a fixed number of instances,
which are created when the record type is defined.
The syntax for the defining a finite type is:
\begin{example}
(define-finite-type \cvar{tag} \cvar{type-name}
(\cvar{field-tag} \ldots)
\cvar{predicate-name}
\cvar{vector-of-elements-name}
\cvar{name-accessor}
\cvar{index-accessor}
(\cvar{field-tag} \cvar{accessor-name} [\cvar{modifier-name}])
\ldots
((\cvar{element-name} \cvar{field-value} \ldots)
\ldots))
\end{example}
This differs from \code{define-record-type} in the following ways:
\begin{itemize}
\item No name is specified for the constructor, but the field arguments
to the constructor are listed.
\item The \cvar{vector-of-elements-name} is added; it will be bound
to a vector containing all of the elements of the type.
These are constructed by applying the (unnamed) constructor to the
initial field values at the end of the form.
\item There are names for accessors for two required fields, name
and index.
These fields are not settable, and are not to be included
in the argument list for the constructor.
\item The form ends with the names and the initial field values for
the elements of the type.
The name must be first.
The remaining values must match the \cvar{field-tag}s in the constructor's
argument list.
\item \cvar{Tag} is bound to a macro that maps \cvar{element-name}s to the
the corresponding element of the vector.
The name lookup is done at macro-expansion time.
\end{itemize}
\begin{example}
(define-finite-type color :color
(red green blue)
color?
colors
color-name
color-index
(red color-red)
(green color-green)
(blue color-blue)
((white 255 255 255)
(black 0 0 0)
(yellow 255 255 0)
(maroon 176 48 96)))
(color-name (vector-ref colors 0)) \evalsto white
(color-name (color black)) \evalsto black
(color-index (color yellow)) \evalsto 2
(color-red (color maroon)) \evalsto 176
\end{example}
Enumerated types are finite types whose only fields are the name
and the index.
The syntax for defining an enumerated type is:
\begin{example}
(define-enumerated-type \cvar{tag} \cvar{type-name}
\cvar{predicate-name}
\cvar{vector-of-elements-name}
\cvar{name-accessor}
\cvar{index-accessor}
(\cvar{element-name} \ldots))
\end{example}
In the absence of any additional fields, both the constructor argument
list and the initial field values are not required.
The above example of a finite type can be pared down to the following
enumerated type:
\begin{example}
(define-enumerated-type color :color
color?
colors
color-name
color-index
(white black yellow maroon))
(color-name (vector-ref colors 0)) \evalsto white
(color-name (color black)) \evalsto black
(color-index (color yellow)) \evalsto 2
\end{example}
\section{Hash tables}
These are generic hash tables, and are in the structure \code{tables}.
Strictly speaking they are more maps than tables, as every table has a
value for every possible key (for that type of table).
All but a finite number of those values are \code{\#f}.
\begin{protos}
\proto{make-table}{}{table}
\proto{make-symbol-table}{}{symbol-table}
\proto{make-string-table}{}{string-table}
\proto{make-integer-table}{}{integer-table}
\proto{make-table-maker}{ compare-proc hash-proc}{procedure}
\protonoresult{make-table-immutable!}{ table}
\end{protos}
\noindent
The first four functions listed make various kinds of tables.
\code{Make-table} returns a table whose keys may be symbols, integer,
characters, booleans, or the empty list (these are also the values
that may be used in \code{case} expressions).
As with \code{case}, comparison is done using \code{eqv?}.
The comparison procedures used in symbol, string, and integer tables are
\code{eq?}, \code{string=?}, and \code{=}.
\code{Make-table-maker} takes two procedures as arguments and returns
a nullary table-making procedure.
\cvar{Compare-proc} should be a two-argument equality predicate.
\cvar{Hash-proc} should be a one argument procedure that takes a key
and returns a non-negative integer hash value.
If \code{(\cvar{compare-proc} \cvar{x} \cvar{y})} returns true,
then \code{(= (\cvar{hash-proc} \cvar{x}) (\cvar{hash-proc} \cvar{y}))}
must also return true.
For example, \code{make-integer-table} could be defined
as \code{(make-table-maker = abs)}.
\code{Make-table-immutable!} prohibits future modification to its argument.
\begin{protos}
\proto{table?}{ value}{boolean}
\proto{table-ref}{ table key}{value or \code{\#f}}
\protonoresult{table-set!}{ table key value}
\protonoresult{table-walk}{ procedure table}
\end{protos}
\noindent
\code{Table?} is the predicate for tables.
\code{Table-ref} and \code{table-set!} access and modify the value of \cvar{key}
in \cvar{table}.
\code{Table-walk} applies \cvar{procedure}, which must accept two arguments,
to every associated key and non-\code{\#f} value in \code{table}.
\begin{protos}
\proto{default-hash-function}{ value}{integer}
\proto{string-hash}{ string}{integer}
\end{protos}
\noindent
\code{default-hash-function} is the hash function used in the tables
returned by \code{make-table}, and \code{string-hash} it the one used
by \code{make-string-table}.
%\W \chapter*{Index}
%\W \htmlprintindex
%\T \input{doc.ind}
\end{document}

87
doc/threads.txt Normal file
View File

@ -0,0 +1,87 @@
Threads
The following are exported by the THREADS structure.
(SPAWN thunk)
(SPAWN thunk name)
Create and schedule a new thread that will execute <thunk>. The optional
name is used when printing the thread.
(RELINQUISH-TIMESLICE)
Let other threads run for a while.
(SLEEP time)
Sleep for <time> milliseconds.
(TERMINATE-CURRENT-THREAD)
Kill the current thread.
(THREAD? thing)
#T if thing is a thread, #F otherwise.
(THREAD-NAME thread)
(THREAD-UID thread)
For printing debugging information.
-----
The following are exported by the LOCKS structure.
(MAKE-LOCK) => lock
(OBTAIN-LOCK lock)
(RELEASE-LOCK lock)
Locks are semaphores.
-----
The following are exported by the PLACEHOLDERS structure.
(MAKE-PLACEHOLDER) => placeholder
(PLACEHOLDER-VALUE placeholder) => value of placeholder
(PLACEHOLDER-SET! placeholder value)
(PLACEHOLDER? thing) => #t or #f
Attempts to reference a placeholder before it has been set cause the
referencing thread to block. Setting a placeholder to two different
values is an error. (Previous versions of Scheme 48 called these
`condition variables', which turn out to be somewhat different.)
-----
Threads and the command interpreter.
Each level of the command interpreter has its own set of active
threads. Moving to a new level, for example when an error occurs,
halts all threads belonging to the previous level. Resuming the
a level causes its associated threads to continue running.
The ,threads command inspects the threads running in the stopped
command level.
> ,open threads
> (define (foo) (sleep 1000) (display "Hi") (newline) (foo))
> (spawn foo 'my-thread)
> Hi
(begin (sleep 10000) (display "Done") (newline))
Hi
Interrupt: keyboard
1> (sleep 5000)
; note that the Hi thread doesn't run in this command level
1> ,proceed 0
Hi
; but it resumes when we resume this level
Hi
Done
> Hi
Hi
Hi
Interrupt: keyboard
1> ,threads
'(#{Thread 28 my-thread} #{Thread 27 command-loop})
[0] '#{Thread 28 my-thread}
[1] '#{Thread 27 command-loop}
inspect:

243
doc/todo.txt Normal file
View File

@ -0,0 +1,243 @@
--*- Mode: Indented-text; -*-
Scheme 48: list of bugs and things to do.
Last update by RAK on 28 April 1998.
Run-time system bugs:
Shadowing can fail sometimes for macro-referenced variables. E.g.
the following sequence will lose if entered interactively as
three separate forms:
(define (foo x) `(a ,x))
(define cons list)
(foo 1) => (a (1 ()))
Programming environment:
Fuller on-line documentation.
Error recovery. Can do better than ,proceed. LOAD should set up
restart continuations.
Types in scheme-interface (and elsewhere) aren't as tight as they
could be.
LET continuation "pessimization" to retain the environment longer.
Have the disassembler display local variable names.
This ought to be recoverable, but isn't always:
> (let loop ((x '())) (loop (cons 3 x)))
not enough room in heap for stack
The get-cont-from-heap instruction should have an exception
discloser that indicates the actual error (returning a
non-fixnum from application top level).
Separate compilation (compile a module, writing object code to a
file). (Rudiments in misc/separate.scm)
Semicolon comments don't quite work after commands (extra newline
required).
Command (and procedure) to change current directory.
Some procedure in EXEC to take the place of ## in moving values from
one package to another: (transport <from-package> <exp> <to-package>
[<id>]), and/or have eval etc. commands return the value
Batch mode should write error messages to (error-output).
Performance:
Generational GC.
More compact representation for debugging data?
Leaf procedure compilation (RK's rts/no-leaf-env.scm): if no
continuations or lambdas, skip the make-env and access locals
using stack-ref. Expected to gain about 6% in speed.
Optimize loops somehow (maybe using call-template opcode and/or
opportunistic compilation).
The CAML light implementation has good documentation and patches
for optimizing the interpreter's switch (*pc++); perhaps we
could lift some of it. (Range check isn't necessary.)
Floating point support in VM.
Bignum support in VM: use MIT Scheme bignums or GNU Multiple
Precision Arithmetic Library (Torbjorn Granlund <tege@sics.se>).
Faster bignum printer (e.g. the one Richard wrote - but it would be
nice if it were an option tied to bignums, not built in to the
initial image).
Ratnum multiplication and division might be made more efficient by
taking cross-GCD's.
Native code compiler...
Big Scheme bugs / features:
It would be nice to be able to simulate control-C interrupts on
a port other than the initial input port - e.g., on a socket.
This would require creating a new thread to act as a front end.
The new thread would read characters eagerly, buffering
everything except control-C's for the thread that is doing the
real work, and converting control-C's into interrupts.
How about deleting entries from tables?
RPC.
Add call/gcc (invokes the Gnu C compiler).
Module system bugs:
,untrace should undefine as well if the variable wasn't bound
before.
Compound signatures don't get updated when a component signature
changes. They contain a list of signatures with no reinitialization
thunk a la structures and packages.
Module system features:
Check for name conflicts between opened structures.
Implement interface subtraction as a way of dealing with such
conflicts: (WITHOUT (<name> ...) <interface>)
Check for cycles in structure inheritance.
An ,access command, similar to ,open.
Deal with package system state better (for linker). Maybe each
package should point to a data structure containing
*location-uid*, location-name-table, *package-uid*,
package-name-table, and perhaps the compiler-state as well (see
segment.scm).
VM:
Heaps that can grow larger.
Add a test to configure.in that can determine whether ld -A works.
If both it and dlopen() work, then both kinds of dynamic loading
should be made available.
Merge in Olin's changes and extensions (command line processing,
the #! syntax for scripts, external function call, etc.).
Interrupt while writing out image causes an exit. [Fixed?]
A jump-back instruction? Might be easier to use than call-template.
Scrutinize all VM fatal errors to see if any can be recovered
from. E.g. "out of ports" shouldn't cause a VM halt, it should
just cause open-port to return #f or an error code. [Fixed?]
Get VM interp.scm-without-gc.scm working again.
Documentation:
Describe (optimize auto-integrate).
How to use the static linker.
How initial.image and scheme48.image get built, really.
Techniques for debugging the runtime system (debug/for-debugging.scm).
Cleanup:
VM:
Rename "unassigned" to "uninitialized"? Or phase it out entirely.
In unix.c, use getrusage(), when available, to get run time.
Run-time / features / development environment:
A DIVIDE procedure (maybe an instruction as well) that returns two
values.
Figure out how to merge the two type systems (META-METHODS and
META-TYPES). The generic function system could make use of the
SUBTYPE? and INTERSECT? predicates.
Correct floating point, esp. reading and printing. And
(= 1/3 (/ 1. 3.)) returns #t, but ought to return #f.
Parameterize over file name syntax somehow. Currently
big/filename.scm assumes Unix (cf. DIRECTORY-COMPONENT-SEPARATOR,
FILE-NAME-PREFERRED-CASE). Perhaps there should be VM support for
this.
Make sure that the disassembler and assembler are inverses of one
another.
Disassembler should generate S-expression first, and then print
it independently.
Combine conditions, signals, and handle into a single structure?
Figure out a better way to implement ##.
Be consistent about "filename" versus "file-name".
Compiler / linker / module system:
The "reflective tower" isn't really a reflective tower, it's a
syntactic tower. Rename it.
The scanner (file loader) should operate on streams, not lists.
This would result in more uniform and flexible internal
protocols for reading files, scanning for DEFINEs, compiling,
and running - passes could be interleaved or separated easily.
Flush link/data.scm. Linker should instead open the VM module
that includes vm/data.scm.
Flush (optimize ...) clause in DEFINE-STRUCTURE in favor of
optimizer argument to SCAN-STRUCTURES.
Vector patterns and templates ought to be supported in
SYNTAX-RULES.
The DEFINE-INTERFACE forms should contain types for every exported
variable; the code in cprim.scm (and recon.scm?) shouldn't have
to worry about setting up types.
Add ENVIRONMENT-DEFINED? ?
Make USUAL-TRANSFORM return a transform?
Add enough to the node signature to make it usable on its own?
make-c-header-file should put definitions for the interrupt
enumeration into scheme48.h, and unix.c et al should use them.
Flatloading and loading are very different operations, so FLATLOAD
shouldn't do SET-PACKAGE-LOADED?!; instead it should maintain its
own list of flatloaded packages (in a global variable, say).
Etc:
Start using a source control system (like rcs).
There ought to be a sanity check to ensure that the size of the
area as computed by static.scm agrees with the size as computed
by C's sizeof() operator.
What should (syntax-rules (x) ((foo ?body) (let ((x 1)) ?body))) do?
To: jar@cs.cornell.edu
Subject: Not a bug this time. :-)
Date: Tue, 22 Feb 94 19:13:37 -0500
From: Paul Stodghill <stodghil@cs.cornell.edu>
The result of ,expand can be confusing. In particular, it doesn't
distinguish between different identifiers that have the same name.
For instance, in the example below, it would be more useful if the result
of the ,expand was something like,
'((lambda (.x.1) (set! x (- .x.1))) x)
Welcome to Scheme 48 0.31 (made by jar on Sun Feb 13 18:33:57 EST 1994).
Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees.
Please report bugs to scheme-48-bugs@altdorf.ai.mit.edu.
Type ,? (comma question-mark) for help.
> (define-syntax foo
(syntax-rules ()
((foo var) ((lambda (x) (set! var (- x))) var))))
> (define x 1)
> ,expand (foo x)
'((lambda (x) (set! x (- x))) x)
>
Date: Mon, 14 Jun 93 18:33:30 HKT
From: shivers@csd.hku.hk
To: kelsey@flora.ccs.neu.edu
Cc: jar@cs.cornell.edu
Subject: Scheme 48
...
All true. My major motivation was portability. I also found the module system
to be a big win. Other things that influenced me were (1) elegance and
modularity -- I felt I could comprehend and mung the system as needed (2)
reasonable efficiency and small size and (3) real, full R4RS+ support (most
small systems do it partly).
Actually, I wouldn't say the programming environment is particularly
exceptional, unless you count the module system.
A small thing lacking in other Schemes that really reduced my debug times: the
loader would complain about undefined free var refs in my code. This
frequently picked out variable spelling errors, inconsistent name linkages,
and forgotten procedure defs. Not a big thing, but really effective.
Another win was simply having the implementors around for detailed
explanations and support.
Problems I had with S48:
- Inability to mess with the VM, as it is written in a language that can
be compiled by only 1 person in the world.
- The foreign-function support was quite limited, and the foreign-data support
was basically non-existent. Exporting gc'd data to C, gc'ing data allocated
in C, hooks into the GC, importing C data into Scheme -- no support. Elk
handles this better, as that is critical to the type of applications at
which elk is targeted.
I fixed some of this myself -- helped by your general, portable low-level ff
interface, which was well-designed in terms of those goals -- but I couldn't
do much about foreign-data support.
- No support currently for linking static heap data into a text-pages
area to reduce gc copying and shrink the dynamic heap.
- The module system was frequently frustrating. The non-uniform , command
language, bugs, the restrictions of living with a module system,
being blocked from accessing primitives whose bindings had been
gc'd away at link time, and awkwardnesses in the user interface really
slowed me down.
The module system was also a great help; these are simply the problems
of life with an experimental system, as opposed to a polished final
product.
[But] all in all, S48 was the best choice I could have made.

240
doc/type.txt Normal file
View File

@ -0,0 +1,240 @@
The Type System
Scheme 48 has a rudimentary type system. Its main purpose is to
generate helpful compile-time diagnostics.
Currently you don't get much checking beyond wrong number of arguments
warnings unless you're compiling a package that has an (OPTIMIZE ...)
clause in its definition (e.g. (OPTIMIZE EXPAND) or (OPTIMIZE
AUTO-INTEGRATE)). The reason that type checking is disabled most of
the time is that it increases compilation time by about 33%.
A design goal is to assign types to all valid Scheme programs. That
is, type warnings should not be generated for programs that could work
according to Scheme's dynamic semantics. For example, no warning
should be produced for
(define (foo x y) (if x (+ y 1) (car y)))
Warnings could in principle be produced for particular calls to FOO
that would definitely go wrong, such as (foo #t 'a).
The type system assumes that all code is potentially reachable. This
means that there will be some warnings for programs that cannot go
wrong, e.g. (if #t 3 (car 7)).
Additionally, it's assumed that in a (BEGIN ...) or combination, every
argument or command will always be executed. This won't be the case
if there can be a throw out of the middle. For example, in
(call-with-current-continuation
(lambda (k)
(if (not (number? x))
(k #f))
(+ x 1)))
the type system might deduce that X must be a number (which is false).
The type reconstruction algorithm (such as it is) is in
bcomp/recon.scm. The implementation finds some specific procedure
types for LAMBDA expressions, but generally gives up pretty quickly.
Notation
--------
F : T means that form F has static type T. T1 <= T2, or T1 is under
T2, means that T1 is a subtype of T2; that is, if a form of type T2 is
acceptable in some context, then so is a form of type T1.
Non-expressions
---------------
Not every valid Scheme form is an expression. Forms that are not
expressions are syntactic keywords, definitions, types, and structure
names.
If a name is bound to a macro or special operator, then an occurrence
of that name has type :SYNTAX. E.g.
cond : :syntax
Definitions have type :DEFINITION. E.g.
(begin (define x 1) (define y 2)) : :definition
Thus type checking subsumes syntax checking.
Types (other than :TYPE itself?) have type :TYPE.
The type of a structure is its interface. E.g.
(define-structure foo (export a b) ...)
foo : (export a b)
Values
------
All expressions have type :VALUES. They may have more specific
types as well.
If E1 ... En have types T1 ... Tn with Ti <= :VALUE, then
the expression (VALUES E1 ... En) has type (SOME-VALUES T1 ... Tn).
If T <= :VALUE then (SOME-VALUES T) is equivalent to T.
Procedure types
---------------
Procedure types have the form (PROCEDURE T1 T2), where T1 and T2 are
under :VALUES. Examples:
(lambda (x) (values x 1)) :
(procedure (some-values :value) (some-values :value :number))
cons : (procedure (some-values :value :value) :pair)
Fixed-arity procedure types (PROCEDURE (SOME-VALUES T1 ... TN) T) are
so common that the abbreviated syntax (PROC (T1 ... Tn) T) is
defined to mean the same thing. E.g.
cons : (proc (:value :value) :pair)
E : (PROCEDURE T1 T2) means that in a call to a value of E, if the
argument sequence has any type other than T1, then the call can be
expected to "go wrong" (provoke a type error) at run time. This is
not to say it will definitely go wrong, but that it is just a matter
of luck if it doesn't. If the argument sequence does have type T1,
then the call might or might not go wrong, and any return value(s)
will have type T2.
For example,
(lambda (x) (+ (begin (set! x '(3)) 5) (car x))) :
(proc (:pair) :value),
because if the arguments to + are evaluated from right to left, and X
is not a pair, then there will be a run time type error.
Some primitive procedures have their own special typing rules.
Examples include VALUES, CALL-WITH-VALUES, and PRIMITIVE-CATCH.
Variable types
--------------
Assignable variables have type (VARIABLE T), where T for now will
always be :VALUE. In (SET! V E), V must have type (VARIABLE T) for
some T.
Loopholes
---------
The construct (loophole T E) is considered to have type T no matter
what type E has. Among other things, this allows a rudimentary static
abstract data type facility. For example, record types defined using
DEFINE-RECORD-TYPE (rts/bummed-jar-defrecord.scm) are established as
new base types.
Type lattice
------------
The subtype relation is implemented by the procedure COMPATIBLE-TYPES?
(in bcomp/mtypes.scm). If (COMPATIBLE-TYPES? T1 T2) is 'definitely,
then T1 <= T2. If it's #T, then T1 and T2 intersect.
The type lattice has no bottom or top elements.
The types :SYNTAX, :VALUES, :DEFINITION, :STRUCTURE, and :TYPE are
incomparable and maximal.
The following are a comprehensive set of subtyping rules for the type
system as it stands. Additional rules may be added in the future.
- (SOME-VALUES T1 ... Tn) <= :VALUES.
- If T1 <= T1', ..., Tn <= Tn' then (SOME-VALUES T1 ... Tn) <=
(SOME-VALUES T1' ... Tn').
- T <= (SOME-VALUES T).
- Basic value types, which include :NUMBER, :CHAR, :BOOLEAN, :PAIR,
:STRING, and :UNSPECIFIC, are all under :VALUE.
- If T1' <= T1 and T2 <= T2', then (PROCEDURE T1 T2) <= (PROCEDURE
T1' T2').
- (VARIABLE T) <= T.
- :ZERO, the result type of infinite loops and calls to
continuations, is under :VALUE, but perhaps shouldn't be. (E.g.
maybe it should be just under :VALUES instead.)
- (EXPORT (<name> T) ...) is under :STRUCTURE.
[Not yet implemented.]
Type well-formedness
--------------------
In (SOME-VALUES T1 ... Tn), T1 ... Tn must be under :VALUE.
In (PROCEDURE T1 T2), T1 and T2 must be under :VALUES.
In (VARIABLE T), T must be under :VALUE.
Module system
-------------
The rules for interfaces and structures are not yet very well worked
out.
Interfaces are types. The type of a structure is its interface.
(Compare with Pebble's "bindings" and "declarations".)
An interface has the basic form (EXPORT (<name> <type>) ...).
There are two kinds of abbreviations:
- (EXPORT ... <name> ...) means the same as
(EXPORT ... (<name> :VALUE) ...)
- (EXPORT ... ((<name1> <name2> ...) <type>) ...) means the same as
(EXPORT ... (<name1> <type>) (<name2> <type>) etc. ...)
Distinct interfaces are not comparable.
If a form S has type (EXPORT ... (name T) ...), then the form
(STRUCTURE-REF S name) has type T. Note that T needn't be a :VALUE
type; e.g.
(structure-ref scheme cond) : :syntax
When a package is loaded or otherwise compiled, the type that is
reconstructed or inherited for each exported name is checked against
the type specified in the signature. (Cf. procedure SCAN-STRUCTURES
in bcomp/scan.scm.)
<explain the role of the expander in type checking... compile-call
doesn't do much checking if the arguments aren't expanded...>
Future work
-----------
There probably ought to be dependent sums and products and/or
universal and existential types. In particular, it would be nice to
be able to get static checking for abstract types, even if they're not
implemented using records.
Type constructors (like STREAM-OF or COMPUTATION-OF) would be nice.
There are many loose ends in the implementation. For example, type
and type constructor names aren't always lexically scoped; sometimes
their scope is global. Packages that open the LOOPHOLES structure
(which exports LOOPHOLE) don't always open TYPES (which would be a bad
idea given the way TYPES is currently defined); LOOPHOLE works in
spite of that.
Figure out whether :TYPE : :TYPE.
-----
Original by JAR, 20 July 93.
Updated by JAR, 5 December 93.

709
doc/user-guide.txt Normal file
View File

@ -0,0 +1,709 @@
A User's Guide to Scheme 48
A line may take us hours, yet if it does not seem a moment's thought
All our stitching and unstitching has been as nought.
Yeats
Adam's Curse
Introduction
Scheme 48 is an implementation of the Scheme programming language as
described in the Revised^4 Report on the Algorithmic Language Scheme.
It is based on a compiler and interpreter for a virtual Scheme
machine. The name derives from our desire to have an implementation
that is simple and lucid enough that it looks as if it were written in
just 48 hours. We don't claim to have reached that stage yet; much
more simplification is necessary.
Scheme 48 tries to be faithful to the upcoming Revised^5 Scheme
Report, providing neither more nor less in the initial user
environment. (This is not to say that more isn't available in other
environments; see below.) Support for numbers is weak: bignums are
slow and floating point is almost nonexistent (see description of
floatnums, below). DEFINE-SYNTAX, LET-SYNTAX, LETREC-SYNTAX, and
SYNTAX-RULES are supported, but not the rest of the Revised^4 Scheme
macro proposal.
The Revised^5 Report hasn't been published yet, but it will be very
similar to the Revised^4 Report. For a list of differences, see
doc/meeting.tex.
This is what might be called an alpha release. Please report bugs,
especially in the VM, especially core dumps, to
scheme-48-bugs@altdorf.ai.mit.edu. Include the version number x.yy
from the "Welcome to Scheme 48 x.yy" greeting message in your bug
report. It is a goal of this project to produce a bullet-proof
system; we want no bugs and, especially, no crashes. (There are a few
known bugs, listed in the TODO file that comes with the distribution.)
Send mail to scheme-48-request@altdorf.ai.mit.edu to be put on a
mailing list for announcements, discussion, bug reports, and bug
fixes.
-----
Command line arguments
A few command line arguments are processed by the virtual machine as
it starts up.
scheme48 [-i image] [-h heapsize] [-o filename] [-s stacksize]
[-a argument ...]
-i image
specifies a heap image file to resume. This defaults to a heap
image that runs a Scheme command processor. Heap images are
created by the ,dump and ,build commands, for which see below.
-h heapsize
specifies how much space should be reserved for allocation.
Heapsize is in words (where one word = 4 bytes), and covers both
semispaces, only one of which is in use at any given time (except
during garbage collection). Cons cells are currently 3 words, so
if you want to make sure you can allocate a million cons cells,
you should specify -h 6000000 (actually somewhat more than this,
to account for the initial heap image and breathing room).
-s stacksize
specifies how much space should be reserved for the continuation
and environment stack. If this space is exhausted, continuations
and environments are copied to the heap. stacksize is in words
and defaults to 2500.
-o filename
This specifies an executable file in which foreign identifiers can be
looked up for the foreign function interface. Filename should be the
file that contains the scheme48vm executable image. See
doc/external.txt.
-a argument ...
is only useful with images built using ,build. The arguments are
passed as a list to the procedure specified in the ,build command.
E.g.
> ,build (lambda (a) (for-each display a) (newline) 0) foo.image
> ,exit
% scheme48vm -i foo.image -a mumble "foo x"
mumblefoo x
%
The usual definition of the "s48" or "scheme48" command is actually a
shell script that starts up the virtual machine with a -i argument
specifying the development environment heap image, and a -o argument
specifying the location of the virtual machine.
-----
Command processor
When you invoke the default heap image, a command processor starts
running. At the > prompt, you can type either a Scheme form
(expression or definition), or a command beginning with a comma.
Logistical commands:
,load <filename> ... load Scheme source file(s)
Easier to type than (load "filename") because you don't have to
shift to type the parentheses or quote marks. Also, it works in
any package, unlike (load "filename"), which will work only work
in packages in which the variable LOAD is defined properly.
,exit [<exp>] leave
Exit back out to shell (or executive or whatever invoked Scheme 48
in the first place). <exp> should evaluate to an integer. The
integer is returned to the calling program. (On Unix, 0 is
generally interpreted as success, nonzero as failure.)
Command levels:
If an errors occurs, you are put in a command loop at the dynamic
point at which the error occurred. The prompt will then be "n >"
where n is the command level nesting depth.
<eof>
Pop out one level (running any dynamic-wind "after" thunks), and
resumes running all non-broken threads. EOF after a keyboard
interrupt resumes running the interrupted thread. <eof> is usually
control-D at a Unix shell or using the Emacs "cmuscheme48" library.
,reset top level
Unwind all the way back out to top level.
,level <number> go to command level
Unwind out to a given level. ,level 0 is the same as ,reset.
,push
Go to a deeper command level. (See ,levels, below.)
Debugging commands:
,preview
Sort of like a backtrace, but because of tail recursion you see
less than you might in debuggers for some other languages.
,threads
Invoke the inspector on the threads running on the next level out.
,proceed <exp> ...
Proceed after an interrupt or error, delivering the values of <exp>
... to the continuation.
,trace <name> ...
Start tracing calls to the named procedure or procedures.
With no arguments, displays all procedures currently traced.
This affects the binding of <name>, not the behavior of the
procedure that's it's current value. The effect is similar to
(define <name> (make-traced <name>))
where make-traced is a procedure-returning procedure.
,untrace <name> ...
Stop tracing calls to the named procedure or procedures.
With no argument, stop tracing all calls to all procedures.
,condition
The ,condition command selects and displays the condition object
describing the error or interrupt that initiated the current
command level. This is particularly useful in conjunction with
the inspector. E.g. if a procedure is passed the wrong number of
arguments, do ,condition followed by ,inspect ## to inspect the
procedure and its arguments.
,bound? <name>
Display the binding of <name>, if there is one.
,expand <form>
Show macro expansion of <form>, if any.
,where <procedure>
Display name of source file in which <procedure> is defined.
Building images:
,dump <filename> [<identification>]
This writes out the current heap. When the new image is resumed,
it starts in the command processor. If present, <identification>
should be a string (written with double quotes); this string will
be part of the greeting message as the image starts up.
,build <exp> <filename>
<exp> should evaluate to a procedure of one argument. When
<filename> is resumed, that procedure will be invoked on the VM's
-a arguments, which are passed as a list of strings. The
procedure should return an integer (as for ,exit). The command
processor and debugging system are not included in the image
(unless you go to some effort to preserve them, such as retaining
a continuation).
Doing ",flush" before building an image will make for smaller
images, but if an error occurs, the error message may be less
helpful. Doing ",flush source maps" before loading any programs
will make the image still smaller.
Modes:
When given no argument, all of these commands toggle the corresponding
mode. With the argument ?, the current setting is displayed.
Otherwise the argument should be ON or OFF.
,batch [on | off | ?]
In "batch mode," any error or interrupt that comes up will cause
Scheme 48 to exit immediately with a non-zero exit status. Also,
the command processor doesn't print prompts. The default is
interactive mode.
,form-preferred [on | off | ?]
Enable or disable "form preferred" mode. In this mode, command
processor commands needn't be prefixed by comma. To see the value
of a variable (or number - this should be fixed), do (begin
<name>). "Command preferred" mode is the default.
,levels [on | off | ?]
Enable or disable command levels. With levels enabled (the
default), errors "push" a new command level, and <eof> (see above)
or ,reset is required to return to top level. The effects of
pushed command levels include:
- a longer prompt
- retention of the continuation in effect at the point of errors
- longer ,previews
- confusion among some newcomers
With levels disabled, one must issue a ,push command immediately
following an error in order to retain the error continuation for
debugging purposes; otherwise the continuation is lost after the
next evaluation request. If you don't know anything about the
available debugging tools, then levels might as well be disabled.
This is an experimental feature inspired by gripes about how
confusing recursive command loop levels are to newcomers to
Scheme. Let me know (jar@ai.mit.edu) if you like it; otherwise it
might get flushed.
Each level has its own set of threads, so pushing a new level stops
all threads running at the current level.
,break-on-warnings [on | off | ?]
When a warning is produced, enter a new command level, just as
when an error occurs.
Resource query and control:
,time <exp>
Measure execution time.
,collect
Invoke the garbage collector. Ordinarily this happens
automatically, but the command tells how much space is available
before and after the collection.
,keep <kind>
,flush <kind>
These control the amount of debugging information retained after
compiling procedures. This information can consume a fair amount
of space. <kind> is one of the following:
. maps - environment maps (local variable names, for inspector)
. source - source code for continuations (displayed by inspector)
. names - procedure names (as displayed by WRITE and in error
messages)
. files - source file names
These commands refer to future compilations only, not to procedures
that already exist. To have any effect, they must be done before
programs are loaded.
,flush
The flush command with no argument deletes the database of names
of initial procedures. Doing ",flush" before a ,build or ,dump
will make the resulting image significantly smaller (by up to 200K
bytes), but will compromise the information content of many error
messages.
Quite obscure:
,go <exp>
This is like ,exit <exp> except that the evaluation of <exp>
is tail-recursive with respect to the command processor. This
means that the command processor itself can probably be GC'ed,
should a garbage collection occur in the execution of <exp>.
Any errors will be treated as in batch mode.
,translate <from> <to>
For LOAD and the ,load command (but not for OPEN-xxPUT-FILE), file
names beginning with the string <from> will be changed so that the
initial <from> is replaced by the string <to>. E.g.
,translate /usr/gjc/ /zu/gjc/
will cause (load "/usr/gjc/foo.scm") to have the same effect as
(load "/zu/gjc/foo.scm").
,from-file <filename> <form> ... ,end
This is used by the cmuscheme48 Emacs library.
Other commands are (or should be) described in the module system
document.
-----
Editing
We recommend running Scheme 48 under Gnu Emacs using the cmuscheme48
command package. This is in the Scheme 48 distribution's emacs/
subdirectory. It is a variant of the "cmuscheme" library, which
comes to us courtesy of Olin Shivers, formerly of CMU. You might want
to put the following in your emacs init file (.emacs):
(setq scheme-program-name "scheme48")
(autoload 'run-scheme "cmuscheme48" "Run an inferior Scheme process." t)
To make the autoload and (require ...) forms work, you will also need
to put the directory containing cmuscheme and related files in your
emacs load-path:
(setq load-path (append load-path '("<scheme-48-directory>/emacs")))
For further documentation see emacs/cmuscheme48.el and emacs/comint.el.
-----
Performance
If you want to generally have your code run faster than it normally
would, enter "benchmark mode" before loading anything. Otherwise
calls to primitives (like + and cons) and in-line procedures (like not
and cadr) won't be open-coded, and programs will run more slowly.
Enter benchmark mode by issuing the ,bench command to the command
processor.
The system doesn't start in benchmark mode by default because the
Scheme report permits redefinitions of built-in procedures. In
benchmark mode, such redefinitions don't work according to the report,
because previously compiled calls may have in-lined the old
definition, leaving no opportunity to call the new definition.
",bench" toggles benchmark mode. ",bench on" and ",bench off" turn it
on and off.
-----
Inspector
There is a low-tech inspector available via the ,inspect and ,debug
commands. The ,inspect command starts an inspector command loop.
There is a focus object (the same as the command processor's ##), for
which a menu of selectable components is displayed. To inspect a
particular component, just type the corresponding number in the menu.
For example:
,inspect '(a (b c) d)
(a (b c) d)
[0] a
[1] (b c)
[2] d
inspect: 1
(b c)
[0] b
[1] c
inspect:
When a new object is selected, the previous one is pushed onto a
stack. You can pop the stack, reverting to the previous object, with
the U command.
The inspector is particularly useful with procedures, continuations,
and records.
Other inspector commands:
u pop object stack
d down stack (current object must be a continuation)
m print more of a long menu
(...) evaluate a form and select result
t select a closure or continuation's template
q quit
## is always the object currently being inspected. After a Q command,
or an error in the inspector, ## is the last object that was being
inspected.
The inspector also accepts arbitrary command processor commands, e.g.
the ,dis command (see below). The leading comma is optional.
After an error occurs, ,debug invokes the inspector on the
continuation at the point of the error. The U and D (up and down)
commands then make the inspector look like a conventional stack
debugger, with continuations playing the role of stack frames. D goes
to older or deeper continuations (frames), and U goes back up to more
recent ones.
Templates are the static components of procedures; these are found
inside of procedures and continuations, and contain the quoted
constants and top-level variables referred to by byte-compiled code.
-----
Disassembler
The ,dis command disassembles procedures.
> ,dis cons
cons
0 (check-nargs= 2)
2 (pop)
3 (make-stored-object 2 pair)
6 (return)
>
The command argument is optional; if unsupplied it defaults to the
current focus object (##).
The disassembler can also be invoked on continuations and templates.
-----
Module system
For information on the module (package) system, see doc/module.tex.
-----
Library
A number of useful utilities are either built in to Scheme 48 or can
be loaded from an external library. These utilities are not visible
in the user environment by default, but can be made available with the
,open command. For example, to use the tables structure, do
> ,open tables
>
If the utility is not already loaded, then the ,open command will
offer to load it:
> ,open queues
Load structure queues (y/n)?
Or, you can load something explicitly (without opening it) using the
load-package command:
> ,load-package queues
...
> ,open queues
When loading a utility, the message "Note: optional optimizer not
invoked" is innocuous. Feel free to ignore it.
See also the package system documentation, doc/module.tex.
Unfortunately, few of these wonderful things are documented. They are
listed, however, in files rts-packages.scm, comp-packages.scm, and
more-packages.scm in the distribution directory, and the bindings they
export are listed in interfaces.scm and more-interfaces.scm. Here is
a little information on the more generally useful structures.
architecture
Information about the virtual machine. E.g.
(enum op eq?) => the integer opcode of the EQ? instruction
arrays
Arrays. See comments at the top of file big/array.scm.
ascii
CHAR->ASCII and ASCII->CHAR. Similar to CHAR->INTEGER and
INTEGER->CHAR except that ASCII encoding is guaranteed.
big-scheme
Many generally useful features. See doc/big-scheme.txt.
bigbit
Extensions to the bitwise logical operators (exported by
the BITWISE structure) so that they operate on bignums.
To use these you should do
,load-package bigbit
,open bitwise
bitwise
Bitwise logical operators. See doc/big-scheme.txt.
conditions
Part of the condition system: DEFINE-CONDITION-PREDICATE and
routines for examining condition objects. (See also handle,
signals.)
define-record-types
A DEFINE-RECORD-TYPE macro, providing a concise front end to the
record package. (Richard and Jonathan favor different
record type defining macros; this one is Jonathan's.)
The general syntax is:
(define-record-type <tag> <type-name>
(<constructor-name> <field-tag>*)
<predicate-name>
(<field-tag> <accessor-name> [<modifier-name>])*)
Example:
(define-record-type pare :pare
(kons x y)
pare?
(x kar set-kar!)
(y kdr))
This defines KONS to be a constructor, KAR and KDR to be
accessors, SET-KAR! to be a modifier, and PARE? to be a predicate
for a new type of object. The type itself is named :PARE.
PARE is a tag used in printing the new objects.
The field tags X and Y are used in the inspector and to match
constructor arguments with fields.
By default, the new objects print as #{Pare}. The print method
can be modified using DEFINE-RECORD-DISCLOSER:
(define-record-discloser :pare
(lambda (p) `(pare ,(kar p) ,(kdr p))))
defpackage
The module system: DEFINE-STRUCTURE and DEFINE-INTERFACE.
defrecord
A define-record-type macro, providing more concise use of the
record package. (Richard and Jonathan favor different
record type defining macros; this one is Richard's.)
destructuring
DESTRUCTURE macro. See doc/big-scheme.txt.
display-conditions
Displaying condition objects.
(DISPLAY-CONDITION condition port) => unspecific
Display condition in an easily readable form. E.g.
> ,open display-conditions handle conditions
> (display-condition
(call-with-current-continuation
(lambda (k)
(with-handler (lambda (c punt)
(if (error? c)
(k c)
(punt)))
(lambda () (+ 1 'a)))))
(current-output-port))
Error: exception
(+ 1 'a)
>
enumerated
Enumerated types. See doc/big-scheme.txt.
extended-ports
Ports for reading from and writing to strings, and related things.
See doc/big-scheme.txt.
externals
Rudimentary external function interface. See doc/external.txt.
filenames
Rudimentary file name parsing and synthesis. E.g.
file-name-directory and file-name-nondirectory are as in Gnu emacs.
floatnums
Floating point numbers. These are in a very crude state; use at
your own risk. They are slow and do not read or print correctly.
fluids
Dynamically bound "variables."
(MAKE-FLUID top-level-value) => a "fluid" object
(FLUID fluid) => current value of fluid object
(SET-FLUID! fluid value) => unspecific; changes current value of
fluid object
(LET-FLUID fluid value thunk) => whatever thunk returns
Within the dynamic extent of execution of (thunk), the fluid
object has value as its binding (unless changed by SET-FLUID!
or overridden by another LET-FLUID).
E.g.
(define f (make-fluid 7))
(define (baz) (+ (fluid f) 1))
(baz) ;=> 8
(let-fluid f 4 (lambda () (+ (baz) 1))) ;=> 6
formats
A simple FORMAT procedure, similar to Common Lisp's or T's.
See doc/big-scheme.txt for documentation.
general-tables
An extended version of TABLES; supports tables keyed by strings.
See doc/big-scheme.txt.
handle
Part of the condition system.
(WITH-HANDLER handler thunk) => whatever thunk returns.
handler is a procedure of two arguments. The first argument
is a condition object, and the second is a "punt" procedure.
The handler should examine the condition object (using ERROR?,
etc. from the CONDITIONS structure). If it decides not to do
anything special, it should tail-call the "punt" procedure.
Otherwise it should take appropriate action and perform a
non-local exit. It should not just return unless it knows
damn well what it's doing; returns in certain situations can
cause VM crashes.
interrupts
Interrupt system
ports
A few extra port-related operations, notably FORCE-OUTPUT.
pp
A pretty-printer. (p <exp>) will pretty-print the result of <exp>,
which must be an S-expression. (Source code for procedures is not
retained or reconstructed.) You can also do (p <exp> <port>) to
print to a specific port.
The procedure pretty-print takes three arguments: the object to be
printed, a port to write to, and the current horizontal cursor
position. If you've just done a newline, then pass in zero for
the position argument.
The algorithm is very peculiar, and sometimes buggy.
queues
FIFO queues.
random
Not-very-random random number generator. The <seed> should be between
0 and 2^28 exclusive.
> (define random (make-random <seed>))
> (random) => a pseudo-random number between 0 and 2^28
receiving
Convenient interface to the call-with-values procedure, like
Common Lisp's multiple-value-bind macro. See doc/big-scheme.txt.
records
MAKE-RECORD-TYPE and friends. See the Scheme of Things column in
Lisp Pointers, volume 4, number 1, for documentation.
recnums
Complex numbers. This should be loaded (e.g. with ,load-package)
but needn't be opened.
search-trees
Balanced binary search trees. See comments at top of
big/search-tree.scm.
signals
ERROR, WARN, and related procedures.
sort
Online merge sort (see comment at top of file big/sort.scm).
(sort-list <list> <pred>)
(sort-list! <list> <pred>)
sicp
Compatibility package for the Scheme dialect used in the book
"Structure and Interpretation of Computer Programs."
sockets
Interface to Unix BSD sockets. See comments at top of file
misc/socket.scm.
tables
Hashed association tables. Keys are compared using EQ?.
See doc/big-scheme.txt.
threads
Multitasking. See doc/threads.txt.
util
SUBLIST, ANY, REDUCE, FILTER, and some other useful things.
weak
Weak pointers and populations.
(MAKE-WEAK-POINTER thing) => weak-pointer
(WEAK-POINTER-REF weak-pointer) => thing or #F
#F if the thing has been gc'ed.
writing
(RECURRING-WRITE thing port recur) => unspecific
This is the same as WRITE except that recursive calls invoke
the recur argument instead of WRITE. For an example, see
the definition of LIMITED-WRITE in env/dispcond.scm, which
implements processing similar to common Lisp's *print-level*
and *print-length*.
-----
Acknowledgment
Thanks to Deborah Tatar for providing the Yeats quotation.

2536
doc/utilities.ps Normal file
View File

File diff suppressed because it is too large Load Diff

47
emacs/README Normal file
View File

@ -0,0 +1,47 @@
Date: Thu, 9 Jul 92 13:26:05 HKT
From: shivers@csd.hku.hk (Olin G. Shivers)
To: jar@cs.cornell.edu
In-Reply-To: Jonathan Rees's message of Wed, 8 Jul 92 22:15:22 -0400 <9207090215.AA00991@sindri.cs.cornell.edu>
Subject: cmulisp
It's also in Ozan's repository, but I don't know how up-to-date it is.
It's always useful to list his repository as a possible location, tho.
-Olin
/afs/cs.cmu.edu/user/shivers/lib/Readme:
This directory contains the following subdirectories:
emacs Gnu emacs packages.
papers My papers, in .dvi and postscript form.
tex LaTeX packages.
All of these files can be anonymously ftp'd.
-Olin
July 3, 1991
===============================================================================
Directions for anonymous ftp:
1. ftp to any CMU machine with access to the /afs network file system.
Almost any machine will do; some possibilities are:
cs.cmu.edu 128.2.222.173
a.gp.cs.cmu.edu 128.2.242.7
f.gp.cs.cmu.edu 128.2.250.164
h.gp.cs.cmu.edu 128.2.254.156
k.gp.cs.cmu.edu 128.2.254.137
2. login as anonymous
You are supposed to provide username@host as the password. The CMU
ftp demon actually checks to ensure there's an "@" in the password.
So you can't just say "foo"; you have to say "foo@bar".
3. cd /afs/cs.cmu.edu/user/shivers/lib
CMU ftp restricts the directories you can access anonymously,
so you must cd straight to the .../lib directory or its descendants.
4. If you are transfering .dvi or other binary files, set the file transfer
mode to raw binary with one of the following commands:
type image
type binary
image
binary
If you don't do this, the files may be garbled.
5. Use dir or ls to list the directory.
6. Transfer the files you want.

693
emacs/cmulisp.el Normal file
View File

@ -0,0 +1,693 @@
;;; -*-Emacs-Lisp-*- cmulisp.el
;;; Copyright Olin Shivers (1988).
;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
;;; notice appearing here to the effect that you may use this code any
;;; way you like, as long as you don't charge money for it, remove this
;;; notice, or hold me liable for its results.
;;; This replaces the standard inferior-lisp mode.
;;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88
;;; Please send me bug reports, bug fixes, and extensions, so that I can
;;; merge them into the master source.
;;;
;;; Change log at end of file.
;;; This file defines a a lisp-in-a-buffer package (cmulisp mode) built on top
;;; of comint mode. Cmulisp mode is similar to, and intended to replace, its
;;; counterpart in the standard gnu emacs release. This replacements is more
;;; featureful, robust, and uniform than the released version. The key
;;; bindings are also more compatible with the bindings of Hemlock and Zwei
;;; (the Lisp Machine emacs).
;;; Since this mode is built on top of the general command-interpreter-in-
;;; a-buffer mode (comint mode), it shares a common base functionality,
;;; and a common set of bindings, with all modes derived from comint mode.
;;; This makes these modes easier to use.
;;; For documentation on the functionality provided by comint mode, and
;;; the hooks available for customising it, see the file comint.el.
;;; For further information on cmulisp mode, see the comments below.
;;; Needs fixin:
;;; The load-file/compile-file default mechanism could be smarter -- it
;;; doesn't know about the relationship between filename extensions and
;;; whether the file is source or executable. If you compile foo.lisp
;;; with compile-file, then the next load-file should use foo.bin for
;;; the default, not foo.lisp. This is tricky to do right, particularly
;;; because the extension for executable files varies so much (.o, .bin,
;;; .lbin, .mo, .vo, .ao, ...).
;;;
;;; It would be nice if cmulisp (and inferior scheme, T, ...) modes
;;; had a verbose minor mode wherein sending or compiling defuns, etc.
;;; would be reflected in the transcript with suitable comments, e.g.
;;; ";;; redefining fact". Several ways to do this. Which is right?
;;;
;;; When sending text from a source file to a subprocess, the process-mark can
;;; move off the window, so you can lose sight of the process interactions.
;;; Maybe I should ensure the process mark is in the window when I send
;;; text to the process? Switch selectable?
(require 'comint)
;; YOUR .EMACS FILE
;;=============================================================================
;; Some suggestions for your .emacs file.
;;
;; ; If cmulisp lives in some non-standard directory, you must tell emacs
;; ; where to get it. This may or may not be necessary.
;; (setq load-path (cons (expand-file-name "~jones/lib/emacs") load-path))
;;
;; ; Autoload cmulisp from file cmulisp.el
;; (autoload 'cmulisp "cmulisp"
;; "Run an inferior Lisp process."
;; t)
;;
;; ; Define C-c t to run my favorite command in cmulisp mode:
;; (setq cmulisp-load-hook
;; '((lambda ()
;; (define-key cmulisp-mode-map "\C-ct" 'favorite-cmd))))
;;; Brief Command Documentation:
;;;============================================================================
;;; Comint Mode Commands: (common to cmulisp and all comint-derived modes)
;;;
;;; m-p comint-previous-input Cycle backwards in input history
;;; m-n comint-next-input Cycle forwards
;;; m-c-r comint-previous-input-matching Search backwards in input history
;;; return comint-send-input
;;; c-a comint-bol Beginning of line; skip prompt.
;;; c-d comint-delchar-or-maybe-eof Delete char unless at end of buff.
;;; c-c c-u comint-kill-input ^u
;;; c-c c-w backward-kill-word ^w
;;; c-c c-c comint-interrupt-subjob ^c
;;; c-c c-z comint-stop-subjob ^z
;;; c-c c-\ comint-quit-subjob ^\
;;; c-c c-o comint-kill-output Delete last batch of process output
;;; c-c c-r comint-show-output Show last batch of process output
;;; send-invisible Read line w/o echo & send to proc
;;; comint-continue-subjob Useful if you accidentally suspend
;;; top-level job.
;;; comint-mode-hook is the comint mode hook.
;;; CMU Lisp Mode Commands:
;;; c-m-x lisp-send-defun This binding is a gnu convention.
;;; c-c c-l lisp-load-file Prompt for file name; tell Lisp to load it.
;;; c-c c-k lisp-compile-file Prompt for file name; tell Lisp to kompile it.
;;; Filename completion is available, of course.
;;;
;;; Additionally, these commands are added to the key bindings of Lisp mode:
;;; c-m-x lisp-eval-defun This binding is a gnu convention.
;;; c-c c-e lisp-eval-defun Send the current defun to Lisp process.
;;; c-x c-e lisp-eval-last-sexp Send the previous sexp to Lisp process.
;;; c-c c-r lisp-eval-region Send the current region to Lisp process.
;;; c-c c-c lisp-compile-defun Compile the current defun in Lisp process.
;;; c-c c-z switch-to-lisp Switch to the Lisp process buffer.
;;; c-c c-l lisp-load-file (See above. In a Lisp file buffer, default
;;; c-c c-k lisp-compile-file is to load/compile the current file.)
;;; c-c c-d lisp-describe-sym Query Lisp for a symbol's description.
;;; c-c c-a lisp-show-arglist Query Lisp for function's arglist.
;;; c-c c-f lisp-show-function-documentation Query Lisp for a function's doc.
;;; c-c c-v lisp-show-variable-documentation Query Lisp for a variable's doc.
;;; cmulisp Fires up the Lisp process.
;;; lisp-compile-region Compile all forms in the current region.
;;;
;;; CMU Lisp Mode Variables:
;;; cmulisp-filter-regexp Match this => don't get saved on input hist
;;; inferior-lisp-program Name of Lisp program run-lisp executes
;;; inferior-lisp-load-command Customises lisp-load-file
;;; cmulisp-mode-hook
;;; inferior-lisp-prompt Initialises comint-prompt-regexp.
;;; Backwards compatibility.
;;; lisp-source-modes Anything loaded into a buffer that's in
;;; one of these modes is considered Lisp
;;; source by lisp-load/compile-file.
;;; Read the rest of this file for more information.
(defvar cmulisp-filter-regexp "\\`\\s *\\(:\\(\\w\\|\\s_\\)\\)?\\s *\\'"
"*What not to save on inferior Lisp's input history
Input matching this regexp is not saved on the input history in cmulisp
mode. Default is whitespace followed by 0 or 1 single-letter :keyword
(as in :a, :c, etc.)")
(defvar cmulisp-mode-map nil)
(cond ((not cmulisp-mode-map)
(setq cmulisp-mode-map
(copy-keymap comint-mode-map))
(lisp-mode-commands cmulisp-mode-map)
(define-key cmulisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp)
(define-key cmulisp-mode-map "\C-c\C-l" 'lisp-load-file)
(define-key cmulisp-mode-map "\C-c\C-k" 'lisp-compile-file)
(define-key cmulisp-mode-map "\C-c\C-a" 'lisp-show-arglist)
(define-key cmulisp-mode-map "\C-c\C-d" 'lisp-describe-sym)
(define-key cmulisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation)
(define-key cmulisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation)))
;;; These commands augment Lisp mode, so you can process Lisp code in
;;; the source files.
(define-key lisp-mode-map "\M-\C-x" 'lisp-eval-defun) ; Gnu convention
(define-key lisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) ; Gnu convention
(define-key lisp-mode-map "\C-c\C-e" 'lisp-eval-defun)
(define-key lisp-mode-map "\C-c\C-r" 'lisp-eval-region)
(define-key lisp-mode-map "\C-c\C-c" 'lisp-compile-defun)
(define-key lisp-mode-map "\C-c\C-z" 'switch-to-lisp)
(define-key lisp-mode-map "\C-c\C-l" 'lisp-load-file)
(define-key lisp-mode-map "\C-c\C-k" 'lisp-compile-file) ; "kompile" file
(define-key lisp-mode-map "\C-c\C-a" 'lisp-show-arglist)
(define-key lisp-mode-map "\C-c\C-d" 'lisp-describe-sym)
(define-key lisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation)
(define-key lisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation)
;;; This function exists for backwards compatibility.
;;; Previous versions of this package bound commands to C-c <letter>
;;; bindings, which is not allowed by the gnumacs standard.
(defun cmulisp-install-letter-bindings ()
"This function binds many cmulisp commands to C-c <letter> bindings,
where they are more accessible. C-c <letter> bindings are reserved for the
user, so these bindings are non-standard. If you want them, you should
have this function called by the cmulisp-load-hook:
(setq cmulisp-load-hook '(cmulisp-install-letter-bindings))
You can modify this function to install just the bindings you want."
(define-key lisp-mode-map "\C-ce" 'lisp-eval-defun-and-go)
(define-key lisp-mode-map "\C-cr" 'lisp-eval-region-and-go)
(define-key lisp-mode-map "\C-cc" 'lisp-compile-defun-and-go)
(define-key lisp-mode-map "\C-cz" 'switch-to-lisp)
(define-key lisp-mode-map "\C-cl" 'lisp-load-file)
(define-key lisp-mode-map "\C-ck" 'lisp-compile-file)
(define-key lisp-mode-map "\C-ca" 'lisp-show-arglist)
(define-key lisp-mode-map "\C-cd" 'lisp-describe-sym)
(define-key lisp-mode-map "\C-cf" 'lisp-show-function-documentation)
(define-key lisp-mode-map "\C-cv" 'lisp-show-variable-documentation)
(define-key cmulisp-mode-map "\C-cl" 'lisp-load-file)
(define-key cmulisp-mode-map "\C-ck" 'lisp-compile-file)
(define-key cmulisp-mode-map "\C-ca" 'lisp-show-arglist)
(define-key cmulisp-mode-map "\C-cd" 'lisp-describe-sym)
(define-key cmulisp-mode-map "\C-cf" 'lisp-show-function-documentation)
(define-key cmulisp-mode-map "\C-cv" 'lisp-show-variable-documentation))
(defvar inferior-lisp-program "lisp"
"*Program name for invoking an inferior Lisp with `cmulisp'.")
(defvar inferior-lisp-load-command "(load \"%s\")\n"
"*Format-string for building a Lisp expression to load a file.
This format string should use %s to substitute a file name
and should result in a Lisp expression that will command the inferior Lisp
to load that file. The default works acceptably on most Lisps.
The string \"(progn (load \\\"%s\\\" :verbose nil :print t) (values))\\\n\"
produces cosmetically superior output for this application,
but it works only in Common Lisp.")
(defvar inferior-lisp-prompt "^[^> ]*>+:? *"
"Regexp to recognise prompts in the inferior Lisp.
Defaults to \"^[^> ]*>+:? *\", which works pretty good for Lucid, kcl,
and franz. This variable is used to initialise comint-prompt-regexp in the
cmulisp buffer.
More precise choices:
Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\"
franz: \"^\\(->\\|<[0-9]*>:\\) *\"
kcl: \"^>+ *\"
This is a fine thing to set in your .emacs file.")
(defvar cmulisp-mode-hook '()
"*Hook for customising cmulisp mode")
(defun cmulisp-mode ()
"Major mode for interacting with an inferior Lisp process.
Runs a Lisp interpreter as a subprocess of Emacs, with Lisp I/O through an
Emacs buffer. Variable inferior-lisp-program controls which Lisp interpreter
is run. Variables inferior-lisp-prompt, cmulisp-filter-regexp and
inferior-lisp-load-command can customize this mode for different Lisp
interpreters.
For information on running multiple processes in multiple buffers, see
documentation for variable cmulisp-buffer.
\\{cmulisp-mode-map}
Customisation: Entry to this mode runs the hooks on comint-mode-hook and
cmulisp-mode-hook (in that order).
You can send text to the inferior Lisp process from other buffers containing
Lisp source.
switch-to-lisp switches the current buffer to the Lisp process buffer.
lisp-eval-defun sends the current defun to the Lisp process.
lisp-compile-defun compiles the current defun.
lisp-eval-region sends the current region to the Lisp process.
lisp-compile-region compiles the current region.
Prefixing the lisp-eval/compile-defun/region commands with
a \\[universal-argument] causes a switch to the Lisp process buffer after sending
the text.
Commands:
Return after the end of the process' output sends the text from the
end of process to point.
Return before the end of the process' output copies the sexp ending at point
to the end of the process' output, and sends it.
Delete converts tabs to spaces as it moves back.
Tab indents for Lisp; with argument, shifts rest
of expression rigidly with the current line.
C-M-q does Tab on each line starting within following expression.
Paragraphs are separated only by blank lines. Semicolons start comments.
If you accidentally suspend your process, use \\[comint-continue-subjob]
to continue it."
(interactive)
(kill-all-local-variables)
(comint-mode)
(setq comint-prompt-regexp inferior-lisp-prompt)
(setq major-mode 'cmulisp-mode)
(setq mode-name "CMU Lisp")
(setq mode-line-process '(": %s"))
(if (string-match "^18.4" emacs-version) ; hack.
(lisp-mode-variables) ; This is right for 18.49
(lisp-mode-variables t)) ; This is right for 18.50
(use-local-map cmulisp-mode-map) ;c-c c-k for "kompile" file
(setq comint-get-old-input (function lisp-get-old-input))
(setq comint-input-filter (function lisp-input-filter))
(setq comint-input-sentinel 'ignore)
(run-hooks 'cmulisp-mode-hook))
(defun lisp-get-old-input ()
"Snarf the sexp ending at point"
(save-excursion
(let ((end (point)))
(backward-sexp)
(buffer-substring (point) end))))
(defun lisp-input-filter (str)
"Don't save anything matching cmulisp-filter-regexp"
(not (string-match cmulisp-filter-regexp str)))
(defun cmulisp (&optional cmd)
"Run an inferior Lisp process, input and output via buffer *cmulisp*.
If there is a process already running in *cmulisp*, just switch to that buffer.
With argument, allows you to edit the command line (default is value
of inferior-lisp-program). Runs the hooks from cmulisp-mode-hook (after the
comint-mode-hook is run).
\(Type \\[describe-mode] in the process buffer for a list of commands.)"
(interactive (list (and current-prefix-arg
(read-string "Run lisp: " inferior-lisp-program))))
(let ((cmd (or cmd inferior-lisp-program)))
(if (not (comint-check-proc "*cmulisp*"))
(let ((cmdlist (cmulisp-args-to-list cmd)))
(set-buffer (apply (function make-comint) "cmulisp" (car cmdlist) nil
(cdr cmdlist)))
(cmulisp-mode))))
(setq cmulisp-buffer "*cmulisp*")
(switch-to-buffer "*cmulisp*"))
;;; Break a string up into a list of arguments.
;;; This will break if you have an argument with whitespace, as in
;;; string = "-ab +c -x 'you lose'".
(defun cmulisp-args-to-list (string)
(let ((where (string-match "[ \t]" string)))
(cond ((null where) (list string))
((not (= where 0))
(cons (substring string 0 where)
(cmulisp-args-to-list (substring string (+ 1 where)
(length string)))))
(t (let ((pos (string-match "[^ \t]" string)))
(if (null pos)
nil
(cmulisp-args-to-list (substring string pos
(length string)))))))))
(defun lisp-eval-region (start end &optional and-go)
"Send the current region to the inferior Lisp process.
Prefix argument means switch-to-lisp afterwards."
(interactive "r\nP")
(comint-send-region (cmulisp-proc) start end)
(comint-send-string (cmulisp-proc) "\n")
(if and-go (switch-to-lisp t)))
(defun lisp-eval-defun (&optional and-go)
"Send the current defun to the inferior Lisp process.
Prefix argument means switch-to-lisp afterwards."
(interactive "P")
(save-excursion
(end-of-defun)
(skip-chars-backward " \t\n\r\f") ; Makes allegro happy
(let ((end (point)))
(beginning-of-defun)
(lisp-eval-region (point) end)))
(if and-go (switch-to-lisp t)))
(defun lisp-eval-last-sexp (&optional and-go)
"Send the previous sexp to the inferior Lisp process.
Prefix argument means switch-to-lisp afterwards."
(interactive "P")
(lisp-eval-region (save-excursion (backward-sexp) (point)) (point) and-go))
;;; Common Lisp COMPILE sux.
(defun lisp-compile-region (start end &optional and-go)
"Compile the current region in the inferior Lisp process.
Prefix argument means switch-to-lisp afterwards."
(interactive "r\nP")
(comint-send-string (cmulisp-proc)
(format "(funcall (compile nil `(lambda () (progn 'compile %s))))\n"
(buffer-substring start end)))
(if and-go (switch-to-lisp t)))
(defun lisp-compile-defun (&optional and-go)
"Compile the current defun in the inferior Lisp process.
Prefix argument means switch-to-lisp afterwards."
(interactive "P")
(save-excursion
(end-of-defun)
(skip-chars-backward " \t\n\r\f") ; Makes allegro happy
(let ((e (point)))
(beginning-of-defun)
(lisp-compile-region (point) e)))
(if and-go (switch-to-lisp t)))
(defun switch-to-lisp (eob-p)
"Switch to the inferior Lisp process buffer.
With argument, positions cursor at end of buffer."
(interactive "P")
(if (get-buffer cmulisp-buffer)
(pop-to-buffer cmulisp-buffer)
(error "No current process buffer. See variable cmulisp-buffer."))
(cond (eob-p
(push-mark)
(goto-char (point-max)))))
;;; Now that lisp-compile/eval-defun/region takes an optional prefix arg,
;;; these commands are redundant. But they are kept around for the user
;;; to bind if he wishes, for backwards functionality, and because it's
;;; easier to type C-c e than C-u C-c C-e.
(defun lisp-eval-region-and-go (start end)
"Send the current region to the inferior Lisp,
and switch to the process buffer."
(interactive "r")
(lisp-eval-region start end t))
(defun lisp-eval-defun-and-go ()
"Send the current defun to the inferior Lisp,
and switch to the process buffer."
(interactive)
(lisp-eval-defun t))
(defun lisp-compile-region-and-go (start end)
"Compile the current region in the inferior Lisp,
and switch to the process buffer."
(interactive "r")
(lisp-compile-region start end t))
(defun lisp-compile-defun-and-go ()
"Compile the current defun in the inferior Lisp,
and switch to the process buffer."
(interactive)
(lisp-compile-defun t))
;;; A version of the form in H. Shevis' soar-mode.el package. Less robust.
;(defun lisp-compile-sexp (start end)
; "Compile the s-expression bounded by START and END in the inferior lisp.
;If the sexp isn't a DEFUN form, it is evaluated instead."
; (cond ((looking-at "(defun\\s +")
; (goto-char (match-end 0))
; (let ((name-start (point)))
; (forward-sexp 1)
; (process-send-string "cmulisp" (format "(compile '%s #'(lambda "
; (buffer-substring name-start
; (point)))))
; (let ((body-start (point)))
; (goto-char start) (forward-sexp 1) ; Can't use end-of-defun.
; (process-send-region "cmulisp" (buffer-substring body-start (point))))
; (process-send-string "cmulisp" ")\n"))
; (t (lisp-eval-region start end)))))
;
;(defun lisp-compile-region (start end)
; "Each s-expression in the current region is compiled (if a DEFUN)
;or evaluated (if not) in the inferior lisp."
; (interactive "r")
; (save-excursion
; (goto-char start) (end-of-defun) (beginning-of-defun) ; error check
; (if (< (point) start) (error "region begins in middle of defun"))
; (goto-char start)
; (let ((s start))
; (end-of-defun)
; (while (<= (point) end) ; Zip through
; (lisp-compile-sexp s (point)) ; compiling up defun-sized chunks.
; (setq s (point))
; (end-of-defun))
; (if (< s end) (lisp-compile-sexp s end)))))
;;;
;;; End of HS-style code
(defvar lisp-prev-l/c-dir/file nil
"Saves the (directory . file) pair used in the last lisp-load-file or
lisp-compile-file command. Used for determining the default in the
next one.")
(defvar lisp-source-modes '(lisp-mode)
"*Used to determine if a buffer contains Lisp source code.
If it's loaded into a buffer that is in one of these major modes, it's
considered a Lisp source file by lisp-load-file and lisp-compile-file.
Used by these commands to determine defaults.")
(defun lisp-load-file (file-name)
"Load a Lisp file into the inferior Lisp process."
(interactive (comint-get-source "Load Lisp file: " lisp-prev-l/c-dir/file
lisp-source-modes nil)) ; NIL because LOAD
; doesn't need an exact name
(comint-check-source file-name) ; Check to see if buffer needs saved.
(setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name)
(file-name-nondirectory file-name)))
(comint-send-string (cmulisp-proc)
(format inferior-lisp-load-command file-name))
(switch-to-lisp t))
(defun lisp-compile-file (file-name)
"Compile a Lisp file in the inferior Lisp process."
(interactive (comint-get-source "Compile Lisp file: " lisp-prev-l/c-dir/file
lisp-source-modes nil)) ; NIL = don't need
; suffix .lisp
(comint-check-source file-name) ; Check to see if buffer needs saved.
(setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name)
(file-name-nondirectory file-name)))
(comint-send-string (cmulisp-proc) (concat "(compile-file \""
file-name
"\"\)\n"))
(switch-to-lisp t))
;;; Documentation functions: function doc, var doc, arglist, and
;;; describe symbol.
;;; ===========================================================================
;;; Command strings
;;; ===============
(defvar lisp-function-doc-command
"(let ((fn '%s))
(format t \"Documentation for ~a:~&~a\"
fn (documentation fn 'function))
(values))\n"
"Command to query inferior Lisp for a function's documentation.")
(defvar lisp-var-doc-command
"(let ((v '%s))
(format t \"Documentation for ~a:~&~a\"
v (documentation v 'variable))
(values))\n"
"Command to query inferior Lisp for a variable's documentation.")
(defvar lisp-arglist-command
"(let ((fn '%s))
(format t \"Arglist for ~a: ~a\" fn (arglist fn))
(values))\n"
"Command to query inferior Lisp for a function's arglist.")
(defvar lisp-describe-sym-command
"(describe '%s)\n"
"Command to query inferior Lisp for a variable's documentation.")
;;; Ancillary functions
;;; ===================
;;; Reads a string from the user.
(defun lisp-symprompt (prompt default)
(list (let* ((prompt (if default
(format "%s (default %s): " prompt default)
(concat prompt ": ")))
(ans (read-string prompt)))
(if (zerop (length ans)) default ans))))
;;; Adapted from function-called-at-point in help.el.
(defun lisp-fn-called-at-pt ()
"Returns the name of the function called in the current call.
Nil if it can't find one."
(condition-case nil
(save-excursion
(save-restriction
(narrow-to-region (max (point-min) (- (point) 1000)) (point-max))
(backward-up-list 1)
(forward-char 1)
(let ((obj (read (current-buffer))))
(and (symbolp obj) obj))))
(error nil)))
;;; Adapted from variable-at-point in help.el.
(defun lisp-var-at-pt ()
(condition-case ()
(save-excursion
(forward-sexp -1)
(skip-chars-forward "'")
(let ((obj (read (current-buffer))))
(and (symbolp obj) obj)))
(error nil)))
;;; Documentation functions: fn and var doc, arglist, and symbol describe.
;;; ======================================================================
(defun lisp-show-function-documentation (fn)
"Send a command to the inferior Lisp to give documentation for function FN.
See variable lisp-function-doc-command."
(interactive (lisp-symprompt "Function doc" (lisp-fn-called-at-pt)))
(comint-proc-query (cmulisp-proc) (format lisp-function-doc-command fn)))
(defun lisp-show-variable-documentation (var)
"Send a command to the inferior Lisp to give documentation for function FN.
See variable lisp-var-doc-command."
(interactive (lisp-symprompt "Variable doc" (lisp-var-at-pt)))
(comint-proc-query (cmulisp-proc) (format lisp-var-doc-command var)))
(defun lisp-show-arglist (fn)
"Sends an query to the inferior Lisp for the arglist for function FN.
See variable lisp-arglist-command."
(interactive (lisp-symprompt "Arglist" (lisp-fn-called-at-pt)))
(comint-proc-query (cmulisp-proc) (format lisp-arglist-command fn)))
(defun lisp-describe-sym (sym)
"Send a command to the inferior Lisp to describe symbol SYM.
See variable lisp-describe-sym-command."
(interactive (lisp-symprompt "Describe" (lisp-var-at-pt)))
(comint-proc-query (cmulisp-proc) (format lisp-describe-sym-command sym)))
(defvar cmulisp-buffer nil "*The current cmulisp process buffer.
MULTIPLE PROCESS SUPPORT
===========================================================================
Cmulisp.el supports, in a fairly simple fashion, running multiple Lisp
processes. To run multiple Lisp processes, you start the first up with
\\[cmulisp]. It will be in a buffer named *cmulisp*. Rename this buffer
with \\[rename-buffer]. You may now start up a new process with another
\\[cmulisp]. It will be in a new buffer, named *cmulisp*. You can
switch between the different process buffers with \\[switch-to-buffer].
Commands that send text from source buffers to Lisp processes --
like lisp-eval-defun or lisp-show-arglist -- have to choose a process
to send to, when you have more than one Lisp process around. This
is determined by the global variable cmulisp-buffer. Suppose you
have three inferior lisps running:
Buffer Process
foo cmulisp
bar cmulisp<2>
*cmulisp* cmulisp<3>
If you do a \\[lisp-eval-defun] command on some Lisp source code,
what process do you send it to?
- If you're in a process buffer (foo, bar, or *cmulisp*),
you send it to that process.
- If you're in some other buffer (e.g., a source file), you
send it to the process attached to buffer cmulisp-buffer.
This process selection is performed by function cmulisp-proc.
Whenever \\[cmulisp] fires up a new process, it resets cmulisp-buffer
to be the new process's buffer. If you only run one process, this will
do the right thing. If you run multiple processes, you can change
cmulisp-buffer to another process buffer with \\[set-variable].
More sophisticated approaches are, of course, possible. If you find youself
needing to switch back and forth between multiple processes frequently,
you may wish to consider ilisp.el, a larger, more sophisticated package
for running inferior Lisp processes. The approach taken here is for a
minimal, simple implementation. Feel free to extend it.")
(defun cmulisp-proc ()
"Returns the current cmulisp process. See variable cmulisp-buffer."
(let ((proc (get-buffer-process (if (eq major-mode 'inferior-lisp-mode)
(current-buffer)
cmulisp-buffer))))
(or proc
(error "No current process. See variable cmulisp-buffer"))))
;;; Do the user's customisation...
;;;===============================
(defvar cmulisp-load-hook nil
"This hook is run when cmulisp is loaded in.
This is a good place to put keybindings.")
(run-hooks 'cmulisp-load-hook)
;;; CHANGE LOG
;;; ===========================================================================
;;; 5/24/90 Olin
;;; - Split cmulisp and cmushell modes into separate files.
;;; Not only is this a good idea, it's apparently the way it'll be rel 19.
;;; - Upgraded process sends to use comint-send-string instead of
;;; process-send-string.
;;; - Explicit references to process "cmulisp" have been replaced with
;;; (cmulisp-proc). This allows better handling of multiple process bufs.
;;; - Added process query and var/function/symbol documentation
;;; commands. Based on code written by Douglas Roberts.
;;; - Added lisp-eval-last-sexp, bound to C-x C-e.
;;;
;;; 9/20/90 Olin
;;; Added a save-restriction to lisp-fn-called-at-pt. This bug and fix
;;; reported by Lennart Staflin.
;;;
;;; 3/12/90 Olin
;;; - lisp-load-file and lisp-compile-file no longer switch-to-lisp.
;;; Tale suggested this.
;;; - Reversed this decision 7/15/91. You need the visual feedback.
;;;
;;; 7/25/91 Olin
;;; Changed all keybindings of the form C-c <letter>. These are
;;; supposed to be reserved for the user to bind. This affected
;;; mainly the compile/eval-defun/region[-and-go] commands.
;;; This was painful, but necessary to adhere to the gnumacs standard.
;;; For some backwards compatibility, see the
;;; cmulisp-install-letter-bindings
;;; function.
;;;
;;; 8/2/91 Olin
;;; - The lisp-compile/eval-defun/region commands now take a prefix arg,
;;; which means switch-to-lisp after sending the text to the Lisp process.
;;; This obsoletes all the -and-go commands. The -and-go commands are
;;; kept around for historical reasons, and because the user can bind
;;; them to key sequences shorter than C-u C-c C-<letter>.
;;; - If M-x cmulisp is invoked with a prefix arg, it allows you to
;;; edit the command line.
;;;
;;; 11/91 Olin
;;; Added a (kill-all-local-variables) to cmulisp-mode, because comint-mode
;;; doesn't do it anymore.
;;;
;;; 12/91 Olin
;;; Changed a bogus recursion in cmulisp-args-to-list from
;;; tea-args-to-list to cmulisp-args-to-lisp. The perils of cut-and-paste
;;; programming. Bug reported by Miles Bader, who also suggested replacing
;;; the whole bogus parser with /bin/sh -c.
(provide 'cmulisp)

433
emacs/cmuscheme.el Normal file
View File

@ -0,0 +1,433 @@
;;; cmuscheme.el -- Scheme process in a buffer. Adapted from tea.el.
;;; Copyright Olin Shivers (1988)
;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
;;; notice appearing here to the effect that you may use this code any
;;; way you like, as long as you don't charge money for it, remove this
;;; notice, or hold me liable for its results.
;;;
;;; This is a customisation of comint-mode (see comint.el)
;;;
;;; Written by Olin Shivers (olin.shivers@cs.cmu.edu). With bits and pieces
;;; lifted from scheme.el, shell.el, clisp.el, newclisp.el, cobol.el, et al..
;;; 8/88
;;;
;;; Please send me bug reports, bug fixes, and extensions, so that I can
;;; merge them into the master source.
;;;
;;; The changelog is at the end of this file.
;;;
;;; NOTE: MIT Cscheme, when invoked with the -emacs flag, has a special user
;;; interface that communicates process state back to the superior emacs by
;;; outputting special control sequences. The gnumacs package, xscheme.el, has
;;; lots and lots of special purpose code to read these control sequences, and
;;; so is very tightly integrated with the cscheme process. The cscheme
;;; interrupt handler and debugger read single character commands in cbreak
;;; mode; when this happens, xscheme.el switches to special keymaps that bind
;;; the single letter command keys to emacs functions that directly send the
;;; character to the scheme process. Cmuscheme mode does *not* provide this
;;; functionality. If you are a cscheme user, you may prefer to use the
;;; xscheme.el/cscheme -emacs interaction.
;;;
;;; Here's a summary of the pros and cons, as I see them.
;;; xscheme: Tightly integrated with inferior cscheme process! A few commands
;;; not in cmuscheme. But. Integration is a bit of a hack. Input
;;; history only keeps the immediately prior input. Bizarre
;;; keybindings.
;;;
;;; cmuscheme: Not tightly integrated with inferior cscheme process. But.
;;; Carefully integrated functionality with the entire suite of
;;; comint-derived CMU process modes. Keybindings reminiscent of
;;; Zwei and Hemlock. Good input history. A few commands not in
;;; xscheme.
;;;
;;; It's a tradeoff. Pay your money; take your choice. If you use a Scheme
;;; that isn't Cscheme, of course, there isn't a choice. Xscheme.el is *very*
;;; Cscheme-specific; you must use cmuscheme.el. Interested parties are
;;; invited to port xscheme functionality on top of comint mode...
;; YOUR .EMACS FILE
;;=============================================================================
;; Some suggestions for your .emacs file.
;;
;; ; If cmuscheme lives in some non-standard directory, you must tell emacs
;; ; where to get it. This may or may not be necessary.
;; (setq load-path (cons (expand-file-name "~jones/lib/emacs") load-path))
;;
;; ; Autoload run-scheme from file cmuscheme.el
;; (autoload 'run-scheme "cmuscheme"
;; "Run an inferior Scheme process."
;; t)
;;
;; ; Files ending in ".scm" are Scheme source,
;; ; so put their buffers in scheme-mode.
;; (setq auto-mode-alist
;; (cons '("\\.scm$" . scheme-mode)
;; auto-mode-alist))
;;
;; ; Define C-c C-t to run my favorite command in inferior scheme mode:
;; (setq cmuscheme-load-hook
;; '((lambda () (define-key inferior-scheme-mode-map "\C-c\C-t"
;; 'favorite-cmd))))
;;;
;;; Unfortunately, scheme.el defines run-scheme to autoload from xscheme.el.
;;; This will womp your declaration to autoload run-scheme from cmuscheme.el
;;; if you haven't loaded cmuscheme in before scheme. Three fixes:
;;; - Put the autoload on your scheme mode hook and in your .emacs toplevel:
;;; (setq scheme-mode-hook
;;; '((lambda () (autoload 'run-scheme "cmuscheme"
;;; "Run an inferior Scheme" t))))
;;; (autoload 'run-scheme "cmuscheme" "Run an inferior Scheme" t)
;;; Now when scheme.el autoloads, it will restore the run-scheme autoload.
;;; - Load cmuscheme.el in your .emacs: (load-library 'cmuscheme)
;;; - Change autoload declaration in scheme.el to point to cmuscheme.el:
;;; (autoload 'run-scheme "cmuscheme" "Run an inferior Scheme" t)
;;; *or* just delete the autoload declaration from scheme.el altogether,
;;; which will allow the autoload in your .emacs to have its say.
(provide 'cmuscheme)
(require 'scheme)
(require 'comint)
;;; INFERIOR SCHEME MODE STUFF
;;;============================================================================
(defvar inferior-scheme-mode-hook nil
"*Hook for customising inferior-scheme mode.")
(defvar inferior-scheme-mode-map nil)
(cond ((not inferior-scheme-mode-map)
(setq inferior-scheme-mode-map
(copy-keymap comint-mode-map))
(define-key inferior-scheme-mode-map "\M-\C-x" ;gnu convention
'scheme-send-definition)
(define-key inferior-scheme-mode-map "\C-x\C-e" 'scheme-send-last-sexp)
(define-key inferior-scheme-mode-map "\C-cl" 'scheme-load-file)
(define-key inferior-scheme-mode-map "\C-ck" 'scheme-compile-file)
(scheme-mode-commands inferior-scheme-mode-map)))
;; Install the process communication commands in the scheme-mode keymap.
(define-key scheme-mode-map "\M-\C-x" 'scheme-send-definition);gnu convention
(define-key scheme-mode-map "\C-x\C-e" 'scheme-send-last-sexp);gnu convention
(define-key scheme-mode-map "\C-ce" 'scheme-send-definition)
(define-key scheme-mode-map "\C-c\C-e" 'scheme-send-definition-and-go)
(define-key scheme-mode-map "\C-cr" 'scheme-send-region)
(define-key scheme-mode-map "\C-c\C-r" 'scheme-send-region-and-go)
(define-key scheme-mode-map "\C-cc" 'scheme-compile-definition)
(define-key scheme-mode-map "\C-c\C-c" 'scheme-compile-definition-and-go)
(define-key scheme-mode-map "\C-cz" 'switch-to-scheme)
(define-key scheme-mode-map "\C-cl" 'scheme-load-file)
(define-key scheme-mode-map "\C-ck" 'scheme-compile-file) ;k for "kompile"
(defun inferior-scheme-mode ()
"Major mode for interacting with an inferior Scheme process.
The following commands are available:
\\{inferior-scheme-mode-map}
A Scheme process can be fired up with M-x run-scheme.
Customisation: Entry to this mode runs the hooks on comint-mode-hook and
inferior-scheme-mode-hook (in that order).
You can send text to the inferior Scheme process from other buffers containing
Scheme source.
switch-to-scheme switches the current buffer to the Scheme process buffer.
scheme-send-definition sends the current definition to the Scheme process.
scheme-compile-definition compiles the current definition.
scheme-send-region sends the current region to the Scheme process.
scheme-compile-region compiles the current region.
scheme-send-definition-and-go, scheme-compile-definition-and-go,
scheme-send-region-and-go, and scheme-compile-region-and-go
switch to the Scheme process buffer after sending their text.
For information on running multiple processes in multiple buffers, see
documentation for variable scheme-buffer.
Commands:
Return after the end of the process' output sends the text from the
end of process to point.
Return before the end of the process' output copies the sexp ending at point
to the end of the process' output, and sends it.
Delete converts tabs to spaces as it moves back.
Tab indents for Scheme; with argument, shifts rest
of expression rigidly with the current line.
C-M-q does Tab on each line starting within following expression.
Paragraphs are separated only by blank lines. Semicolons start comments.
If you accidentally suspend your process, use \\[comint-continue-subjob]
to continue it."
(interactive)
(comint-mode)
;; Customise in inferior-scheme-mode-hook
(setq comint-prompt-regexp "^[^>]*>+ *") ; OK for cscheme, oaklisp, T,...
(scheme-mode-variables)
(setq major-mode 'inferior-scheme-mode)
(setq mode-name "Inferior Scheme")
(setq mode-line-process '(": %s"))
(use-local-map inferior-scheme-mode-map)
(setq comint-input-filter (function scheme-input-filter))
(setq comint-input-sentinel (function ignore))
(setq comint-get-old-input (function scheme-get-old-input))
(run-hooks 'inferior-scheme-mode-hook))
(defun scheme-input-filter (str)
"Don't save anything matching inferior-scheme-filter-regexp"
(not (string-match inferior-scheme-filter-regexp str)))
(defvar inferior-scheme-filter-regexp "\\`\\s *\\S ?\\S ?\\s *\\'"
"*Input matching this regexp are not saved on the history list.
Defaults to a regexp ignoring all inputs of 0, 1, or 2 letters.")
(defun scheme-get-old-input ()
"Snarf the sexp ending at point"
(save-excursion
(let ((end (point)))
(backward-sexp)
(buffer-substring (point) end))))
(defun scheme-args-to-list (string)
(let ((where (string-match "[ \t]" string)))
(cond ((null where) (list string))
((not (= where 0))
(cons (substring string 0 where)
(scheme-args-to-list (substring string (+ 1 where)
(length string)))))
(t (let ((pos (string-match "[^ \t]" string)))
(if (null pos)
nil
(scheme-args-to-list (substring string pos
(length string)))))))))
(defvar scheme-program-name "scheme"
"*Program invoked by the run-scheme command")
;;; Obsolete
(defun scheme (&rest foo)
"Use run-scheme"
(interactive)
(message "Use run-scheme")
(ding))
(defun run-scheme (cmd)
"Run an inferior Scheme process, input and output via buffer *scheme*.
If there is a process already running in *scheme*, just switch to that buffer.
With argument, allows you to edit the command line (default is value
of scheme-program-name). Runs the hooks from inferior-scheme-mode-hook
\(after the comint-mode-hook is run).
\(Type \\[describe-mode] in the process buffer for a list of commands.)"
(interactive (list (if current-prefix-arg
(read-string "Run Scheme: " scheme-program-name)
scheme-program-name)))
(if (not (comint-check-proc "*scheme*"))
(let ((cmdlist (scheme-args-to-list cmd)))
(set-buffer (apply 'make-comint "scheme" (car cmdlist)
nil (cdr cmdlist)))
(inferior-scheme-mode)))
(setq scheme-buffer "*scheme*")
(switch-to-buffer "*scheme*"))
(defun scheme-send-region (start end)
"Send the current region to the inferior Scheme process."
(interactive "r")
(comint-send-region (scheme-proc) start end)
(comint-send-string (scheme-proc) "\n"))
(defun scheme-send-definition ()
"Send the current definition to the inferior Scheme process."
(interactive)
(save-excursion
(end-of-defun)
(let ((end (point)))
(beginning-of-defun)
(scheme-send-region (point) end))))
(defun scheme-send-last-sexp ()
"Send the previous sexp to the inferior Scheme process."
(interactive)
(scheme-send-region (save-excursion (backward-sexp) (point)) (point)))
(defvar scheme-compile-exp-command "(compile '%s)"
"*Template for issuing commands to compile arbitrary Scheme expressions.")
(defun scheme-compile-region (start end)
"Compile the current region in the inferior Scheme process
\(A BEGIN is wrapped around the region: (BEGIN <region>))"
(interactive "r")
(comint-send-string (scheme-proc) (format scheme-compile-exp-command
(format "(begin %s)"
(buffer-substring start end))))
(comint-send-string (scheme-proc) "\n"))
(defun scheme-compile-definition ()
"Compile the current definition in the inferior Scheme process."
(interactive)
(save-excursion
(end-of-defun)
(let ((end (point)))
(beginning-of-defun)
(scheme-compile-region (point) end))))
(defun switch-to-scheme (eob-p)
"Switch to the scheme process buffer.
With argument, positions cursor at end of buffer."
(interactive "P")
(if (get-buffer scheme-buffer)
(pop-to-buffer scheme-buffer)
(error "No current process buffer. See variable scheme-buffer."))
(cond (eob-p
(push-mark)
(goto-char (point-max)))))
(defun scheme-send-region-and-go (start end)
"Send the current region to the inferior Scheme process,
and switch to the process buffer."
(interactive "r")
(scheme-send-region start end)
(switch-to-scheme t))
(defun scheme-send-definition-and-go ()
"Send the current definition to the inferior Scheme,
and switch to the process buffer."
(interactive)
(scheme-send-definition)
(switch-to-scheme t))
(defun scheme-compile-definition-and-go ()
"Compile the current definition in the inferior Scheme,
and switch to the process buffer."
(interactive)
(scheme-compile-definition)
(switch-to-scheme t))
(defun scheme-compile-region-and-go (start end)
"Compile the current region in the inferior Scheme,
and switch to the process buffer."
(interactive "r")
(scheme-compile-region start end)
(switch-to-scheme t))
(defvar scheme-source-modes '(scheme-mode)
"*Used to determine if a buffer contains Scheme source code.
If it's loaded into a buffer that is in one of these major modes, it's
considered a scheme source file by scheme-load-file and scheme-compile-file.
Used by these commands to determine defaults.")
(defvar scheme-prev-l/c-dir/file nil
"Caches the (directory . file) pair used in the last scheme-load-file or
scheme-compile-file command. Used for determining the default in the
next one.")
(defun scheme-load-file (file-name)
"Load a Scheme file into the inferior Scheme process."
(interactive (comint-get-source "Load Scheme file: " scheme-prev-l/c-dir/file
scheme-source-modes t)) ; T because LOAD
; needs an exact name
(comint-check-source file-name) ; Check to see if buffer needs saved.
(setq scheme-prev-l/c-dir/file (cons (file-name-directory file-name)
(file-name-nondirectory file-name)))
(comint-send-string (scheme-proc) (concat "(load \""
file-name
"\"\)\n")))
(defun scheme-compile-file (file-name)
"Compile a Scheme file in the inferior Scheme process."
(interactive (comint-get-source "Compile Scheme file: "
scheme-prev-l/c-dir/file
scheme-source-modes
nil)) ; NIL because COMPILE doesn't
; need an exact name.
(comint-check-source file-name) ; Check to see if buffer needs saved.
(setq scheme-prev-l/c-dir/file (cons (file-name-directory file-name)
(file-name-nondirectory file-name)))
(comint-send-string (scheme-proc) (concat "(compile-file \""
file-name
"\"\)\n")))
(defvar scheme-buffer nil "*The current scheme process buffer.
MULTIPLE PROCESS SUPPORT
===========================================================================
Cmuscheme.el supports, in a fairly simple fashion, running multiple Scheme
processes. To run multiple Scheme processes, you start the first up with
\\[run-scheme]. It will be in a buffer named *scheme*. Rename this buffer
with \\[rename-buffer]. You may now start up a new process with another
\\[run-scheme]. It will be in a new buffer, named *scheme*. You can
switch between the different process buffers with \\[switch-to-buffer].
Commands that send text from source buffers to Scheme processes --
like scheme-send-definition or scheme-compile-region -- have to choose a
process to send to, when you have more than one Scheme process around. This
is determined by the global variable scheme-buffer. Suppose you
have three inferior Schemes running:
Buffer Process
foo scheme
bar scheme<2>
*scheme* scheme<3>
If you do a \\[scheme-send-definition-and-go] command on some Scheme source
code, what process do you send it to?
- If you're in a process buffer (foo, bar, or *scheme*),
you send it to that process.
- If you're in some other buffer (e.g., a source file), you
send it to the process attached to buffer scheme-buffer.
This process selection is performed by function scheme-proc.
Whenever \\[run-scheme] fires up a new process, it resets scheme-buffer
to be the new process's buffer. If you only run one process, this will
do the right thing. If you run multiple processes, you can change
scheme-buffer to another process buffer with \\[set-variable].
More sophisticated approaches are, of course, possible. If you find youself
needing to switch back and forth between multiple processes frequently,
you may wish to consider ilisp.el, a larger, more sophisticated package
for running inferior Lisp and Scheme processes. The approach taken here is
for a minimal, simple implementation. Feel free to extend it.")
(defun scheme-proc ()
"Returns the current scheme process. See variable scheme-buffer."
(let ((proc (get-buffer-process (if (eq major-mode 'inferior-scheme-mode)
(current-buffer)
scheme-buffer))))
(or proc
(error "No current process. See variable scheme-buffer"))))
;;; Do the user's customisation...
(defvar cmuscheme-load-hook nil
"This hook is run when cmuscheme is loaded in.
This is a good place to put keybindings.")
(run-hooks 'cmuscheme-load-hook)
;;; CHANGE LOG
;;; ===========================================================================
;;; 8/88 Olin
;;; Created.
;;;
;;; 2/15/89 Olin
;;; Removed -emacs flag from process invocation. It's only useful for
;;; cscheme, and makes cscheme assume it's running under xscheme.el,
;;; which messes things up royally. A bug.
;;;
;;; 5/22/90 Olin
;;; - Upgraded to use comint-send-string and comint-send-region.
;;; - run-scheme now offers to let you edit the command line if
;;; you invoke it with a prefix-arg. M-x scheme is redundant, and
;;; has been removed.
;;; - Explicit references to process "scheme" have been replaced with
;;; (scheme-proc). This allows better handling of multiple process bufs.
;;; - Added scheme-send-last-sexp, bound to C-x C-e. A gnu convention.
;;; - Have not added process query facility a la cmulisp.el's lisp-show-arglist
;;; and friends, but interested hackers might find a useful application
;;; of this facility.
;;;
;;; 3/12/90 Olin
;;; - scheme-load-file and scheme-compile-file no longer switch-to-scheme.
;;; Tale suggested this.
;;;
;;; 2/21/94 JAR
;;; - full-copy-sparse-keymap -> copy-keymap (thanks to Michael Sperber)

99
emacs/cmuscheme48.el Normal file
View File

@ -0,0 +1,99 @@
;;; cmuscheme48.el -- Scheme process in a buffer. Adapted from cmuscheme.el.
(provide 'cmuscheme48)
(require 'cmuscheme)
(define-key scheme-mode-map "\M-\C-x" 'scheme48-send-definition);gnu convention
(define-key scheme-mode-map "\C-x\C-e" 'scheme48-send-last-sexp);gnu convention
(define-key scheme-mode-map "\C-ce" 'scheme48-send-definition)
(define-key scheme-mode-map "\C-c\C-e" 'scheme48-send-definition-and-go)
(define-key scheme-mode-map "\C-cr" 'scheme48-send-region)
(define-key scheme-mode-map "\C-c\C-r" 'scheme48-send-region-and-go)
(define-key scheme-mode-map "\C-cl" 'scheme48-load-file)
(defun scheme48-send-region (start end)
"Send the current region to the inferior Scheme process."
(interactive "r")
(comint-send-string (scheme-proc)
(concat ",from-file "
(enough-scheme-file-name
(buffer-file-name (current-buffer)))
"\n"))
(comint-send-region (scheme-proc) start end)
(comint-send-string (scheme-proc) " ,end\n"))
; This assumes that when you load things into Scheme 48, you type
; names of files in your home directory using the syntax "~/".
; Similarly for current directory. Maybe we ought to send multiple
; file names to Scheme and let it look at all of them.
(defun enough-scheme-file-name (file)
(let* ((scheme-dir
(save-excursion
(set-buffer scheme-buffer)
(expand-file-name default-directory)))
(len (length scheme-dir)))
(if (and (> (length file) len)
(string-equal scheme-dir (substring file 0 len)))
(substring file len)
(if *scheme48-home-directory-kludge*
(let* ((home-dir (expand-file-name "~/"))
(len (length home-dir)))
(if (and (> (length file) len)
(string-equal home-dir (substring file 0 len)))
(concat "~/" (substring file len))
file))
file))))
(defvar *scheme48-home-directory-kludge* t)
(defun scheme48-send-definition (losep)
"Send the current definition to the inferior Scheme48 process."
(interactive "P")
(save-excursion
(end-of-defun)
(let ((end (point)))
(beginning-of-defun)
(if losep
(let ((loser "/tmp/s48lose.tmp"))
(write-region (point) end loser)
(scheme48-load-file loser))
(scheme48-send-region (point) end)))))
(defun scheme48-send-last-sexp ()
"Send the previous sexp to the inferior Scheme process."
(interactive)
(scheme48-send-region (save-excursion (backward-sexp) (point)) (point)))
(defun scheme48-send-region-and-go (start end)
"Send the current region to the inferior Scheme48 process,
and switch to the process buffer."
(interactive "r")
(scheme48-send-region start end)
(switch-to-scheme t))
(defun scheme48-send-definition-and-go (losep)
"Send the current definition to the inferior Scheme48,
and switch to the process buffer."
(interactive "P")
(scheme48-send-definition losep)
(switch-to-scheme t))
(defun scheme48-load-file (file-name)
"Load a Scheme file into the inferior Scheme48 process."
(interactive (comint-get-source "Load Scheme48 file: "
scheme-prev-l/c-dir/file
scheme-source-modes t)) ; T because LOAD
; needs an exact name
(comint-check-source file-name) ; Check to see if buffer needs saved.
(setq scheme-prev-l/c-dir/file (cons (file-name-directory file-name)
(file-name-nondirectory file-name)))
(comint-send-string (scheme-proc)
(concat ",load "
(enough-scheme-file-name file-name)
"\n")))
; For Pertti Kellom\"aki's debugger.
; Cf. misc/psd-s48.scm.
(defvar psd-using-slib nil "Scheme 48, not SLIB.")

594
emacs/cmushell.el Normal file
View File

@ -0,0 +1,594 @@
;;; -*-Emacs-Lisp-*- General command interpreter in a window stuff
;;; Copyright Olin Shivers (1988).
;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
;;; notice appearing here to the effect that you may use this code any
;;; way you like, as long as you don't charge money for it, remove this
;;; notice, or hold me liable for its results.
;;; The changelog is at the end of file.
;;; Please send me bug reports, bug fixes, and extensions, so that I can
;;; merge them into the master source.
;;; - Olin Shivers (shivers@cs.cmu.edu)
;;; This file defines a a shell-in-a-buffer package (cmushell mode) built on
;;; top of comint mode. Cmushell mode is similar to, and intended to replace,
;;; its counterpart in the standard gnu emacs release. This replacement is
;;; more featureful, robust, and uniform than the released version.
;;; Since this mode is built on top of the general command-interpreter-in-
;;; a-buffer mode (comint mode), it shares a common base functionality,
;;; and a common set of bindings, with all modes derived from comint mode.
;;; This makes these modes easier to use.
;;; For documentation on the functionality provided by comint mode, and
;;; the hooks available for customising it, see the file comint.el.
;;; For further information on cmushell mode, see the comments below.
;;; Needs fixin:
;;; When sending text from a source file to a subprocess, the process-mark can
;;; move off the window, so you can lose sight of the process interactions.
;;; Maybe I should ensure the process mark is in the window when I send
;;; text to the process? Switch selectable?
(require 'comint)
(provide 'cmushell)
;; YOUR .EMACS FILE
;;=============================================================================
;; Some suggestions for your .emacs file.
;;
;; ; If cmushell lives in some non-standard directory, you must tell emacs
;; ; where to get it. This may or may not be necessary.
;; (setq load-path (cons (expand-file-name "~jones/lib/emacs") load-path))
;;
;; ; Autoload cmushell from file cmushell.el
;; (autoload 'cmushell "cmushell"
;; "Run an inferior shell process."
;; t)
;;
;; ; Define C-c C-t to run my favorite command in cmushell mode:
;; (setq cmushell-load-hook
;; '((lambda ()
;; (define-key cmushell-mode-map "\C-c\C-t" 'favorite-cmd))))
;;; Brief Command Documentation:
;;;============================================================================
;;; Comint Mode Commands: (common to cmushell and all comint-derived modes)
;;;
;;; m-p comint-previous-input Cycle backwards in input history
;;; m-n comint-next-input Cycle forwards
;;; c-c r comint-previous-input-matching Search backwards in input history
;;; return comint-send-input
;;; c-a comint-bol Beginning of line; skip prompt.
;;; c-d comint-delchar-or-maybe-eof Delete char unless at end of buff.
;;; c-c c-u comint-kill-input ^u
;;; c-c c-w backward-kill-word ^w
;;; c-c c-c comint-interrupt-subjob ^c
;;; c-c c-z comint-stop-subjob ^z
;;; c-c c-\ comint-quit-subjob ^\
;;; c-c c-o comint-kill-output Delete last batch of process output
;;; c-c c-r comint-show-output Show last batch of process output
;;; send-invisible Read line w/o echo & send to proc
;;; comint-continue-subjob Useful if you accidentally suspend
;;; top-level job.
;;; comint-mode-hook is the comint mode hook.
;;; Shell Mode Commands:
;;; cmushell Fires up the shell process.
;;; tab comint-dynamic-complete Complete a partial file name
;;; m-? comint-dynamic-list-completions List completions in help buffer
;;; dirs Resync the buffer's dir stack.
;;; dirtrack-toggle Turn dir tracking on/off.
;;;
;;; The cmushell mode hook is cmushell-mode-hook
;;; The cmushell-load-hook is run after this file is loaded.
;;; comint-prompt-regexp is initialised to shell-prompt-pattern, for backwards
;;; compatibility.
;;; Read the rest of this file for more information.
;;; SHELL.EL COMPATIBILITY
;;;============================================================================
;;; In brief: this package should have no trouble coexisting with shell.el.
;;;
;;; Most customising variables -- e.g., explicit-shell-file-name -- are the
;;; same, so the users shouldn't have much trouble. Hooks have different
;;; names, however, so you can customise shell mode differently from cmushell
;;; mode. You basically just have to remember to type M-x cmushell instead of
;;; M-x shell.
;;;
;;; It would be nice if this file was completely plug-compatible with the old
;;; shell package -- if you could just name this file shell.el, and have it
;;; transparently replace the old one. But you can't. Several other packages
;;; (tex-mode, background, dbx, gdb, kermit, monkey, prolog, telnet) are also
;;; clients of shell mode. These packages assume detailed knowledge of shell
;;; mode internals in ways that are incompatible with cmushell mode (mostly
;;; because of cmushell mode's greater functionality). So, unless we are
;;; willing to port all of these packages, we can't have this file be a
;;; complete replacement for shell.el -- that is, we can't name this file
;;; shell.el, and its main entry point (shell), because dbx.el will break
;;; when it loads it in and tries to use it.
;;;
;;; There are two ways to fix this. One: rewrite these other modes to use the
;;; new package. This is a win, but can't be assumed. The other, backwards
;;; compatible route, is to make this package non-conflict with shell.el, so
;;; both files can be loaded in at the same time. And *that* is why some
;;; functions and variables have different names: (cmushell),
;;; cmushell-mode-map, that sort of thing. All the names have been carefully
;;; chosen so that shell.el and cmushell.el won't tromp on each other.
;;; Customisation and Buffer Variables
;;; ===========================================================================
;;;
;In loaddefs.el now.
;(defconst shell-prompt-pattern
; "^[^#$%>]*[#$%>] *"
; "*Regexp used by Newline command to match subshell prompts.
;;; Change the doc string for shell-prompt-pattern:
(put 'shell-prompt-pattern 'variable-documentation
"Regexp to match prompts in the inferior shell.
Defaults to \"^[^#$%>]*[#$%>] *\", which works pretty well.
This variable is used to initialise comint-prompt-regexp in the
shell buffer.
This is a fine thing to set in your .emacs file.")
(defvar shell-popd-regexp "popd"
"*Regexp to match subshell commands equivalent to popd.")
(defvar shell-pushd-regexp "pushd"
"*Regexp to match subshell commands equivalent to pushd.")
(defvar shell-cd-regexp "cd"
"*Regexp to match subshell commands equivalent to cd.")
(defvar explicit-shell-file-name nil
"*If non-nil, is file name to use for explicitly requested inferior shell.")
(defvar explicit-csh-args
(if (eq system-type 'hpux)
;; -T persuades HP's csh not to think it is smarter
;; than us about what terminal modes to use.
'("-i" "-T")
'("-i"))
"*Args passed to inferior shell by M-x cmushell, if the shell is csh.
Value is a list of strings, which may be nil.")
;;; All the above vars aren't prefixed "cmushell-" to make them
;;; backwards compatible w/shell.el and old .emacs files.
(defvar cmushell-dirstack nil
"List of directories saved by pushd in this buffer's shell.")
(defvar cmushell-dirstack-query "dirs"
"Command used by shell-resync-dirlist to query shell.")
(defvar cmushell-mode-map '())
(cond ((not cmushell-mode-map)
(setq cmushell-mode-map (full-copy-sparse-keymap comint-mode-map))
(define-key cmushell-mode-map "\t" 'comint-dynamic-complete)
(define-key cmushell-mode-map "\M-?" 'comint-dynamic-list-completions)))
(defvar cmushell-mode-hook '()
"*Hook for customising cmushell mode")
;;; Basic Procedures
;;; ===========================================================================
;;;
(defun cmushell-mode ()
"Major mode for interacting with an inferior shell.
Return after the end of the process' output sends the text from the
end of process to the end of the current line.
Return before end of process output copies rest of line to end (skipping
the prompt) and sends it.
M-x send-invisible reads a line of text without echoing it, and sends it to
the shell.
If you accidentally suspend your process, use \\[comint-continue-subjob]
to continue it.
cd, pushd and popd commands given to the shell are watched by Emacs to keep
this buffer's default directory the same as the shell's working directory.
M-x dirs queries the shell and resyncs Emacs' idea of what the current
directory stack is.
M-x dirtrack-toggle turns directory tracking on and off.
\\{cmushell-mode-map}
Customisation: Entry to this mode runs the hooks on comint-mode-hook and
cmushell-mode-hook (in that order).
Variables shell-cd-regexp, shell-pushd-regexp and shell-popd-regexp are used
to match their respective commands."
(interactive)
(comint-mode)
(setq comint-prompt-regexp shell-prompt-pattern)
(setq major-mode 'cmushell-mode)
(setq mode-name "CMU shell")
(use-local-map cmushell-mode-map)
(make-local-variable 'cmushell-dirstack)
(setq cmushell-dirstack nil)
(make-local-variable 'cmushell-dirtrackp)
(setq cmushell-dirtrackp t)
(setq comint-input-sentinel 'cmushell-directory-tracker)
(run-hooks 'cmushell-mode-hook))
(defun cmushell ()
"Run an inferior shell, with I/O through buffer *cmushell*.
If buffer exists but shell process is not running, make new shell.
If buffer exists and shell process is running,
just switch to buffer *cmushell*.
Program used comes from variable explicit-shell-file-name,
or (if that is nil) from the ESHELL environment variable,
or else from SHELL if there is no ESHELL.
If a file ~/.emacs_SHELLNAME exists, it is given as initial input
(Note that this may lose due to a timing error if the shell
discards input when it starts up.)
The buffer is put in cmushell-mode, giving commands for sending input
and controlling the subjobs of the shell. See cmushell-mode.
See also variable shell-prompt-pattern.
The shell file name (sans directories) is used to make a symbol name
such as `explicit-csh-arguments'. If that symbol is a variable,
its value is used as a list of arguments when invoking the shell.
Otherwise, one argument `-i' is passed to the shell.
\(Type \\[describe-mode] in the shell buffer for a list of commands.)"
(interactive)
(let ((buffer-name (concat "*" cmushell-buffer-base-name "*")))
(cond ((not (comint-check-proc buffer-name))
(let* ((prog (or explicit-shell-file-name
(getenv "ESHELL")
(getenv "SHELL")
"/bin/sh"))
(name (file-name-nondirectory prog))
(startfile (concat "~/.emacs_" name))
(xargs-name (intern-soft (concat "explicit-" name "-args"))))
(set-buffer (apply 'make-comint cmushell-buffer-base-name prog
(if (file-exists-p startfile) startfile)
(if (and xargs-name (boundp xargs-name))
(symbol-value xargs-name)
'("-i"))))
(cmushell-mode))))
(switch-to-buffer buffer-name)))
(defvar cmushell-buffer-base-name "cmushell"
"Name of buffer in which CMU shell is to run.")
;;; Directory tracking
;;; ===========================================================================
;;; This code provides the cmushell mode input sentinel
;;; CMUSHELL-DIRECTORY-TRACKER
;;; that tracks cd, pushd, and popd commands issued to the shell, and
;;; changes the current directory of the shell buffer accordingly.
;;;
;;; This is basically a fragile hack, although it's more accurate than
;;; the released version in shell.el. It has the following failings:
;;; 1. It doesn't know about the cdpath shell variable.
;;; 2. It only spots the first command in a command sequence. E.g., it will
;;; miss the cd in "ls; cd foo"
;;; 3. More generally, any complex command (like ";" sequencing) is going to
;;; throw it. Otherwise, you'd have to build an entire shell interpreter in
;;; emacs lisp. Failing that, there's no way to catch shell commands where
;;; cd's are buried inside conditional expressions, aliases, and so forth.
;;;
;;; The whole approach is a crock. Shell aliases mess it up. File sourcing
;;; messes it up. You run other processes under the shell; these each have
;;; separate working directories, and some have commands for manipulating
;;; their w.d.'s (e.g., the lcd command in ftp). Some of these programs have
;;; commands that do *not* affect the current w.d. at all, but look like they
;;; do (e.g., the cd command in ftp). In shells that allow you job
;;; control, you can switch between jobs, all having different w.d.'s. So
;;; simply saying %3 can shift your w.d..
;;;
;;; The solution is to relax, not stress out about it, and settle for
;;; a hack that works pretty well in typical circumstances. Remember
;;; that a half-assed solution is more in keeping with the spirit of Unix,
;;; anyway. Blech.
;;;
;;; One good hack not implemented here for users of programmable shells
;;; is to program up the shell w.d. manipulation commands to output
;;; a coded command sequence to the tty. Something like
;;; ESC | <cwd> |
;;; where <cwd> is the new current working directory. Then trash the
;;; directory tracking machinery currently used in this package, and
;;; replace it with a process filter that watches for and strips out
;;; these messages.
;;; REGEXP is a regular expression. STR is a string. START is a fixnum.
;;; Returns T if REGEXP matches STR where the match is anchored to start
;;; at position START in STR. Sort of like LOOKING-AT for strings.
(defun cmushell-front-match (regexp str start)
(eq start (string-match regexp str start)))
(defun cmushell-directory-tracker (str)
"Tracks cd, pushd and popd commands issued to the shell.
This function is called on each input passed to the shell.
It watches for cd, pushd and popd commands and sets the buffer's
default directory to track these commands.
You may toggle this tracking on and off with M-x dirtrack-toggle.
If emacs gets confused, you can resync with the shell with M-x dirs.
See variables shell-cd-regexp, shell-pushd-regexp, and shell-popd-regexp.
Environment variables are expanded, see function substitute-in-file-name."
(condition-case err
(cond (cmushell-dirtrackp
(string-match "^\\s *" str) ; skip whitespace
(let ((bos (match-end 0))
(x nil))
(cond ((setq x (cmushell-match-cmd-w/optional-arg shell-popd-regexp
str bos))
(cmushell-process-popd (substitute-in-file-name x)))
((setq x (cmushell-match-cmd-w/optional-arg shell-pushd-regexp
str bos))
(cmushell-process-pushd (substitute-in-file-name x)))
((setq x (cmushell-match-cmd-w/optional-arg shell-cd-regexp
str bos))
(cmushell-process-cd (substitute-in-file-name x)))))))
(error (message (car (cdr err))))))
;;; Try to match regexp CMD to string, anchored at position START.
;;; CMD may be followed by a single argument. If a match, then return
;;; the argument, if there is one, or the empty string if not. If
;;; no match, return nil.
(defun cmushell-match-cmd-w/optional-arg (cmd str start)
(and (cmushell-front-match cmd str start)
(let ((eoc (match-end 0))) ; end of command
(cond ((cmushell-front-match "\\s *\\(\;\\|$\\)" str eoc)
"") ; no arg
((cmushell-front-match "\\s +\\([^ \t\;]+\\)\\s *\\(\;\\|$\\)"
str eoc)
(substring str (match-beginning 1) (match-end 1))) ; arg
(t nil))))) ; something else.
;;; The first regexp is [optional whitespace, (";" or the end of string)].
;;; The second regexp is [whitespace, (an arg), optional whitespace,
;;; (";" or end of string)].
;;; popd [+n]
(defun cmushell-process-popd (arg)
(let ((num (if (zerop (length arg)) 0 ; no arg means +0
(cmushell-extract-num arg))))
(if (and num (< num (length cmushell-dirstack)))
(if (= num 0) ; condition-case because the CD could lose.
(condition-case nil (progn (cd (car cmushell-dirstack))
(setq cmushell-dirstack
(cdr cmushell-dirstack))
(cmushell-dirstack-message))
(error (message "Couldn't cd.")))
(let* ((ds (cons nil cmushell-dirstack))
(cell (nthcdr (- num 1) ds)))
(rplacd cell (cdr (cdr cell)))
(setq cmushell-dirstack (cdr ds))
(cmushell-dirstack-message)))
(message "Bad popd."))))
;;; cd [dir]
(defun cmushell-process-cd (arg)
(condition-case nil (progn (cd (if (zerop (length arg)) (getenv "HOME")
arg))
(cmushell-dirstack-message))
(error (message "Couldn't cd."))))
;;; pushd [+n | dir]
(defun cmushell-process-pushd (arg)
(if (zerop (length arg))
;; no arg -- swap pwd and car of shell stack
(condition-case nil (if cmushell-dirstack
(let ((old default-directory))
(cd (car cmushell-dirstack))
(setq cmushell-dirstack
(cons old (cdr cmushell-dirstack)))
(cmushell-dirstack-message))
(message "Directory stack empty."))
(message "Couldn't cd."))
(let ((num (cmushell-extract-num arg)))
(if num ; pushd +n
(if (> num (length cmushell-dirstack))
(message "Directory stack not that deep.")
(let* ((ds (cons default-directory cmushell-dirstack))
(dslen (length ds))
(front (nthcdr num ds))
(back (reverse (nthcdr (- dslen num) (reverse ds))))
(new-ds (append front back)))
(condition-case nil
(progn (cd (car new-ds))
(setq cmushell-dirstack (cdr new-ds))
(cmushell-dirstack-message))
(error (message "Couldn't cd.")))))
;; pushd <dir>
(let ((old-wd default-directory))
(condition-case nil
(progn (cd arg)
(setq cmushell-dirstack
(cons old-wd cmushell-dirstack))
(cmushell-dirstack-message))
(error (message "Couldn't cd."))))))))
;; If STR is of the form +n, for n>0, return n. Otherwise, nil.
(defun cmushell-extract-num (str)
(and (string-match "^\\+[1-9][0-9]*$" str)
(string-to-int str)))
(defun cmushell-dirtrack-toggle ()
"Turn directory tracking on and off in a cmushell buffer."
(interactive)
(setq cmushell-dirtrackp (not cmushell-dirtrackp))
(message "directory tracking %s."
(if cmushell-dirtrackp "ON" "OFF")))
;;; For your typing convenience:
(fset 'dirtrack-toggle 'cmushell-dirtrack-toggle)
(defun cmushell-resync-dirs ()
"Resync the buffer's idea of the current directory stack.
This command queries the shell with the command bound to
cmushell-dirstack-query (default \"dirs\"), reads the next
line output and parses it to form the new directory stack.
DON'T issue this command unless the buffer is at a shell prompt.
Also, note that if some other subprocess decides to do output
immediately after the query, its output will be taken as the
new directory stack -- you lose. If this happens, just do the
command again."
(interactive)
(let* ((proc (get-buffer-process (current-buffer)))
(pmark (process-mark proc)))
(goto-char pmark)
(insert cmushell-dirstack-query) (insert "\n")
(sit-for 0) ; force redisplay
(comint-send-string proc cmushell-dirstack-query)
(comint-send-string proc "\n")
(set-marker pmark (point))
(let ((pt (point))) ; wait for 1 line
;; This extra newline prevents the user's pending input from spoofing us.
(insert "\n") (backward-char 1)
(while (not (looking-at ".+\n"))
(accept-process-output proc)
(goto-char pt)))
(goto-char pmark) (delete-char 1) ; remove the extra newline
;; That's the dirlist. grab it & parse it.
(let* ((dl (buffer-substring (match-beginning 0) (- (match-end 0) 1)))
(dl-len (length dl))
(ds '()) ; new dir stack
(i 0))
(while (< i dl-len)
;; regexp = optional whitespace, (non-whitespace), optional whitespace
(string-match "\\s *\\(\\S +\\)\\s *" dl i) ; pick off next dir
(setq ds (cons (substring dl (match-beginning 1) (match-end 1))
ds))
(setq i (match-end 0)))
(let ((ds (reverse ds)))
(condition-case nil
(progn (cd (car ds))
(setq cmushell-dirstack (cdr ds))
(cmushell-dirstack-message))
(error (message "Couldn't cd.")))))))
;;; For your typing convenience:
(fset 'dirs 'cmushell-resync-dirs)
;;; Show the current dirstack on the message line.
;;; Pretty up dirs a bit by changing "/usr/jqr/foo" to "~/foo".
;;; (This isn't necessary if the dirlisting is generated with a simple "dirs".)
;;; All the commands that mung the buffer's dirstack finish by calling
;;; this guy.
(defun cmushell-dirstack-message ()
(let ((msg "")
(ds (cons default-directory cmushell-dirstack)))
(while ds
(let ((dir (car ds)))
(if (string-match (format "^%s\\(/\\|$\\)" (getenv "HOME")) dir)
(setq dir (concat "~/" (substring dir (match-end 0)))))
(if (string-equal dir "~/") (setq dir "~"))
(setq msg (concat msg dir " "))
(setq ds (cdr ds))))
(message msg)))
;;; Interfacing to client packages (and converting them)
;;;============================================================================
;;; Several gnu packages (tex-mode, background, dbx, gdb, kermit, prolog,
;;; telnet are some) use the shell package as clients. Most of them would
;;; be better off using the comint package directly, but they predate it.
;;; The catch is that most of these packages (dbx, gdb, prolog, telnet)
;;; assume total knowledge of all the local variables that shell mode
;;; functions depend on. So they (kill-all-local-variables), then create
;;; the few local variables that shell.el functions depend on. Alas,
;;; cmushell.el functions depend on a different set of vars (for example,
;;; the input history ring is a local variable in cmushell.el's shell mode,
;;; whereas there is no input history ring in shell.el's shell mode).
;;; So we have a situation where the greater functionality of cmushell.el
;;; is biting us -- you can't just replace shell will cmushell.
;;;
;;; Altering these packages to use comint mode directly should *greatly*
;;; improve their functionality, and is actually pretty easy. It's
;;; mostly a matter of renaming a few variable names. See comint.el for more.
;;; -Olin
;;; Do the user's customisation...
;;;===============================
(defvar cmushell-load-hook nil
"This hook is run when cmushell is loaded in.
This is a good place to put keybindings.")
(run-hooks 'cmushell-load-hook)
;;; Change Log
;;; ===========================================================================
;;; Olin 8/88
;;; Created.
;;;
;;; Olin 5/26/90
;;; - Split cmulisp and cmushell modes into separate files.
;;; Not only is this a good idea, it's apparently the way it'll be rel 19.
;;; - Souped up the directory tracking; it now can handle pushd, pushd +n,
;;; and popd +n.
;;; - Added cmushell-dirtrack-toggle command to toggle the directory
;;; tracking that cmushell tries to do. This is useful, for example,
;;; when you are running ftp -- it prevents the ftp "cd" command from
;;; spoofing the tracking machinery. This command is also named
;;; dirtrack-toggle, so you need only type M-x dirtrack to run it.
;;; - Added cmushell-resync-dirs command. This queries the shell
;;; for the current directory stack, and resets the buffer's stack
;;; accordingly. This command is also named dirs, so you need only type
;;; M-x dirs to run it.
;;; - Bits of the new directory tracking code were adapted from source
;;; contributed by Vince Broman, Jeff Peck, and Barry Warsaw.
;;; - See also the improvements made to comint.el at the same time.
;;; - Renamed several variables. Mostly this comprised changing "shell"
;;; to "cmushell" in the names. The only variables that are not prefixed
;;; with "cmushell-" are the ones that are common with shell.el:
;;; explicit-shell-file-name shell-prompt-pattern explicit-csh-args
;;; and shell-cd/popd/pushd-regexp
;;; The variables and functions that were changed to have "cmushell-"
;;; prefixes are:
;;; shell-directory-stack (v), shell-directory-tracker (f)
;;; This should not affect users, only elisp hackers. Hopefully
;;; one day shell.el will just go away, and we can drop all this
;;; "cmushell" bullshit.
;;; - Upgraded process sends to use comint-send-string instead of
;;; process-send-string.
;;;
;;; Olin 6/14/90
;;; - If your shell is named <shellname>, and a variable named
;;; explicit-<shellname>-args exists, cmushell is supposed
;;; to use its value as the arglist to the shell invocation.
;;; E.g., if you define explicit-csh-args to be
;;; ("-ifx"), then when cmushell cranks up a csh, it execs it
;;; as "csh -ifx". This is what is documented. What has actually
;;; been the case is that the variable checked is
;;; explicit-<shellname>-arguments, not explicit-<shellname>-args.
;;; The documentation has been changed to conform to the code (for
;;; backwards compatibility with shell.el). This bug is inherited from
;;; the same bug in shell.el.
;;; This bug reported by Stephen Anderson.
;;;
;;; Olin 9/5/90
;;; - Arguments to cd, popd, and pushd now have their env vars expanded
;;; out by the tracking machinery. So if you say "cd $SRCDIR/funs", the
;;; $SRCDIR var will be replaced by its value *in emacs' process
;;; environment*. If this is different from the shell's binding of the
;;; variable, you lose. Several users needed this feature, fragile
;;; though it may be. The fix was contributed by sk@thp.Uni-Koeln.DE.
;;;
;;; Olin 3/12/91
;;; - Moved comint-dynamic-complete (filename completion) from M-tab to tab.

1372
emacs/comint.el Normal file
View File

File diff suppressed because it is too large Load Diff

91
emacs/jar-hacks.el Normal file
View File

@ -0,0 +1,91 @@
; Comment out region
(defun comment-out-region (arg)
"Insert comment string at beginning of each line in the region."
(interactive "P")
(let (start end)
(if (< (point) (mark))
(setq start (point) end (mark-marker))
(setq start (mark) end (point-marker)))
(save-excursion
(untabify start (marker-position end))
(goto-char start)
(if (not (bolp))
(progn (end-of-line) (forward-char)))
(while (< (point) (marker-position end))
(if (eq arg '-)
(if (looking-at comment-start)
(delete-char (length comment-start)))
(insert comment-start))
(end-of-line)
(forward-char)))))
;(defun uncomment-out-region (arg)
; (interactive nil)
; (comment-out-region '-))
; Mini-Find Tag
(defvar last-mini-tag "" "Last tag sought by mini-find-tag.")
(defun mini-find-tag (tagname &optional next)
"Search for a definition of TAGNAME in current buffer.
If TAGNAME is a null string, the expression in the buffer
around or before point is used as the tag name.
If second arg NEXT is non-nil (interactively, with prefix arg),
searches for the next definition in the buffer
that matches the tag name used in the previous mini-find-tag."
(interactive (if current-prefix-arg
'(nil t)
(list (read-string "Mini-find tag: "))))
(if (equal tagname "") ;See definition of find-tag.
(setq tagname (save-excursion
(buffer-substring
(progn (backward-sexp 1) (point))
(progn (forward-sexp 1) (point))))))
(let ((pt (save-excursion
(if (not next)
(goto-char (point-min))
(setq tagname last-mini-tag))
(setq last-mini-tag tagname)
(if (re-search-forward
(concat "^(def.*" tagname)
nil t)
(point)
nil))))
(if pt
(progn (set-mark-command nil)
(goto-char pt))
(signal 'search-failed '()))))
; indent-differently
(defun indent-differently ()
"Make the current line indent like the body of a special form by
changing the operator's scheme-indent-hook appropriately."
(interactive nil)
(let ((here (point)))
(save-excursion
(back-to-indentation)
(backward-up-list 1)
(forward-char 1)
(let ((i -1)
(function nil)
(p (point)))
(while (<= (point) here)
(setq i (+ i 1))
(forward-sexp 1)
(if (= i 0)
(setq function (buffer-substring p (point)))))
(setq i (- i 1))
(let ((name (intern (downcase function))))
(cond ((equal (get name 'scheme-indent-hook) i)
(message "Indent %s nil" name)
(put name 'scheme-indent-hook nil))
(t
(message "Indent %s %d" name i)
(put name 'scheme-indent-hook i))))))
(scheme-indent-line)))

98
gdbinit Normal file
View File

@ -0,0 +1,98 @@
#
# Commands useful for debugging the Scheme48 VM.
#
#Set a breakpoint at label "raise".
#Obtain the proper line number using "egrep -n raise: scheme48vm.c".
break scheme48vm.c:5227
display/i $pc
define pcont
echo template id = \
output *(long *)((*(long *)(($ & ~3) + 8) & ~3) + 4) / 4
echo \npc = \
output (*(long *)(($ & ~3) + 4) / 4)
echo \nparent = \
output *(long *)($ & ~3)
echo \nenv = \
output *(long *)(($ & ~3) + 12)
echo \ncount = \
output *(long *)(($ & ~3) - 4) >> 10
echo \n
end
#
document pcont
Print $ as a continuation.
end
define parent
print *(long *)($ & ~3)
pcont
end
#
document parent
Select parent continuation.
end
define preview
set $cont = ScontS
preview-loop
end
#
define preview-loop
output $cont
echo \040
output *(long *)((*(long *)(($cont & ~3) + 8) & ~3) + 4) / 4
echo \n
set $cont = *(long *)($cont & ~3)
preview-loop
end
#
document preview
Display Scheme stack trace. Look up the template uids in the .debug file.
end
define show-header
echo Header length:\
output $hdr >> 8
echo \ type:\040
output ($hdr & 127) >> 2
echo \ tag:\040
output $hdr & 3
echo \n
end
define look
output ($ - Snewspace_beginS)
echo :\n
set $hdr = *(long *)($ - 7)
show-header
output *(long *)($ - 3)
echo \n
output *(long *)($ + 1)
echo \n
output *(long *)($ + 5)
echo \n
end
define go0
print *(long *)($ - 3)
end
define bytes
set $foo = RScode_pointerS
output (int)*(unsigned char *)($foo + 0)
echo \040
output (int)*(unsigned char *)($foo + 1)
echo \040
output (int)*(unsigned char *)($foo + 2)
echo \040
output (int)*(unsigned char *)($foo + 3)
echo \040
output (int)*(unsigned char *)($foo + 4)
echo \n
end

238
install-sh Executable file
View File

@ -0,0 +1,238 @@
#! /bin/sh
#
# install - install a program, script, or datafile
# This comes from X11R5.
#
# Calling this script install-sh is preferred over install.sh, to prevent
# `make' implicit rules from creating a file called install from it
# when there is no Makefile.
#
# This script is compatible with the BSD install script, but was written
# from scratch.
#
# set DOITPROG to echo to test this script
# Don't use :- since 4.3BSD and earlier shells don't like it.
doit="${DOITPROG-}"
# put in absolute paths if you don't have them in your path; or use env. vars.
mvprog="${MVPROG-mv}"
cpprog="${CPPROG-cp}"
chmodprog="${CHMODPROG-chmod}"
chownprog="${CHOWNPROG-chown}"
chgrpprog="${CHGRPPROG-chgrp}"
stripprog="${STRIPPROG-strip}"
rmprog="${RMPROG-rm}"
mkdirprog="${MKDIRPROG-mkdir}"
transformbasename=""
transform_arg=""
instcmd="$mvprog"
chmodcmd="$chmodprog 0755"
chowncmd=""
chgrpcmd=""
stripcmd=""
rmcmd="$rmprog -f"
mvcmd="$mvprog"
src=""
dst=""
dir_arg=""
while [ x"$1" != x ]; do
case $1 in
-c) instcmd="$cpprog"
shift
continue;;
-d) dir_arg=true
shift
continue;;
-m) chmodcmd="$chmodprog $2"
shift
shift
continue;;
-o) chowncmd="$chownprog $2"
shift
shift
continue;;
-g) chgrpcmd="$chgrpprog $2"
shift
shift
continue;;
-s) stripcmd="$stripprog"
shift
continue;;
-t=*) transformarg=`echo $1 | sed 's/-t=//'`
shift
continue;;
-b=*) transformbasename=`echo $1 | sed 's/-b=//'`
shift
continue;;
*) if [ x"$src" = x ]
then
src=$1
else
# this colon is to work around a 386BSD /bin/sh bug
:
dst=$1
fi
shift
continue;;
esac
done
if [ x"$src" = x ]
then
echo "install: no input file specified"
exit 1
else
true
fi
if [ x"$dir_arg" != x ]; then
dst=$src
src=""
if [ -d $dst ]; then
instcmd=:
else
instcmd=mkdir
fi
else
# Waiting for this to be detected by the "$instcmd $src $dsttmp" command
# might cause directories to be created, which would be especially bad
# if $src (and thus $dsttmp) contains '*'.
if [ -f $src -o -d $src ]
then
true
else
echo "install: $src does not exist"
exit 1
fi
if [ x"$dst" = x ]
then
echo "install: no destination specified"
exit 1
else
true
fi
# If destination is a directory, append the input filename; if your system
# does not like double slashes in filenames, you may need to add some logic
if [ -d $dst ]
then
dst="$dst"/`basename $src`
else
true
fi
fi
## this sed command emulates the dirname command
dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'`
# Make sure that the destination directory exists.
# this part is taken from Noah Friedman's mkinstalldirs script
# Skip lots of stat calls in the usual case.
if [ ! -d "$dstdir" ]; then
defaultIFS='
'
IFS="${IFS-${defaultIFS}}"
oIFS="${IFS}"
# Some sh's can't handle IFS=/ for some reason.
IFS='%'
set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'`
IFS="${oIFS}"
pathcomp=''
while [ $# -ne 0 ] ; do
pathcomp="${pathcomp}${1}"
shift
if [ ! -d "${pathcomp}" ] ;
then
$mkdirprog "${pathcomp}"
else
true
fi
pathcomp="${pathcomp}/"
done
fi
if [ x"$dir_arg" != x ]
then
$doit $instcmd $dst &&
if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi &&
if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi &&
if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi &&
if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi
else
# If we're going to rename the final executable, determine the name now.
if [ x"$transformarg" = x ]
then
dstfile=`basename $dst`
else
dstfile=`basename $dst $transformbasename |
sed $transformarg`$transformbasename
fi
# don't allow the sed command to completely eliminate the filename
if [ x"$dstfile" = x ]
then
dstfile=`basename $dst`
else
true
fi
# Make a temp file name in the proper directory.
dsttmp=$dstdir/#inst.$$#
# Move or copy the file name to the temp name
$doit $instcmd $src $dsttmp &&
trap "rm -f ${dsttmp}" 0 &&
# and set any options; do chmod last to preserve setuid bits
# If any of these fail, we abort the whole thing. If we want to
# ignore errors from any of these, just make sure not to ignore
# errors from the above "$doit $instcmd $src $dsttmp" command.
if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi &&
if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi &&
if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi &&
if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi &&
# Now rename the file to the real destination.
$doit $rmcmd -f $dstdir/$dstfile &&
$doit $mvcmd $dsttmp $dstdir/$dstfile
fi &&
exit 0

18
ps-compiler/compile-gc.scm Normal file
View File

@ -0,0 +1,18 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
(config '(load "../scheme/vm/macro-package-defs.scm"))
(load-package 'vm-architecture)
(in 'forms '(run (set! *duplicate-lambda-size* 30)))
(in 'simplify-let '(run (set! *duplicate-lambda-size* 15)))
(in 'prescheme-compiler
'(run (prescheme-compiler
'(allocation heap heap-init images gc)
'("../scheme/vm/interfaces.scm"
"../scheme/vm/ps-package-defs.scm"
"../scheme/vm/package-defs.scm"
"../scheme/vm/gc-package-defs.scm")
's48-heap-init
"../scheme/vm/scheme48heap.c"
'(header "#include \"scheme48vm.h\"")
;'(copy (heap walk-over-type-in-area))
'(integrate (real-copy-object s48-trace-locations!)))))

27
ps-compiler/compile-vm-no-gc.scm Normal file
View File

@ -0,0 +1,27 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
(config '(load "../scheme/vm/macro-package-defs.scm"))
(load-package 'vm-architecture)
(in 'forms '(run (set! *duplicate-lambda-size* 30)))
(in 'simplify-let '(run (set! *duplicate-lambda-size* 15)))
(in 'prescheme-compiler
'(run (prescheme-compiler
'(vm external-gc-roots)
'("../scheme/vm/interfaces.scm"
"../scheme/vm/ps-package-defs.scm"
"../scheme/vm/package-defs.scm"
"../scheme/vm/no-gc-package-defs.scm")
's48-init
"../scheme/vm/scheme48vm.c"
'(header "#include \"scheme48vm-prelude.h\"")
'(copy (interpreter push-continuation-on-stack))
'(no-copy (interpreter interpret
application-exception
handle-interrupt
uuo)
;(vm restart)
(interpreter-gc collect-saving-temp
collect-saving-temps)))))
; '(shadow ((interpreter restart)
; (interpreter *val* *code-pointer*)
; (stack *stack* *env*))))))

29
ps-compiler/compile-vm.scm Normal file
View File

@ -0,0 +1,29 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
(config '(load "../scheme/vm/macro-package-defs.scm"))
(load-package 'vm-architecture)
(in 'forms '(run (set! *duplicate-lambda-size* 30)))
(in 'simplify-let '(run (set! *duplicate-lambda-size* 15)))
(in 'prescheme-compiler
'(run (prescheme-compiler
'(interpreter heap-init)
'("../scheme/vm/interfaces.scm"
"../scheme/vm/ps-package-defs.scm"
"../scheme/vm/package-defs.scm")
'scheme48-init
"../scheme/vm/scheme48vm.c"
'(header "#include \"scheme48vm-prelude.h\"")
'(copy (heap walk-over-type-in-area)
(fixnum-arithmetic quotient-carefully))
'(no-copy (interpreter interpret
application-exception
handle-interrupt
uuo
collect-saving-temp
do-gc))
'(integrate (copy-next do-gc)
(copy-object do-gc))
'(shadow ((interpreter do-gc) (heap *hp*))
((interpreter restart)
(interpreter *val* *code-pointer*)
(stack *stack* *env*))))))

340
ps-compiler/doc/node.txt Normal file
View File

@ -0,0 +1,340 @@
In the compiler `continuation' means a continuation that is a lambda node.
Non-lambda continuation arguments, such as the argument to a RETURN, are
not referred to as continuations (the argument isn't a continuation, it
is a variable that is bound to a continuation).
Every node has the following fields:
variant ; one of LITERAL, REFERENCE, LAMBDA, or CALL
parent ; parent node
index ; index of this node in parent, if parent is a call node
simplified? ; true if it has already been simplified; if this is #F
; then all of this node's ancestors must also be unsimplified
flag ; useful flag, all users must leave this is #F
Literal nodes:
value ; the value
type ; the type of the value (important for statically typed languages,
; not so useful for Scheme)
Reference nodes:
variable ; the referenced variable; the binder of the variable must be
; an ancestor of the reference node
Call nodes:
primop ; the primitive being called
args ; vector of argument nodes
exits ; the number of arguments that are continuations; the continuation
; arguments come before the non-continuation ones
source ; source info; used for error messages
Primops are either trivial or nontrivial. Trivial primops only return a value
and have no side effects. Calls to trivial primops never have continuation
arguments and are always arguments to other calls. Calls to nontrivial primops
may or may not have continuations and are always the body of a lambda node.
Lambda nodes:
type ; one of PROC, CONT, or JUMP (and maybe THROW at some point)
name ; symbol (for debugging)
id ; unique integer (for debugging)
body ; the call-node that is the body of the lambda
variables ; a list of variable records, with #Fs for ignored positions
source ; source info; used for error messages
protocol ; calling protocol from the source language
block ; for use during code generation
env ; for use when adding explicit environments
PROC's are general procedures. The first variable of a PROC will be bound
to the PROC's continuation.
CONT's are continuation arguments to calls.
JUMP's are continuations bound by LET or LETREC, whose calling points are
known, and which are created and called within a single PROC.
Variables:
name ; source code name for variable (used for debugging only)
id ; unique numeric identifier (used for debugging only)
type ; type of variable's value
binder ; LAMBDA node which binds this variable (or #F if none)
refs ; list of reference nodes n for which (REFERENCE-VARIABLE n)
; = this variable
flag ; useful slot, used by shapes, COPY-NODE, NODE->VECTOR, etc.
; all users must leave this is #F
flags ; list of various annotations, e.g. IGNORABLE
generate ; for whatever code generation wants
----------------------------------------------------------------
The node tree has a very regular lexical structure:
The body of every lambda node is a non-trivial call.
The parent of every non-trivial call is a lambda node.
Every CONT lambda is a continuation of a non-trivial call.
Every JUMP lambda is an argument to either the LET or the LETREC
primops (described below).
The lambda node that binds a variable is an ancestor of every reference
to that variable.
If you start from any leaf node and follow the parent pointers up through the
node tree, you first go through some number, possible zero, of trivial calls
until a non-trivial call is reached. From that point on non-trivial calls
alternate with CONT nodes until a PROC or JUMP lambda is reached. Going up
from a PROC lambda is the same as going up from a leaf, while JUMP lambdas
are always arguments to LET or LETREC, both of which are non-trivial.
A basic block appears as a sequence of non-trivial calls with a single
continuation apiece. The block begins with a PROC or JUMP lambda, or
with a CONT lambda that is an argument to a call with two or more
continuations, and ends with a call that has either no continuations,
or two or more.
Basic blocks are grouped into trees. The root of every tree is either
a PROC or JUMP lambda, the branch points are calls with two or more
continuations, and the leaves are jumps or returns. Within a tree
the control flow follows the lexical structure of the program from
parent to child (if we ignore calls to other PROCs).
Every JUMP lambda is called from within only one PROC lambda, so a PROC
can be considered to consist of a set of trees, the leaves of which either
return from that PROC or jump to the top of another tree in the set.
----------------------------------------------------------------
Primops:
id ; unique symbol identifying this primop
trivial? ; #t if this primop has does not accept a continuation
side-effects ; one of #F, READ, WRITE, ALLOCATE, or IO
simplify-call-proc ; simplify method
primop-cost-proc ; cost of executing this operation
; (in some undisclosed metric)
return-type-proc ; the type of the value returned (for trivial primops only)
proc-data ; more data for the procedure primops
cond-data ; more data for conditional primops
code-data ; code generation data
`procedure' primops are those that call one of their values.
`conditional' primops are those that have more than one continuation.
Below is a list of the standard primops. All but the last two are non-trivial.
For the following the five primops the lambda node being called, jumped to,
or whatever has been identified by the compiler, and the number of variables
that the lambda node has matches the number of arguments.
(CALL <cont> <proc> . <args>)
(TAIL-CALL <cont-var> <proc> . <args>)
(RETURN <cont-var> . <args>)
(JUMP <jump-var> . <args>)
; (THROW <throw-var> . <args>) not yet implemented
These are the same as the above except that the procedure has not been
identified by the compiler. There is no UNKNOWN-JUMP because all calls
to JUMP lambdas must be known.
(UNKNOWN-CALL <cont> <proc> . <args>)
(UNKNOWN-TAIL-CALL <cont> <proc> . <args>)
(UNKNOWN-RETURN <cont-var> . <args>)
PROC lambdas are called with either CALL or TAIL-CALL if all of their call
sites have been identified, or with UNKNOWN-CALL or UNKNOWN-TAIL-CALL if not.
JUMP lambdas are called using JUMP.
LET binds random values, such as lambda nodes or the results of trivial
calls, to variables. This primop only exists because of the requirement
that every call have a primop; all it does is apply <cont> to <args>
(it is called LET instead of APPLY because LET forms in the source code
become calls to this primop).
(LET <cont> . <args>)
Recursive binding:
(LETREC1 <cont>)
(LETREC2 <cont> <id-var> <lambda1> <lambda2> ...)
These are always used together, with the body of the continuation to LETREC1
being a call to LETREC2. The two calls together look like:
(LETREC1 (lambda (<id-var> <var1> ... <varN>)
(LETREC2 <cont> <id-var> <lambda1> ... <lambdaN>)))
which the CPS pretty-printer prints as:
(let* (...
((id-var var1 ... varN) (letrec1))
(() (letrec2 id-var lambda1 ... lambdaN))
...)
...)
The end result is to bind <varI> to <lambdaI>. The point to the excercise
is that lambdas occur within the scope of the variables.
Undefined effect. This takes a continuation variable as an argument only
so that the continuation variable is always reached.
(UNDEFINED-EFFECT <cont-var> ...)
Accessing and mutating the store.
Cells are used to implement SET! on lexically bound variables. GLOBAL-SET!
and GLOBAL-REF are used for module variables that may be set.
(CELL-SET! <cont> <cell> <value>)
(GLOBAL-SET! <cont> <global-var> <value>)
(CELL-REF <cell>) ; trivial
(GLOBAL-REF <global-var>) ; trivial
----------------------------------------------------------------
Printing out the node tree.
The following procedure:
(define (fact n)
(let loop ((n n) (r 1))
(if (< n 2)
r
(loop (- n 1) (* n r)))))
when converted into nodes is:
(LAMBDAp (c_6 n_1)
(letrec1 (LAMBDAc (x_13 loop_2)
(letrec2 (LAMBDAc ()
(unknown-tail-call c_6 loop_2 n_1 '1))
x_13
(LAMBDAp (c_8 n_3 r_4)
(test
(LAMBDAc ()
(unknown-return c_8 r_4))
(LAMBDAc ()
(unknown-tail-call c_8 loop_2 (- n_3 '1) (* n_3 r_4)))
(< n_3 '2)))))))
where LAMBDAp is a PROC lambda and LAMBDAc is a CONT lambda. Lexically bound
variables are printed as <name>_<id> and constants as '<value>. This is not
very readable, and larger procedures are much worse. The first step in making
it more comprehensible is to print each lambda node separately with a marker
to indicate where it appears in the tree.
(LAMBDAp fact_7 (c_6 n_1)
(letrec1 1 ^c_14))
(LAMBDAc c_14 (x_13 loop_2)
(letrec2 1 ^c_12 x_13 ^loop_9))
(LAMBDAc c_12 ()
(unknown-tail-call 0 c_6 loop_2 n_1 '1))
(LAMBDAp loop9 (c_8 n_3 r_4)
(test 2 ^g_10 ^g_11 (< n_3 '2)))
(LAMBDAc g_10 ()
(unknown-return 0 c_8 r_4))
(LAMBDAc g_11 ()
(unknown-tail-call 0 c_8 loop_2 (- n_3 '1) (* n_3 r_4)))
The labels used are the names and id's of the lambda nodes, with a ^ in front
to distinguish them from variables. The code for each lambda is indented
slightly more than the lambda in which it actually occurs. To make the
distinction between continuation and non-continuation lambdas clearer the
number of continuation arguments to a call is printed just after the primop
(for example the first two arguments to TEST are continuations).
The first three calls form a basic block because the first two calls have
exactly one continuation apiece. To make this more easily seen these
calls can be printed using a more condensed notation:
(LAMBDAp fact_7 (c_6 n_1)
(LET* (((x_13 loop_2) (letrec1))
(() (letrec2 x_13 ^loop_9)))
(unknown-tail-call 0 c_6 loop_2 n_1 '1)))
The continuations are not printed as arguments but instead their variables
are printed to the left of the call in a parody of Scheme's LET*. The results
of the LETREC1 are bound to the variables X_13 and LOOP_2 as would happen with
the real LET* (if it allowed calls to return multiple values).
Finally, here is the way the code for FACT is actually printed:
7 (P fact_7 (c_6 n_1)
14 (LET* (((x_13 loop_2)
(letrec1))
12 (() (letrec2 x_13 ^loop_9)))
(unknown-tail-call 0 c_6 loop_2 n_1 '1)))
9 (P loop_9 (c_8 n_3 r_4)
(test 2 ^g_10 ^g_11 (< n_3 '2)))
10 (C g_10 ()
(unknown-return 0 c_8 r_4))
11 (C g_11 ()
(unknown-tail-call 0 c_8 loop_2 (- n_3 '1) (* n_3 r_4)))
The ID number of every lambda node is printed out at the beginning of the
line on which the code for the lambda appears. This is redundant for the
lambdas that are not printed as part of a LET*. The word `LAMBDA' is not
printed. The (letrec1) call appears on a new line because the printer
indents the calls in LET* a fixed amount.
The reason for printing the ID numbers is so that the actual nodes can be
obtained. Once a lambda has been printed (either by the pretty printer or
by the regular printer), (NODE-UNHASH <id>) will return it:
scheme-compiler> (node-unhash 9)
'#{Node lambda loop 9}
scheme-compiler> ,inspect ##
'#{Node lambda loop 9}
[0: variant] 'lambda
[1: parent] '#{Node call letrec2}
[2: index] 2
[3: simplified?] #t
[4: flag] #f
[5: stuff-0] '#{Node call test}
[6: stuff-1] '(#{Variable n 3} #{Variable r 4})
[7: stuff-2] '(#{Name #} (n r) (if # r #))
[8: stuff-3] '#{Lambda-data}
----------------------------------------------------------------
Simplification.
The factorial procedure above is how it looks when originally translated
into a node tree. The next step in compilation is to simplify the tree,
doing constant folding, identifying call points, and so on. The simplified
version of FACT is:
7 (P fact_7 (c_6 n_1)
14 (LET* (((x_13 loop_2)
(letrec1))
12 (() (letrec2 x_13 ^loop_9)))
(jump 0 loop_2 n_1 '1)))
9 (J loop_9 (n_3 r_4)
(test 2 ^g_10 ^g_11 (< n_3 '2)))
10 (C g_10 ()
(unknown-return 0 c_6 r_4))
11 (C g_11 ()
(jump 0 loop_2 (+ '-1 n_3) (* n_3 r_4)))
The only change is that the loop has been turned into a JUMP lambda.
----------------------------------------------------------------
Still to describe:
protocol determination
simplifier moving stuff down, duplicating, later passes move values back up

15
ps-compiler/doc/todo.txt Normal file
View File

@ -0,0 +1,15 @@
There is a question about the simplifier for -.
Also, should (- x x) be checked for?
Join substitute is not quite right: might have (some-test cont1 cont2 V <huge>)
where V is being tested. As it stands we'll duplicate <huge>. Should check
that it is either small or contains no references to V (in which case we lift
it with the conts).
Need to come up with good numbers for the maximum size of procs and jumps
that should be duplicated.
Can join-substitute move stuff above a test?
Pre-Scheme type checker dies on (car '()) if a LET has more variables
than values.

124
ps-compiler/front/cps.scm Normal file
View File

@ -0,0 +1,124 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; (cps-call <primop> <exits> <first-arg-index> <args> <cps>) ->
; <call-node> + <top-call-node> + <bottom-lambda-node>
;
; (cps-sequence <nodes> <cps>) -> <last-node> + <top-call> + <bottom-lambda>
;
; (<cps> <node>) -> <value-node> + <top-call-node> + <bottom-lambda-node>
(define (cps-call primop exits first-arg-index args cps)
(let ((call (make-call-node primop
(+ (length args) first-arg-index)
exits))
(arguments (make-arg-nodes args first-arg-index cps)))
(let loop ((args arguments) (first #f) (last #f))
(if (null? args)
(values call first last)
(let ((arg (car args)))
(attach call (arg-index arg) (arg-value arg))
(if (and last (arg-first arg))
(attach-body last (arg-first arg)))
(loop (cdr args)
(or first (arg-first arg))
(or (arg-last arg) last)))))))
; Record to hold information about arguments to calls.
(define-record-type arg :arg
(make-arg index rank value first last)
arg?
(index arg-index) ; The index of this argument in the call.
(rank arg-rank) ; The estimated cost of executing this node at run time.
(value arg-value) ; What CPS returned for this argument.
(first arg-first)
(last arg-last))
; Convert the elements of EXP into nodes (if they aren't already) and put
; them into an ARG record. Returns the list of ARG records sorted
; by ARG-RANK.
(define (make-arg-nodes exp start cps)
(do ((index start (+ index 1))
(args exp (cdr args))
(vals '() (cons (receive (value first last)
(cps (car args))
(make-arg index (node-rank first) value first last))
vals)))
((null? args)
(sort-list vals
(lambda (v1 v2)
(> (arg-rank v1) (arg-rank v2)))))))
; Complexity analysis used to order argument evaluation. More complex
; arguments are to be evaluated first. This just counts reference nodes.
; It is almost certainly a waste of time.
(define (node-rank first)
(if (not first)
0
(complexity-analyze-vector (call-args first))))
(define (complexity-analyze node)
(cond ((empty? node)
0)
((reference-node? node)
1)
((lambda-node? node)
(if (not (empty? (lambda-body node)))
(complexity-analyze-vector (call-args (lambda-body node)))
0))
((call-node? node)
(complexity-analyze-vector (call-args node)))
(else
0)))
(define (complexity-analyze-vector vec)
(do ((i 0 (+ i 1))
(q 0 (+ q (complexity-analyze (vector-ref vec i)))))
((>= i (vector-length vec))
q)))
;----------------------------------------------------------------
; (cps-sequence <nodes> <values-cps>) ->
; <last-node> + <top-call> + <bottom-lambda>
; <values-cps> is the same as the <cps> used above, except that it returns
; a list of value nodes instead of exactly one.
(define (cps-sequence nodes values-cps)
(if (null? nodes)
(bug "CPS: empty sequence"))
(let loop ((nodes nodes) (first #f) (last #f))
(if (null? (cdr nodes))
(values (car nodes) first last)
(receive (exp-first exp-last)
(cps-sequent (car nodes) values-cps)
(if (and last exp-first)
(attach-body last exp-first))
(loop (cdr nodes) (or first exp-first) (or exp-last last))))))
(define (cps-sequent node values-cps)
(receive (vals exp-first exp-last)
(values-cps node)
(receive (calls other)
(partition-list call-node? vals)
(map erase other)
(if (null? calls)
(values exp-first exp-last)
(insert-let calls exp-first exp-last)))))
(define (insert-let calls exp-first exp-last)
(let* ((vars (map (lambda (call)
(make-variable 'v (trivial-call-return-type call)))
calls))
(cont (make-lambda-node 'c 'cont vars))
(call (make-call-node (get-primop (enum primop let))
(+ 1 (length calls))
1)))
(attach-call-args call (cons cont calls))
(cond (exp-first
(attach-body exp-last call)
(values exp-first cont))
(else
(values call cont)))))

319
ps-compiler/front/jump.scm Normal file
View File

@ -0,0 +1,319 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; Code to turn PROC lambdas into JUMP lambdas.
(define (integrate-jump-procs!)
(receive (hits useless)
(find-jump-procs (filter proc-lambda? (make-lambda-list)) find-calls)
(remove-unused-procedures! useless)
(for-each (lambda (p)
(procs->jumps (cdr p)
(map bound-to-variable (cdr p))
(car p)))
hits)
(not (and (null? hits) (null? useless)))))
; Make a call graph with extra nodes inserted for continuations:
;
; If F calls G tail-recursively, add an edge F->G
; If F calls G ... with continuation K, add a node K and edges F->K, K->G ...
;
; Then FIND-JOINS will return a list of the nodes that are passed two or
; more distinct continuations. The rest can be merged with their callers.
;
; Need a root node, so make one that points to all procs with unknown calls.
(define-record-type node :node
(really-make-node proc cont successors join? merged?)
node?
(proc node-proc) ; lambda node (or #f for continuation holders)
(cont node-cont) ; lambda node (or #f for procs)
(successors node-successors set-node-successors!)
(temp node-temp set-node-temp!)
(join? node-join? set-node-join?!)
(merged? node-merged? set-node-merged?!))
(define (make-node proc cont)
(really-make-node proc cont '() #f #f))
(define-record-discloser :node
(lambda (node)
(list 'node (node-proc node) (node-cont node))))
(define (add-child! parent child)
(if (not (memq? child (node-successors parent)))
(set-node-successors! parent (cons child (node-successors parent)))))
; We want to find subsets of ALL-PROCS such that all elements of a subset
; are always called with the same continuation. (PROC->USES <proc>) returns
; the references to <proc> that are calls, or #f if there are references that
; are not calls.
;
; We proceed as follows:
; 1. Partition the procs depending on whether all their calls are known or not.
; 2. Build a call graph:
; Nodes represent either procedures or continuations. If there is a
; tail-recursive call to procedure B in procedure A, then there is an
; edge from A to B. For continuation C such that there is a call in
; procedure A to procedure B with that continuation, there are edges
; from A to C and from C to B.
; In other words, it is a call graph where the edges that represent
; non-tail-recursive calls are replaced by two edges, with a node for
; the continuation in between.
; There is a special root node (representing `outside'), that has
; edges to the nodes representing procedures whose call sites have not
; been identified.
; 3. Determine the dominance frontiers in the graph.
; 4. Find the nodes in the graph that are reachable from more than one
; continuation (the joins).
; 5. Starting from each node that represents a continuation (the joins,
; procs whose calls aren't known, and the continuations themselves),
; find the set of nodes reachable from that node without going through
; some other continuation node.
(define (find-jump-procs all-procs proc->uses)
(for-each (lambda (l)
(set-lambda-block! l (make-node l #f)))
all-procs)
(receive (known unknown)
(partition-list calls-known? all-procs)
(let ((root (make-node #f #f))
(conts-cell (list '()))
(known-blocks (map lambda-block known))
(procs-cell (list (map lambda-block unknown))))
(note-calls! known conts-cell procs-cell proc->uses)
(let ((unknown-blocks (car procs-cell))
(conts (car conts-cell)))
(set-node-successors! root unknown-blocks)
(graph->ssa-graph! root node-successors node-temp set-node-temp!)
(let ((joins (find-joins (append conts unknown-blocks) node-temp)))
(for-each (lambda (n)
(set-node-join?! n #t))
joins)
(let* ((mergable (filter-map find-mergable
(append joins unknown-blocks conts)))
(useless (filter (lambda (p)
(not (or (node-join? (lambda-block p))
(node-merged? (lambda-block p)))))
known)))
(for-each (lambda (p)
(set-lambda-block! p #f))
all-procs)
(values mergable useless)))))))
; Walk KNOWN-PROCS adding edges to the call graph.
(define (note-calls! known-procs conts-cell procs-cell proc->uses)
(for-each (lambda (proc)
(for-each (lambda (ref)
(note-call! (lambda-block proc)
ref
conts-cell procs-cell))
(proc->uses proc)))
known-procs))
; Add an edge from the node containing REF to PROC-NODE. Tail calls add an
; edge directly from the calling node, non-tail calls add an edge from the
; successor to the calling node that represents the call's continuation.
(define (note-call! proc-node ref conts-cell procs-cell)
(let ((caller (get-lambda-block (containing-procedure ref) procs-cell)))
(add-child! (if (calls-this-primop? (node-parent ref) 'tail-call)
caller
(get-cont-block caller
(call-arg (node-parent ref) 0)
conts-cell))
proc-node)))
; Get the block for lambda-node PROC, making a new one if necessary.
(define (get-lambda-block proc procs-cell)
(let ((block (lambda-block proc)))
(if (node? block)
block
(let ((new (make-node proc #f)))
(set-lambda-block! proc new)
(set-car! procs-cell (cons new (car procs-cell)))
new))))
; Get the successor to CALLER containing CONT, making it if necessary.
(define (get-cont-block caller cont conts-cell)
(or (any (lambda (node)
(and (node-cont node)
(node-equal? cont (node-cont node))))
(node-successors caller))
(let ((cont-node (make-node #f cont)))
(set-car! conts-cell (cons cont-node (car conts-cell)))
(add-child! caller cont-node)
cont-node)))
;----------------
(define (find-mergable node)
(let ((mergable (really-find-mergable node)))
(if (null? mergable)
#f
(cons (or (node-cont node)
(car (variable-refs (car (lambda-variables (node-proc node))))))
mergable))))
(define (really-find-mergable node)
(let recur ((nodes (node-successors node)) (res '()))
(if (null? nodes)
res
(recur (cdr nodes)
(let ((node (car nodes)))
(cond ((or (node-join? node) ; gets two or more continuations
(node-merged? node) ; already merged
(node-cont node)) ; different continuation
res)
; ((node-cont node) ; not a lambda
; (recur (node-successors node) res))
(else
(set-node-merged?! node #t)
(recur (node-successors node)
(cons (node-proc node) res)))))))))
;=============================================================================;
; Part 2. PROCS is a list of procedures that are only called by each other;
; with no entry point they are useless and can be removed.
(define (remove-unused-procedures! procs)
(for-each (lambda (proc)
(let ((var (bound-to-variable proc)))
(if (not var)
(bug "known procedure has no variable ~S" proc))
(format #t "Removing unused procedure: ~S~%"
(variable-name var)) ; would LAMBDA-NAME be better?
(mark-changed (node-parent proc))
(detach-bound-value var proc)
(erase proc)))
procs))
;=============================================================================;
; Part 3. Turn JUMP-PROCS from procs to jumps. CONT is the continuation they
; all receive, and is also turned into a jump.
; This creates a LETREC to bind all CONT and any of JUMP-PROCS that are
; passed CONT directly and are bound abouve the LCA of all calls to JUMP-PROCS
; that use CONT. Then every jump-proc is changed from a proc lambda to a
; jump lambda and has its continuation removed. Returns are replaced with
; jumps to CONT. If CONT is not a variable some protocol adjustment may be
; required.
(define (procs->jumps jump-procs vars cont)
(receive (called-vars called-procs lca)
(find-cont-uses cont vars jump-procs)
(let ((proc (containing-procedure cont))
(lca (if (call-node? lca) lca (node-parent lca)))
(cvar (if (lambda-node? cont)
(make-variable 'w (node-type cont))
#f)))
(receive (called-vars called-procs)
(bound-above? lca called-vars called-procs)
(for-each detach-bound-value called-vars called-procs)
(cond ((lambda-node? cont)
(determine-continuation-protocol cont jump-procs)
(move cont (lambda (ignore) (make-literal-node '#f '#f)))
(put-in-letrec (cons cvar called-vars)
(cons cont called-procs)
lca)
(change-lambda-type cont 'jump))
(else
(put-in-letrec called-vars called-procs lca))))
(for-each proc-calls->jumps jump-procs)
(for-each (lambda (p)
(let* ((v (car (lambda-variables p)))
(refs (variable-refs v)))
(set-variable-refs! v '())
(for-each (lambda (r)
(if (lambda-node? cont)
(return->jump (node-parent r) cvar cont)
(replace r (make-reference-node
(car (lambda-variables proc))))))
refs)
(remove-variable p v)))
jump-procs)
(values))))
; Returns those of VALS and VARS where there is a call to the variable that
; passes CONT as a continuation, or where the variable is not bound. The
; third values returned is the least-common-ancestor of all calls to VARS
; that use CONT.
(define (find-cont-uses cont vars vals)
(let loop ((vars vars) (vals vals) (r-vars '()) (r-vals '()) (uses '()))
(if (null? vars)
(values r-vars r-vals (least-common-ancestor uses))
(let ref-loop ((refs (variable-refs (car vars))) (my-uses uses))
(cond ((not (null? refs))
(ref-loop (cdr refs)
(if (node-equal? cont
(call-arg (node-parent (car refs)) 0))
(cons (car refs) my-uses)
my-uses)))
((and (variable-binder (car vars))
(eq? my-uses uses))
(loop (cdr vars) (cdr vals) r-vars r-vals uses))
(else
(loop (cdr vars) (cdr vals)
(cons (car vars) r-vars)
(cons (car vals) r-vals)
my-uses)))))))
; Return the list of VARS and VALS where the variable is either global
; or bound above CALL.
(define (bound-above? call vars vals)
(set-node-flag! call #t)
(let loop ((vars vars) (vals vals) (r-vars '()) (r-vals '()))
(cond ((null? vars)
(set-node-flag! call #f)
(values r-vars r-vals))
((and (variable-binder (car vars))
(marked-ancestor (variable-binder (car vars))))
(loop (cdr vars) (cdr vals) r-vars r-vals))
(else
(loop (cdr vars) (cdr vals)
(cons (car vars) r-vars)
(cons (car vals) r-vals))))))
(define (detach-bound-value var node)
(if (variable-binder var)
(let ((binder (variable-binder var))
(parent (node-parent node))
(index (node-index node)))
(set-lambda-variables! binder (delq! var (lambda-variables binder)))
(detach node)
(remove-call-arg parent index))))
; Turn all calls to PROC into jumps.
(define (proc-calls->jumps proc)
(for-each (lambda (n)
(call->jump (node-parent n)))
(find-calls proc))
(change-lambda-type proc 'jump))
; Change a call to a jump by changing the primop and removing the continuation.
(define (call->jump call)
(case (primop-id (call-primop call))
((call tail-call)
(set-call-primop! call (get-primop (enum primop jump)))
(remove-call-arg call 0))
(else
(bug "odd call primop ~S" (call-primop call)))))
; Change a return to a jump. VAR is a variable bound to JUMP, the lambda
; being jumped to.
(define (return->jump call var jump)
(case (primop-id (call-primop call))
((return)
(set-call-primop! call (get-primop (enum primop jump)))
(replace (call-arg call 0) (make-reference-node var)))
(else
(bug "odd return primop ~S" (call-primop call)))))

224
ps-compiler/front/special.scm Normal file
View File

@ -0,0 +1,224 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; This file is obsolete and no longer used.
;----------------------------------------------------------------------------
; SPECIAL FORMS
;
; QUOTE CALL RETURN BLOCK LAMBDA LETREC
; + LET for reasons of type-checking
;
;----------------------------------------------------------------------------
(define-record-type quote-exp :quote-exp
(make-quote-exp value type)
quote-exp?
(value quote-exp-value)
(type quote-exp-type set-quote-exp-type!))
(define-record-type call-exp :call-exp
(make-call-exp! proc exits type args source)
call-exp?
(proc call-exp-proc)
(exits call-exp-exits)
(type call-exp-type set-call-exp-type!)
(args call-exp-args)
(source call-exp-source))
(define-record-type let-exp :let-exp
(make-let-exp vars vals body source)
let-exp?
(vars let-exp-vars)
(vals let-exp-vals)
(body let-exp-body set-let-exp-body!)
(source let-exp-source))
(define-record-type return-exp :return-exp
(make-return-exp protocol type args)
return-exp?
(protocol return-exp-protocol)
(type return-exp-type)
(args return-exp-args))
(define-record-type block-exp :block-exp
(make-block-exp exps)
block-exp?
(exps block-exp-exps))
(define-record-type lambda-exp :lambda-exp
(make-lambda-exp id return-type protocol vars body source)
lambda-exp?
(id lambda-exp-id)
(return-type lambda-exp-return-type set-lambda-exp-return-type!)
(protocol lambda-exp-protocol)
(vars lambda-exp-vars)
(body lambda-exp-body set-lambda-exp-body!)
(source lambda-exp-source))
(define (make-continuation-exp vars body)
(make-lambda-exp #f #f #f vars body #f))
(define-record-type letrec-exp :letrec-exp
(make-letrec-exp vars vals body source)
letrec-exp?
(vars letrec-exp-vars)
(vals letrec-exp-vals)
(body letrec-exp-body set-letrec-exp-body!)
(source letrec-exp-source))
(define-record-type external-value :external-value
(make-external-value type)
external-value?
(type external-value-type set-external-value-type!))
; Creating nodes and CPS converting calls and blocks.
;-------------------------------------------------------------------------------
; (CPS expression) => value + first-call + last-lambda
; = the value of the expression
; + the first of any calls that must be executed to get the value
; + the continuation lambda of the last of the necessary calls
; The first call and the last lambda will be #F if the value is trivial.
;
; (TAIL-CPS expression continuation-variable) => call
; = the first call to execute to return the value of the expression to
; the continuation variable
(define (cps exp)
(let ((value (cps-value exp)))
(if value
(values value #f #f)
(generic-cps exp #f))))
(define (tail-cps exp cont-var)
(receive (value type)
(cps-value+type exp)
(if value
(make-value-return cont-var value type)
(generic-cps exp cont-var))))
(define (cps-value exp)
(receive (value type)
(cps-value+type exp)
value))
(define (cps-value+type exp)
(cond ((variable? exp)
(values (make-reference-node exp) (variable-type exp)))
((quote-exp? exp)
(values (make-literal-node (quote-exp-value exp)
(quote-exp-type exp))
(quote-exp-type exp)))
((lambda-exp? exp)
(let ((node (lambda-exp->node exp)))
(values node (lambda-node-type node))))
(else
(values #f #f))))
(define (generic-cps exp cont-var)
(cond ((block-exp? exp)
(make-block (block-exp-exps exp) cont-var))
((return-exp? exp)
(make-return-call exp cont-var))
((call-exp? exp)
(make-primop-call exp cont-var))
((let-exp? exp)
(make-lambda-call exp cont-var))
((letrec-exp? exp)
(letrec-exp->node exp cont-var))
(else
(bug "unknown syntax~% ~S" exp))))
(define (lambda-exp->node exp)
(let* ((cvar (make-variable 'c (lambda-exp-return-type exp)))
(node (make-lambda-node (lambda-exp-id exp)
'proc
(cons cvar (copy-list (lambda-exp-vars exp))))))
(set-lambda-protocol! node (lambda-exp-protocol exp))
(set-lambda-source! node (lambda-exp-source exp))
(attach-body node (tail-cps (lambda-exp-body exp) cvar))
node))
(define (letrec-exp->node exp cont-var)
(let ((vals (map cps-value (letrec-exp-vals exp)))
(vars (letrec-exp-vars exp))
(cont (make-lambda-node 'c 'cont '())))
(let-nodes ((top (letrec1 1 l1))
(l1 ((x #f) . vars) call2)
(call2 (letrec2 1 cont (* x) . vals)))
(set-call-source! top (letrec-exp-source exp))
(happens-after top cont (letrec-exp-body exp) cont-var))))
; (CATCH id . body)
; (THROW primop rep id . args)
(define (make-undefined-value)
(make-quote-exp the-undefined-value #f))
(define (exp->s-exp exp)
(cond ((variable? exp)
(format #f "~S_~S" (variable-name exp) (variable-id exp)))
((quote-exp? exp)
(list 'quote (quote-exp-value exp)))
((block-exp? exp)
(cons 'begin (map exp->s-exp (block-exp-exps exp))))
((return-exp? exp)
(cons 'return (map exp->s-exp (return-exp-args exp))))
((call-exp? exp)
`(,(primop-id (call-exp-proc exp))
,(call-exp-exits exp)
. ,(map exp->s-exp (call-exp-args exp))))
((let-exp? exp)
`(let ,(map list
(map exp->s-exp (let-exp-vars exp))
(map exp->s-exp (let-exp-vals exp)))
,(exp->s-exp (let-exp-body exp))))
((lambda-exp? exp)
`(lambda ,(map exp->s-exp (lambda-exp-vars exp))
,(exp->s-exp (lambda-exp-body exp))))
((letrec-exp? exp)
`(letrec ,(map list
(map exp->s-exp (letrec-exp-vars exp))
(map exp->s-exp (letrec-exp-vals exp)))
,(exp->s-exp (letrec-exp-body exp))))
(else
(error '"unknown syntax~% ~S" exp))))
(define (exp-source exp)
(cond ((call-exp? exp)
(call-exp-source exp))
((let-exp? exp)
(let-exp-source exp))
((letrec-exp? exp)
(letrec-exp-source exp))
((lambda-exp? exp)
(lambda-exp-source exp))
(else
#f)))
(define (find-some-source top-exp exp)
(or (exp-source exp)
(call-with-current-continuation
(lambda (exit)
(let recur ((at top-exp))
(let ((hit? (cond ((eq? at exp)
#t)
((call-exp? at)
(or (recur (call-exp-proc at))
(any recur (call-exp-args at))))
((let-exp? at)
(or (recur (let-exp-body at))
(any recur (let-exp-vals at))))
((letrec-exp? at)
(or (recur (letrec-exp-body at))
(any recur (letrec-exp-vals at))))
((return-exp? at)
(any recur (return-exp-args at)))
((lambda-exp? at)
(recur (lambda-exp-body at)))
((block-exp? at)
(any recur (block-exp-exps at)))
(else #f))))
(if (and hit? (exp-source at))
(exit (exp-source at)))
hit?))))))

91
ps-compiler/front/top.scm Normal file
View File

@ -0,0 +1,91 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; Debugging aids
(define *bad-ids* '())
(define *all-procs?* #f)
(define *checkpoints* '())
(define all-checkpoints
'(node-made
simplify1
protocols
simplify2
node->vector
pre-simplify-proc
envs-added
))
(define (debug-breakpoint loc id data)
(if (and (memq? loc *checkpoints*)
(or (not id)
*all-procs?*
(memq? id *bad-ids*)))
(breakpoint "~S at ~S is ~S" id loc data)))
(define (add-checks . locs)
(receive (okay wrong)
(partition-list (lambda (l) (memq? l all-checkpoints))
locs)
(set! *checkpoints* (union okay *checkpoints*))
(for-each (lambda (l)
(format #t '"~&~S is not a checkpoint~%" l))
wrong)
*checkpoints*))
(define (clear-checks . locs)
(set! *checkpoints*
(if (null? locs)
'()
(set-difference *checkpoints* locs))))
(define (add-procs . locs)
(if (null? locs)
(set! *all-procs?* #t)
(set! *bad-ids* (union locs *bad-ids*))))
(define (clear-procs . locs)
(cond ((null? locs)
(set! *all-procs?* #f)
(set! *bad-ids* '()))
(else
(set! *bad-ids*
(if (null? locs)
'()
(set-difference *bad-ids* locs))))))
(define add-check add-checks)
(define clear-check clear-checks)
(define add-proc add-procs)
(define clear-proc clear-procs)
;------------------------------------------------------------------------------
(define *remove-cells?* #f)
(define *flow-values?* #f)
(define (simplify-all node id)
(debug-breakpoint 'node-made id node)
(simplify-node node)
(debug-breakpoint 'simplify1 id node)
(determine-protocols)
(debug-breakpoint 'protocols id node)
(if (integrate-jump-procs!)
(simplify-node node))
(cond (*remove-cells?*
(remove-cells-from-tree node (make-lambda-list))
(simplify-node node)))
(cond (*flow-values?*
(flow-values node (make-lambda-list))
(simplify-node node)))
(debug-breakpoint 'simplify2 id node)
(values))
(define (determine-protocols)
(walk-lambdas (lambda (l)
(cond ((and (eq? 'proc (lambda-type l))
(node? (node-parent l))
(find-calls l))
=> (lambda (calls)
(determine-lambda-protocol l calls)))))))

258
ps-compiler/interfaces.scm Normal file
View File

@ -0,0 +1,258 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
(define-interface utilities-interface
(export bug
user-error
user-warning
true false
or-map
remove-similar-elts
select-from-table
table->list table->entry-list
table-push table-pop
merge-lists
vector-every?
make-ignorable
sub-vector->list
flag-assq
enforce
writec
mem?
walk-vector
vector-replace
copy-list
copy-vector
symbol-hash
string-hash
char->ascii
object-hash
union intersection set-difference
make-xvector xvector-length xvector-ref xvector-set! xvector->vector
(define-subrecord :syntax)
;(define-simple-record-type :syntax)
(define-local-syntax :syntax)
))
(define-interface primop-interface
(export primop? make-primop make-proc-primop make-conditional-primop
all-primops get-primop
primop-id primop-trivial? primop-side-effects
primop-cost
simplify-call
primop-procedure? primop-call-index
primop-conditional?
expand-to-conditional
simplify-conditional?
primop-code-data set-primop-code-data!
trivial-call-return-type
(primop :syntax)
))
(define-interface variable-interface
(export variable? make-variable
global-variable? make-global-variable
variable-name set-variable-name!
variable-id
variable-type set-variable-type!
variable-binder set-variable-binder!
variable-refs set-variable-refs!
variable-flag set-variable-flag!
variable-flags set-variable-flags!
variable-generate set-variable-generate!
erase-variable
variable-index copy-variable used? unused?
variable-known-value
add-variable-known-value!
remove-variable-known-value!
variable-simplifier
add-variable-simplifier!
remove-variable-simplifier!
note-known-global-lambda!
))
(define-interface node-interface
(compound-interface
primop-interface
variable-interface
(export reset-node-id node-hash node-unhash
node? node-variant
node-parent set-node-parent!
node-index set-node-index!
node-simplified? set-node-simplified?!
node-flag set-node-flag!
empty empty? proclaim-empty
erase
detach detach-body
attach attach-body
move move-body
insert-body
replace replace-body
mark-changed
leaf-node?
literal-node? make-literal-node
literal-value set-literal-value!
literal-type set-literal-type!
copy-literal-node
reference-node? make-reference-node
reference-variable set-reference-variable!
call-node? make-call-node
call-primop set-call-primop!
call-args set-call-args!
call-exits set-call-exits!
call-source set-call-source!
call-arg call-arg-count
lambda-node? make-lambda-node
lambda-body set-lambda-body!
lambda-variables set-lambda-variables!
lambda-name set-lambda-name!
lambda-id
lambda-type
lambda-block set-lambda-block!
lambda-env set-lambda-env!
lambda-protocol set-lambda-protocol!
lambda-source set-lambda-source!
lambda-variable-count
calls-known? set-calls-known?!
proc-lambda?
initialize-lambdas add-lambda add-lambdas
change-lambda-type
walk-lambdas make-lambda-list
loc/owner loc/type loc/rep
set/owner set/type set/rep set/value
node-base containing-procedure
trivial? nontrivial?
nontrivial-ancestor
calls-this-primop?
bound-to-variable
walk-refs-safely
small-node?
side-effects?
called-node? called-node
called-lambda
get-lambda-value
;set-reference?
attach-call-args remove-call-args replace-call-args
remove-null-arguments
shorten-call-args insert-call-arg remove-call-arg
append-call-arg
remove-body
put-in-letrec
remove-lambda-variable remove-variable remove-unused-variables
substitute substitute-vars-in-node-tree
replace-call-with-value
copy-node-tree
mark-ancestors marked-ancestor? unmarked-ancestor?
node-ancestor? marked-ancestor least-common-ancestor
proc-ancestor
hoistable-node?
find-scoping
(let-nodes :syntax)
node-equal?
no-free-references?
find-calls
node-type
the-undefined-value
undefined-value?
undefined-value-node?
make-undefined-literal
)))
(define-interface simplify-internal-interface
(export simplify-node
default-simplifier
simplify-arg
simplify-args
simplify-lambda-body
simplify-known-lambda
(pattern-simplifier :syntax)
simplify-allocation
simplify-known-call
simplify-known-tail-call
simplify-unknown-call
simplify-return
simplify-jump
; simplify-undefined-value
simplify-test expand-test simplify-test?
))
(define-interface front-debug-interface
(export debug-breakpoint
add-checks add-check clear-checks clear-check
add-procs add-proc clear-procs clear-proc))
(define-interface front-interface
(export simplify-all
integrate-jump-procs! ; for debugging
))
(define-interface annotated-read-interface
(export read-and-annotate
pair-annotation
annotated-cons
annotation?
annotation-file
annotation-form
annotation-row
annotation-column
))
(define-interface compiler-byte-vector-interface
(export make-byte-vector byte-vector? byte-vector-length
byte-vector-ref byte-vector-word-ref byte-vector-half-word-ref
byte-vector-set! byte-vector-word-set! byte-vector-half-word-set!
byte-vector-endianess set-byte-vector-endianess!
))
(define-interface parameter-interface
(export lookup-primop
lookup-imported-variable
type/unknown
type-eq?
lambda-node-type
true-value
false-value
determine-lambda-protocol
determine-continuation-protocol
))

40
ps-compiler/load-ps-compiler.scm Normal file
View File

@ -0,0 +1,40 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; -*- Mode: Scheme; -*-
; To load the Pre-Scheme compiler into Scheme 48:
; ,exec ,load load-ps-compiler.scm
; It needs a larger than default sized heap. 4000000 is big enough to
; load the pre-scheme compiler but not big enough to compile the VM,
; 12000000 is enough to compile the VM.
;
; compile-vm.exec is an exec script to compile the Scheme 48 virtual machine.
;
; This requires that Pre-Scheme already be loaded.
(user '(run (let ((minor-number (call-with-input-file
"minor-version-number"
(lambda (in)
(read in)))))
(newline)
(newline)
(display "Pre-Scheme compiler version 0.")
(display minor-number)
(newline)
(display "Copyright (c) 1994-1999 by Richard Kelsey.")
(newline)
(display "Please report bugs to pre-scheme@martigny.ai.mit.edu.")
(newline)
(newline))))
(config)
(structure 'reflective-tower-maker
'(export-reflective-tower-maker))
(load "interfaces.scm")
(load "package-defs.scm")
(load "prescheme/interfaces.scm")
(load "prescheme/package-defs.scm")
(load-package 'let-nodes) ; used in FOR-SYNTAX
(load-package 'simp-patterns) ; used in FOR-SYNTAX
(load-package 'prescheme-compiler)

11
ps-compiler/load-scheme.scm Normal file
View File

@ -0,0 +1,11 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; Load the Scheme front-end
(config)
(load "interfaces.scm")
(load "package-defs.scm")
(load "scheme-to-c/package-defs.scm")
(load-package 'let-nodes) ; used in FOR-SYNTAX
(load-package 'simp-patterns) ; used in FOR-SYNTAX
(load-package 'scheme-test)

1
ps-compiler/minor-version-number Normal file
View File

@ -0,0 +1 @@
5

40
ps-compiler/node/arch.scm Normal file
View File

@ -0,0 +1,40 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; These are all of the primitives that are known to the compiler.
; The enumeration is needed by the expander for LET-NODES so it ends up
; being loaded into two separate packages.
(define-enumeration primop
(
; Nontrivial Primops
call ; see below
tail-call
return
jump
throw
unknown-call
unknown-tail-call
unknown-return
dispatch ; (dispatch <cont1> ... <contN> <exp>)
let ; (let <lambda-node> . <args>)
letrec1 ; (letrec1 (lambda (x v1 v2 ...)
letrec2 ; (letrec2 <cont> x <lambda1> <lambda2> ...)))
cell-set!
global-set!
undefined-effect ; (undefined-effect . <maybe-args>)
; Trivial Primops
make-cell
cell-ref
global-ref
; Environment stuff, these are both trivial
closure
env-ref
))

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