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

scsh 0.4.x prerelease

This commit is contained in:
bdc 1995-10-14 03:34:21 +00:00
parent 2302efe24e
commit e5a2148d4a
320 changed files with 1 additions and 44558 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

106
.gdbinit
View File

@ -1,106 +0,0 @@
#
# 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:4831
#display/i $pc
define scsh
run -o ./scshvm -i ./scsh/scsh.image
end
#
document scsh
For testing scsh -bri
end
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

0
.notify
View File

120
INSTALL
View File

@ -1,120 +0,0 @@
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 scsh, 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'.

497
NEWS.s48-0.36
View File

@ -1,497 +0,0 @@
-*- Mode: Indented-text; -*-
Recent changes to Scheme 48.
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

263
TODO.s48-0.36
View File

@ -1,263 +0,0 @@
--*- Mode: Indented-text; -*-
Scheme 48: list of bugs and things to do.
Last update by JAR on 3 March 1994.
Run-time system bugs:
MAX and MIN don't do inexact contagion.
Compiler needs to treat calls with more than 63 arguments specially.
Compiler loses if a procedure has more than 254 literals. This
seems to happen a lot with enormous backquote forms, which really
do arise in practice (e.g. PSD, Hanson's macro expander, etc.).
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 ()))
The WITH-**PUT-FILE and CALL-WITH-**PUT-PORT procedures probably
close ports sooner than the Scheme reports think they ought to.
(They just do the obvious DYNAMIC-WIND.)
If (find-all-symbols) fails due to lack of space, it should GC and
retry (I think) (bug reported by Basile Starynkevitch, 7-21-93)
Programming environment:
Error checking for macro & special form syntax.
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
Put the inspector at its own command level, so that ^D after
errors puts you back in the inspector.
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.
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 features:
,more-threads command doesn't get defined (new bug in 0.26).
How about deleting entries from tables?
Non-blocking I/O for threads. I think access to Unix select() might
be sufficient (with pause() and sleep() as degenerate cases).
Look at concurrent ML source code, which gets this right.
RPC.
Add call/gcc (invokes the Gnu C compiler).
It would be nice if WITH-MULTITASKING returned whatever the thunk
returned.
,exit following ,start-threads causes a core dump.
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.
Make the number predicate instructions return #t when appropriate
for the built-in number stored object types (bignum, double,
ratnum).
Make the Unix standard error stream available as
(error-output-port)
FIND-ALL-X-RECORDS that finds all records with a particular value
in their first slot.
Documentation:
Olin's "cig" (C interface generator).
user-guide.txt should point to the existing lsc.ps?
(optimize auto-integrate) and ,load-package analysis.
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).
Threads, fluids, records, tables. [all in big-scheme.txt?]
Cleanup:
VM:
Revert to the old exception system: vector of handlers (not just a
single procedure), and each handler gets an exception code.
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.
Etc:
Start using a source control system (like rcs).
We ought to have a test system / validation suite.
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.

166
alt-packages.scm
View File

@ -1,166 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; This configuration file provides alternative implementations of the
; low, run-time, run-time-internals structures. Cf. the interface
; definitions in packages.scm.
; Run-time structures assumed to be inherited from somewhere: (none of
; these is used by the linker)
; conditions
; continuations
; display-conditions
; exceptions
; fluids-internal
; methods
; meta-methods
; interrupts
; low-level
; more-types
; number-i/o
; ports
; reading
; records-internal
; scheme-level-2-internal
; wind
; writing
; --------------------
; low
; Features, assumed inherited:
; ascii
; bitwise
; code-vectors
; features
; signals
; Unimplemented (you'll need a VM to do these):
; vm-exposure
; Defined in alt/low-packages.scm:
; escapes
; primitives
(define-structure scheme-level-0 scheme-level-0-interface
(open scheme))
(define-structure escapes escapes-interface ;cf. alt/low-packages.scm
(open scheme-level-2 define-record-types signals)
(files (alt escape)))
(define-structures ((low-level low-level-interface)
(source-file-names (export (%file-name% :syntax)))
(structure-refs (export (structure-ref :syntax))))
(open scheme-level-2 signals)
(files (alt low)))
(define-structure closures closures-interface
(open scheme-level-1 records)
(files (alt closure)))
(define-structure locations locations-interface
(open scheme-level-2 signals)
(files (alt locations)))
(define-structure loopholes (export (loophole :syntax))
(open scheme-level-2)
(files (alt loophole)))
(define-structure silly (export reverse-list->string)
(open scheme-level-1)
(files (alt silly)))
(define-structure write-images (export write-image)
(open scheme-level-2
tables ;Forward reference
features bitwise ascii enumerated
architecture
templates
closures
signals)
(files (link data)
(link transport)
(link write-image)))
; --------------------
; run-time (generally speaking, things needed by the linker)
; Same as in rts-packages.scm:
(define-structure architecture architecture-interface
(open scheme-level-1 signals enumerated)
(files (rts arch)))
; Use the non-bummed version!
(define-structure bummed-define-record-types define-record-types-interface
(open scheme-level-1 records)
(files (rts jar-defrecord)))
; Same as in rts-packages.scm:
(define-structure enumerated enumerated-interface
(open scheme-level-1 signals)
(files (rts enum)
(rts defenum scm)))
(define-structure fluids fluids-interface
(open scheme-level-1 signals)
(files (alt fluid)))
(define-structures ((scheme-level-2 scheme-level-2-interface)
(scheme-level-1 scheme-level-1-interface))
(open scheme))
(define-structure templates templates-interface
(open scheme-level-1)
(files (alt template)
(rts template)))
(define-structure util util-interface
(open scheme-level-1)
(files (rts util)))
(define-structure weak weak-interface
(open scheme-level-1 signals)
(files (alt weak)
(rts population)))
; --------------------
; run-time internals (generally speaking, things not needed by the linker)
; * = mentioned in more-packages.scm
; conditions
; continuations
; display-conditions
; * exceptions
; * fluids-internal
; methods
; meta-methods
; interrupts
; low-level
; more-types
; * number-i/o
; * ports
; * reading
; * records-internal
; scheme-level-2-internal
; * wind
; writing
(define-structure wind wind-interface
(open scheme-level-2)
(files (alt reroot)))
; --------------------
; These don't really belong here, but I sure don't know where they
; ought to go.
(define-structure environments (export *structure-ref)
(open ) ;Assume flatloading
(files (alt environments)))
; Procedure annotations
(define-structure annotations
(export annotate-procedure procedure-annotation)
(open scheme-level-1)
(files (alt annotate)))

13
alt/annotate.scm
View File

@ -1,13 +0,0 @@
; no copyright please, silly shell script
(define *annotations* '()
(define (annotate-procedure proc ann)
(let ((new (lambda args (apply proc args))))
(set! *annotations* (cons (cons new ann) *annotations*))
new))
(define (procedure-annotation proc)
(cond ((assq proc *annotations*) => cdr)
(else #f)))

69
alt/ascii.scm
View File

@ -1,69 +0,0 @@
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
;;;; Portable definitions of char->ascii and ascii->char
; Don't detabify this file!
; This module defines char->ascii and ascii->char in terms of
; char->integer and integer->char, with no assumptions about the encoding.
; Portable except maybe for the strings that contain tab, page, and
; carriage return characters. Those can be flushed if necessary.
(define ascii-limit 128)
(define ascii-chars
(let* ((ascii-chars (make-vector ascii-limit #f))
(unusual (lambda (s)
(if (or (not (= (string-length s) 1))
(let ((c (string-ref s 0)))
(or (char=? c #\space)
(char=? c #\newline))))
(error "unusual whitespace character lost" s)
s)))
(init (lambda (i s)
(do ((i i (+ i 1))
(j 0 (+ j 1)))
((= j (string-length s)))
(vector-set! ascii-chars i (string-ref s j))))))
(init 9 (unusual " ")) ;tab
(init 12 (unusual " ")) ;page
(init 13 (unusual " ")) ;carriage return
(init 10 (string #\newline))
(init 32 " !\"#$%&'()*+,-./0123456789:;<=>?")
(init 64 "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_")
(init 96 "`abcdefghijklmnopqrstuvwxyz{|}~")
ascii-chars))
(define (ascii->char n)
(or (vector-ref ascii-chars n)
(error "not a standard character's ASCII code" n)))
(define native-chars
(let ((end (vector-length ascii-chars)))
(let loop ((i 0)
(least #f)
(greatest #f))
(cond ((= i end)
(let ((v (make-vector (+ (- greatest least) 1) #f)))
(do ((i 0 (+ i 1)))
((= i end) (cons least v))
(let ((c (vector-ref ascii-chars i)))
(if c
(vector-set! v (- (char->integer c) least) i))))))
(else
(let ((c (vector-ref ascii-chars i)))
(if c
(let ((n (char->integer c)))
(loop (+ i 1)
(if least (min least n) n)
(if greatest (max greatest n) n)))
(loop (+ i 1) least greatest))))))))
(define (char->ascii char)
(or (vector-ref (cdr native-chars)
(- (char->integer char) (car native-chars)))
(error "not a standard character" char)))
(define ascii-whitespaces '(32 10 9 12 13)) ;space linefeed tab page return

58
alt/bitwise-tests.scm
View File

@ -1,58 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Lost: (ARITHMETIC-SHIFT 5 27) => -402653184 [wanted 671088640.]
; Lost: (ARITHMETIC-SHIFT 5 28) => 268435456 [wanted 1342177280.]
(define (testit name proc x y z)
(let ((result (proc x y)))
(if (not (= result z))
(begin (display "Lost: ")
(write `(,name ,x ,y))
(display " => ")
(write result)
(display " [wanted ")
(write z)
(display "]")
(newline)))))
(define most-positive-fixnum
(let ((n (arithmetic-shift 2 27))) (+ n (- n 1))))
(define (test-left-shifts x)
(let ((crossover (arithmetic-shift 2 27)))
(do ((y 0 (+ y 1))
(z x (* z (if (>= z crossover) 2. 2))))
((= y 34))
(testit 'arithmetic-shift arithmetic-shift x y z))))
(test-left-shifts 5)
(test-left-shifts -5)
(define (test-right-shifts x)
(do ((y 0 (- y 1))
(z x (quotient z 2)))
((= y -34))
(testit 'arithmetic-shift arithmetic-shift x y z)))
(test-right-shifts (* 5 (expt 2 36)))
(test-right-shifts (* -5 (expt 2 36)))
(define (bit1? x)
(if (< x 0)
(even? (quotient (- -1 x) 2))
(odd? (quotient x 2))))
(define (try-truth-table name proc predicate)
(do ((x -4 (+ x 1)))
((= x 4))
(do ((y -4 (+ y 1)))
((= y 4))
(testit name proc x y
(+ (if (predicate (odd? x) (odd? y)) 1 0)
(if (predicate (bit1? x) (bit1? y)) 2 0)
(if (predicate (negative? x) (negative? y)) -4 0))))))
(try-truth-table 'bitwise-and bitwise-and (lambda (a b) (and a b)))
(try-truth-table 'bitwise-ior bitwise-ior (lambda (a b) (or a b)))

44
alt/bitwise.scm
View File

@ -1,44 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Bitwise operators written in vanilla Scheme.
; Written for clarity and simplicity, not for speed.
; No need to use these in Scheme 48 since Scheme 48's virtual machine
; provides fast machine-level implementations.
(define (bitwise-not i)
(- -1 i))
(define (bitwise-and x y)
(cond ((= x 0) 0)
((= x -1) y)
(else
(+ (* (bitwise-and (arithmetic-shift x -1)
(arithmetic-shift y -1))
2)
(* (modulo x 2) (modulo y 2))))))
(define (bitwise-ior x y)
(bitwise-not (bitwise-and (bitwise-not x)
(bitwise-not y))))
(define (bitwise-xor x y)
(bitwise-and (bitwise-not (bitwise-and x y))
(bitwise-ior x y)))
(define (bitwise-eqv x y)
(bitwise-not (bitwise-xor x y)))
(define (arithmetic-shift n m)
(floor (* n (expt 2 m))))
(define (count-bits x) ; Count 1's in the positive 2's comp rep
(let ((x (if (< x 0) (bitwise-not x) x)))
(do ((x x (arithmetic-shift x 1))
(result 0 (+ result (modulo x 2))))
((= x 0) result))))
;(define (integer-length integer) ...) ;?

11
alt/closure.scm
View File

@ -1,11 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Closures
(define closure-rtd (make-record-type 'closure '(template env)))
(define closure? (record-predicate closure-rtd))
(define make-closure (record-constructor closure-rtd '(template env)))
(define closure-template (record-accessor closure-rtd 'template))
(define closure-env (record-accessor closure-rtd 'env))

19
alt/code-vector.scm
View File

@ -1,19 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Code-vectors implemented as vectors.
(define *code-vector-marker* (list '*code-vector-marker*))
(define (make-code-vector len init)
(let ((t (make-vector (+ len 1) init)))
(vector-set! t 0 *code-vector-marker*)
t))
(define (code-vector? obj)
(and (vector? obj)
(> (vector-length obj) 0)
(eq? (vector-ref obj 0) *code-vector-marker*)))
(define (code-vector-length t) (- (vector-length t) 1))
(define (code-vector-ref t i) (vector-ref t (+ i 1)))
(define (code-vector-set! t i x) (vector-set! t (+ i 1) x))

192
alt/config.scm
View File

@ -1,192 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Stub support for DEFINE-PACKAGE and DEFINE-INTERFACE macros.
; Interfaces are ignored. Only dependencies are significant.
(define (load-configuration filename . rest)
(let ((save filename))
(dynamic-wind (lambda () (set! *source-file-name* filename))
(lambda ()
(apply load filename rest))
(lambda () (set! *source-file-name* save)))))
(define (%file-name%) *source-file-name*)
(define *source-file-name* "")
; This is used to generate file lists that are "included" in "makefiles."
(define (write-file-names target . stuff)
(call-with-output-file target
(lambda (port)
(display "Writing ") (display target) (newline)
(display "#### This file was generated automatically. ####"
port)
(newline port)
(let ((mumble (lambda (name filenames)
(newline port)
(display name port)
(display " = " port)
(for-each (lambda (filename)
(display filename port)
(display " " port))
filenames)
(newline port))))
(do ((stuff stuff (cddr stuff)))
((null? stuff))
(mumble (car stuff) (cadr stuff)))
;(mumble 'all-files (reverse *all-files*))
))))
; --------------------
(define (make-indirect-interface name thunk)
(thunk))
(define (make-simple-interface name items)
(cons 'export items))
(define (make-compound-interface name . sigs)
(cons 'compound-interface sigs))
; Structures are views into packages.
; In this implementation, interface information is completely ignored.
(define-syntax make-structure
(syntax-rules ()
((make-structure ?package ?interface ?name)
(vector '<structure> ?name ?package))
((make-structure ?package ?interface)
(make-structure ?package ?interface #f))))
(define (structure-name s) (vector-ref s 1))
(define (structure-package s) (vector-ref s 2))
(define (verify-later! thunk) 'lose)
;(define *all-files* '())
; Packages are not what they appear to be.
(define (make-a-package opens-thunk accesses-thunk tower
file-name clauses name)
(vector '<a-package>
(delay (opens-thunk))
(delay (accesses-thunk))
file-name
clauses
#f))
(define (package-opens p) (force (vector-ref p 1)))
(define (package-accesses p) (force (vector-ref p 2)))
(define (package-file-name p) (vector-ref p 3))
(define (package-clauses p) (vector-ref p 4))
(define (package-loaded? p) (vector-ref p 5))
(define (set-package-loaded?! p ?) (vector-set! p 5 ?))
(define dummy-package
(make-a-package (lambda () '()) (lambda () '()) #f "" '() #f))
; source-file-names ?
(define module-system (make-structure dummy-package #f 'module-system))
(define scheme (make-structure dummy-package #f 'scheme))
(define built-in-structures
(make-structure dummy-package #f 'built-in-structures))
(define (note-name! thing name)
thing)
; Handy
(define (setdiff l1 l2)
(cond ((null? l2) l1)
((null? l1) l1)
((member (car l1) l2)
(setdiff (cdr l1) l2))
(else (cons (car l1)
(setdiff (cdr l1) l2)))))
; Stuff copied from rts/filename.scm... ugh...
; Namelist = ((dir ...) basename type)
; or ((dir ...) basename)
; or (dir basename type)
; or (dir basename)
; or basename
(define (namestring namelist dir default-type)
(let ((namelist (if (list? namelist) namelist (list '() namelist))))
(let ((subdirs (if (list? (car namelist))
(car namelist)
(list (car namelist))))
(basename (cadr namelist))
(type (if (null? (cddr namelist))
default-type
(caddr namelist))))
(string-append (or dir "")
(apply string-append
(map (lambda (subdir)
(string-append
(namestring-component subdir)
directory-component-separator))
subdirs))
(namestring-component basename)
(if type
(string-append type-component-separator
(namestring-component type))
"")))))
(define directory-component-separator "/") ;unix sux
(define type-component-separator ".")
(define (namestring-component x)
(cond ((string? x) x)
((symbol? x)
(list->string (map file-name-preferred-case
(string->list (symbol->string x)))))
(else
;; (error "bogus namelist component" x)
"bogus namelist component")))
(define file-name-preferred-case char-downcase)
(define *scheme-file-type* 'scm)
(define *load-file-type* *scheme-file-type*) ;#F for Pseudoscheme or T
(define (file-name-directory filename)
(substring filename 0 (file-nondirectory-position filename)))
(define (file-name-nondirectory filename)
(substring filename
(file-nondirectory-position filename)
(string-length filename)))
(define (file-nondirectory-position filename)
(let loop ((i (- (string-length filename) 1)))
(cond ((< i 0) 0)
;; Heuristic. Should work for DOS, Unix, VMS, MacOS.
((string-posq (string-ref filename i) "/:>]\\") (+ i 1))
(else (loop (- i 1))))))
(define (string-posq thing s)
(let loop ((i 0))
(cond ((>= i (string-length s)) #f)
((eq? thing (string-ref s i)) i)
(else (loop (+ i 1))))))
; Types
(define :value ':value)
(define :syntax ':syntax)
(define :structure ':structure)
(define :procedure ':procedure)
(define :number ':number)
(define-reflective-tower-maker list)

20
alt/contin.scm
View File

@ -1,20 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Continuations implemented as vectors.
(define *continuation-marker* (list '*continuation-marker*))
(define (make-continuation len init)
(let ((c (make-vector (+ len 1) init)))
(vector-set! c 0 *continuation-marker*)
c))
(define (continuation? obj)
(and (vector? obj)
(> (vector-length obj) 0)
(eq? (vector-ref obj 0) *continuation-marker*)))
(define (continuation-length c) (- (vector-length c) 1))
(define (continuation-ref c i) (vector-ref c (+ i 1)))
(define (continuation-set! c i x) (vector-set! c (+ i 1) x))

6
alt/environments.scm
View File

@ -1,6 +0,0 @@
; don't put a copyright notice, silly shell script
(define (*structure-ref struct name)
(eval name (interaction-environment)))

32
alt/escape.scm
View File

@ -1,32 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; For an explanation, see comments in rts/low.scm.
; The debugger invokes EXTRACT-CONTINUATION on a "native" continuation
; as obtained by PRIMITIVE-CWCC in order to get a VM continuation.
; The distinction between native and VM continuations is useful when
; debugging a program running under a VM that's different from
; whatever machine is running the debugger.
(define-record-type escape :escape
(make-escape proc)
(proc escape-procedure))
(define (with-continuation esc thunk)
(if esc
((escape-procedure esc) thunk)
(let ((answer (thunk)))
(signal 'vm-return answer) ;#f means halt
(call-error "halt" answer))))
(define (primitive-cwcc proc)
(call-with-current-continuation
(lambda (done)
((call-with-current-continuation
(lambda (k)
(call-with-values
(lambda ()
(proc (make-escape k)))
done)))))))

29
alt/features-packages.scm
View File

@ -1,29 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; The following several packages have Scheme-implementation-specific
; variants that are much better for one reason or another than
; the generic versions defined here.
(define-structures ((signals signals-interface)
(handle (export ignore-errors))
(features features-interface))
(open scheme-level-2)
(files features))
(define-structure records records-interface
(open scheme-level-2 signals)
(files record))
(define-structure ascii (export ascii->char char->ascii)
(open scheme-level-2 signals)
(files ascii))
(define-structure bitwise bitwise-interface
(open scheme-level-2 signals)
(files bitwise))
(define-structure code-vectors code-vectors-interface
(open scheme-level-1)
(files code-vectors))

58
alt/features.scm
View File

@ -1,58 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; This is file features.scm.
; Synchronize any changes with all the other *-features.scm files.
; These definitions should be quite portable to any Scheme implementation.
; Assumes Revised^5 Report Scheme, for EVAL and friends.
; SIGNALS
(define (error message . irritants)
(display-error-message "Error: " message irritants)
(an-error-occurred-now-what?))
(define (warn message . irritants)
(display-error-message "Warning: " message irritants))
(define (display-error-message heading message irritants)
(display heading)
(display message)
(newline)
(let ((spaces (list->string
(map (lambda (c) #\space) (string->list heading)))))
(for-each (lambda (irritant)
(display spaces)
(write irritant)
(newline))
irritants)))
; Linker also needs SIGNAL, SYNTAX-ERROR, CALL-ERROR
; HANDLE
(define (ignore-errors thunk)
'(error "ignore-errors isn't implemented"))
; FEATURES
(define (force-output port) #f)
(define (string-hash s)
(let ((n (string-length s)))
(do ((i 0 (+ i 1))
(h 0 (+ h (char->ascii (string-ref s i)))))
((>= i n) h))))
(define (make-immutable! thing) #f)
(define (immutable? thing) #f)
(define (unspecific) (if #f #f))
; BITWISE -- use alt/bitwise.scm (!)
; ACII -- use alt/ascii.scm
; CODE-VECTORS -- use alt/code-vectors.scm

33
alt/fluid.scm
View File

@ -1,33 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Fluid variables
(define (make-fluid val)
(vector '<fluid> val))
(define (fluid f) (vector-ref f 1))
(define (set-fluid! f val)
(vector-set! f 1 val))
(define (let-fluid f val thunk)
(let ((swap (lambda () (let ((temp (fluid f)))
(set-fluid! f val)
(set! val temp)))))
(dynamic-wind swap thunk swap)))
(define (let-fluids . args) ;Kind of gross
(let loop ((args args)
(swap (lambda () #f)))
(if (null? (cdr args))
(dynamic-wind swap (car args) swap)
(loop (cddr args)
(let ((f (car args))
(val (cadr args)))
(lambda ()
(swap)
(let ((temp (fluid f)))
(set-fluid! f val)
(set! val temp))))))))

14
alt/init-defpackage.scm
View File

@ -1,14 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; This file should be loaded into the bootstrap linker before any use
; of DEFINE-STRUCTURE. Compare with env/init-defpackage.scm.
(define-reflective-tower-maker
(lambda (clauses names)
(let ((env (interaction-environment)))
(delay
(begin (if (not (null? clauses))
(warn "a FOR-SYNTAX clause appears in a package being linked by the cross-linker"
`(for-syntax ,@clauses)))
(cons eval env))))))

30
alt/locations.scm
View File

@ -1,30 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Locations
(define location-rtd
(make-record-type 'location '(id defined? contents)))
(define-record-discloser location-rtd
(lambda (l) `(location ,(location-id l))))
(define make-undefined-location
(let ((make (record-constructor location-rtd
'(id defined? contents))))
(lambda (id)
(make id #f '*empty*))))
(define location? (record-predicate location-rtd))
(define location-id (record-accessor location-rtd 'id))
(define location-defined? (record-accessor location-rtd 'defined?))
(define contents (record-accessor location-rtd 'contents))
(define set-defined?! (record-modifier location-rtd 'defined?))
(define (set-location-defined?! loc ?)
(set-defined?! loc ?)
(if (not ?)
(set-contents! loc '*empty*)))
(define set-contents! (record-modifier location-rtd 'contents))

9
alt/loophole.scm
View File

@ -1,9 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
(define-syntax loophole
(syntax-rules ()
((loophole ?type ?form)
(begin (lambda () ?type) ;Elicit unbound-variable warnings, etc.
?form))))

26
alt/low-packages.scm
View File

@ -1,26 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Alternate implementations of the low-structures.
; Cf. low-structures-interface in ../packages.scm and ../alt-structures.scm.
; Most of the low-structures are assumed to be inherited or obtained
; elsewhere (probably from a running Scheme 48). This only defines
; structures that export privileged operations.
(define-structure escapes escapes-interface
(open scheme-level-2 define-record-types signals)
(files escape))
(define-structures ((primitives primitives-interface)
(primitives-internal (export maybe-handle-interrupt
raise-exception
get-exception-handler
?start)))
(open scheme-level-2
bitwise define-record-types
features
signals
templates)
(files primitives
weak
contin))

25
alt/low.scm
View File

@ -1,25 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Portable versions of low-level things that would really like to rely
; on the Scheme 48 VM or on special features provided by the byte code
; compiler.
(define (vector-unassigned? v i) #f)
(define (flush-the-symbol-table!) #f)
(define maybe-open-input-file open-input-file)
(define maybe-open-output-file open-output-file)
; Suppress undefined export warnings.
(define-syntax %file-name%
(syntax-rules ()
((%file-name%) "")))
(define-syntax structure-ref
(syntax-rules ()
((structure-ref ?struct ?name)
(error "structure-ref isn't implemented" '?struct '?name))))

175
alt/primitives.scm
View File

@ -1,175 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Alternate implementation of PRIMITIVES module.
(define underlying-error error)
(define (unspecific) (if #f #f))
; Records
(define-record-type new-record :new-record
(make-new-record fields)
record?
(fields new-record-fields))
(define (make-record size init)
(make-new-record (make-vector size init)))
(define (record-ref r i)
(vector-ref (new-record-fields r) i))
(define (record-set! r i value)
(vector-set! (new-record-fields r) i value))
(define (record-length r)
(vector-length (new-record-fields r)))
; Extended numbers
(define-record-type new-extended-number :new-extended-number
(make-new-extended-number fields)
extended-number?
(fields new-extended-number-fields))
(define-record-discloser :new-extended-number
(lambda (n) `(extended-number ,(new-extended-number-fields n))))
(define (make-extended-number size init)
(make-new-extended-number (make-vector size init)))
(define (extended-number-ref n i)
(vector-ref (new-extended-number-fields n) i))
(define (extended-number-set! n i value)
(vector-set! (new-extended-number-fields n) i value))
(define (extended-number-length n)
(vector-length (new-extended-number-fields n)))
; Dynamic state (= current thread)
(define *dynamic-state* 'uninitialized-dynamic-state)
(define (get-dynamic-state) *dynamic-state*)
(define (set-dynamic-state! state)
(if (not (and (record? state)
(list? (record-ref state 1))))
(underlying-error "invalid dynamic state" state))
(set! *dynamic-state* state))
; Etc.
(define (close-port port)
((if (input-port? port) close-input-port close-output-port)
port))
(define (write-string s port)
(display s port))
(define (schedule-interrupt interval)
(if (not (= interval 0))
(warn "ignoring schedule-interrupt" interval)))
(define *pseudo-enabled-interrupts* 0)
(define (set-enabled-interrupts! ei)
(let ((previous *pseudo-enabled-interrupts*))
(set! *pseudo-enabled-interrupts* ei)
;; (if (bitwise-and *pseudo-pending-interrupts* ei) ...)
previous))
(define *pseudo-pending-interrupts* 0)
(define *pseudo-exception-handler* #f)
(define (set-exception-handler! h)
(set! *pseudo-exception-handler* h))
(define *pseudo-interrupt-handlers* #f)
(define (set-interrupt-handlers! v)
(set! *pseudo-interrupt-handlers* v))
(define (unimplemented name)
(lambda args (underlying-error "unimplemented primitive" name args)))
(define collect (unimplemented 'collect))
(define external-call (unimplemented 'external-call))
(define external-lookup (unimplemented 'external-lookup))
(define external-name (unimplemented 'external-name))
(define external-value (unimplemented 'external-value))
(define (external? x) #f)
(define find-all-xs (unimplemented 'find-all-xs))
(define make-external (unimplemented 'make-external))
(define vm-extension (unimplemented 'vm-extension))
(define (memory-status which arg)
(case which
((2) 100)
((3) (display "(Ignoring set-minimum-recovered-space!)") (newline))
(else (underlying-error "unimplemented memory-status" which arg))))
(define (time which arg)
(case which
((0) 1000)
(else (underlying-error "unimplemented time" which arg))))
; end of definitions implementing PRIMITIVES structure
; --------------------
; Auxiliary crud.
(define (maybe-handle-interrupt which)
;; Should actually do (get-highest-priority-interrupt!) ...
(let ((bit (arithmetic-shift 1 which)))
(cond ((= (bitwise-and *pseudo-enabled-interrupts* bit) 0)
(set! *pseudo-pending-interrupts*
(bitwise-ior *pseudo-pending-interrupts* bit))
(display "(Interrupt deferred)")
(newline)
#f)
(else
(set! *pseudo-pending-interrupts*
(bitwise-and *pseudo-pending-interrupts*
(bitwise-not bit)))
(display "(Handling interrupt)")
(newline)
((vector-ref *pseudo-interrupt-handlers* which)
(set-enabled-interrupts! 0))
#t))))
(define (raise-exception opcode arguments)
(apply (get-exception-handler)
opcode
arguments))
(define (get-exception-handler)
*pseudo-exception-handler*)
(define (clear-registers!)
(set! *dynamic-state* 'uninitialized-dynamic-state)
(set! *pseudo-enabled-interrupts* 0)
(set! *pseudo-interrupt-handlers* #f)
(set! *pseudo-exception-handler* #f))
(define *vm-return* #f)
(define (vm-return . rest)
(if *vm-return*
(apply *vm-return* rest)
(underlying-error "vm-return" rest)))
(define (?start entry-point arg) ;E.g. (?start (usual-resumer bare) 0)
(clear-registers!)
(call-with-current-continuation
(lambda (k)
(set! *vm-return* k)
(entry-point arg
(current-input-port)
(current-output-port)))))

120
alt/pseudoscheme-features.scm
View File

@ -1,120 +0,0 @@
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; This is file pseudoscheme-features.scm.
; Synchronize any changes with all the other *-features.scm files.
(define *load-file-type* #f) ;For fun
; SIGNALS
(define error #'ps:scheme-error)
(define warn #'ps:scheme-warn)
(define (signal type . stuff)
(apply warn "condition signalled" type stuff))
(define (syntax-error . rest) ; Must return a valid expression.
(apply warn rest)
''syntax-error)
(define (call-error message proc . args)
(error message (cons proc args)))
; HANDLE
(define (ignore-errors thunk)
#-Lucid
'(error "ignore-errors isn't implemented") ;No big deal if it doesn't work.
#+Lucid
(let ((result (lcl:ignore-errors (thunk))))
(lisp:if (lisp:typep result 'lcl:condition)
(list 'error result)
result)))
; FEATURES
(define force-output #'lisp:force-output)
(define (string-hash s)
(let ((n (string-length s)))
(do ((i 0 (+ i 1))
(h 0 (+ h (lisp:char-code (string-ref s i)))))
((>= i n) h))))
(define (make-immutable! thing) #f)
(define (immutable? thing) #f)
(define (unspecific) (if #f #f))
; BITWISE
(define arithmetic-shift #'lisp:ash)
(define bitwise-and #'lisp:logand)
(define bitwise-ior #'lisp:logior)
; ASCII
(define char->ascii #'lisp:char-code)
(define ascii->char #'lisp:code-char)
; CODE-VECTORS
(define (make-code-vector len . fill-option)
(lisp:make-array len :element-type '(lisp:unsigned-byte 8)
:initial-element (if (null? fill-option)
0
(car fill-option))))
(define (code-vector? obj)
(ps:true? (lisp:typep obj
(lisp:quote (lisp:simple-array (lisp:unsigned-byte 8)
(lisp:*))))))
(define (code-vector-ref bv k)
(lisp:aref (lisp:the (lisp:simple-array (lisp:unsigned-byte 8) (lisp:*))
bv)
k))
(define (code-vector-set! bv k val)
(lisp:setf (lisp:aref (lisp:the (lisp:simple-array (lisp:unsigned-byte 8)
(lisp:*))
bv)
k)
val))
(define (code-vector-length bv)
(lisp:length (lisp:the (lisp:simple-array (lisp:unsigned-byte 8) (lisp:*))
bv)))
; The rest is unnecessary in Pseudoscheme versions 2.8d and after.
;(define eval #'schi:scheme-eval)
;(define (interaction-environment) schi:*current-rep-environment*)
;(define scheme-report-environment
; (let ((env (scheme-translator:make-program-env
; 'rscheme
; (list scheme-translator:revised^4-scheme-module))))
; (lambda (n)
; n ;ignore
; env)))
; Dynamic-wind.
;
;(define (dynamic-wind in body out)
; (in)
; (lisp:unwind-protect (body)
; (out)))
;
;(define values #'lisp:values)
;
;(define (call-with-values thunk receiver)
; (lisp:multiple-value-call receiver (thunk)))

18
alt/pseudoscheme-record.scm
View File

@ -1,18 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
(define make-record-type #'scheme-translator::make-record-type)
(define record-constructor #'scheme-translator::record-constructor)
(define record-accessor #'scheme-translator::record-accessor)
(define record-modifier #'scheme-translator::record-modifier)
(define record-predicate #'scheme-translator::record-predicate)
(define define-record-discloser #'scheme-translator::define-record-discloser)
(define record-type? #'scheme-translator::record-type-descriptor-p)
(define record-type-field-names #'scheme-translator::rtd-field-names)
(define record-type-name #'scheme-translator::rtd-identification)
; Internal record things, for inspector or whatever
(define disclose-record #'scheme-translator::disclose-record)
(define record-type #'scheme-translator::record-type)
(define (record? x) (if (scheme-translator::record-type x) #t #f))

28
alt/queue.scm
View File

@ -1,28 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Queues
(define (make-queue)
(cons '() '()))
(define (queue-empty? q)
(and (null? (car q))
(null? (cdr q))))
(define (enqueue q obj)
(set-car! q (cons obj (car q))))
(define (dequeue q)
(normalize-queue! q)
(let ((head (car (cdr q))))
(set-cdr! q (cdr (cdr q)))
head))
(define (normalize-queue! q)
(if (null? (cdr q))
(begin (set-cdr! q (reverse (car q)))
(set-car! q '()))))
(define (queue-head q)
(normalize-queue! q)
(car (cdr q)))

96
alt/record.scm
View File

@ -1,96 +0,0 @@
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; This is file record.scm.
;;;; Records
; This is completely vanilla Scheme code. Should work anywhere.
(define (make-record-type type-id field-names)
(define unique (list type-id))
(define size (+ (length field-names) 1))
(define (constructor . names-option)
(let* ((names (if (null? names-option)
field-names
(car names-option)))
(number-of-inits (length names))
(indexes (map field-index names)))
(lambda field-values
(if (= (length field-values) number-of-inits)
(let ((record (make-vector size 'uninitialized)))
(vector-set! record 0 unique)
(for-each (lambda (index value)
(vector-set! record index value))
indexes
field-values)
record)
(error "wrong number of arguments to record constructor"
field-values type-id names)))))
(define (predicate obj)
(and (vector? obj)
(= (vector-length obj) size)
(eq? (vector-ref obj 0) unique)))
(define (accessor name)
(let ((i (field-index name)))
(lambda (record)
(if (predicate record) ;Faster: (eq? (vector-ref record 0) unique)
(vector-ref record i)
(error "invalid argument to record accessor"
record type-id name)))))
(define (modifier name)
(let ((i (field-index name)))
(lambda (record new-value)
(if (predicate record) ;Faster: (eq? (vector-ref record 0) unique)
(vector-set! record i new-value)
(error "invalid argument to record modifier"
record type-id name)))))
(define (field-index name)
(let loop ((l field-names) (i 1))
(if (null? l)
(error "bad field name" name)
(if (eq? name (car l))
i
(loop (cdr l) (+ i 1))))))
(define the-descriptor
(lambda (request)
(case request
((constructor) constructor)
((predicate) predicate)
((accessor) accessor)
((modifier) modifier)
((name) type-id)
((field-names) field-names))))
the-descriptor)
(define (record-constructor r-t . names-option)
(apply (r-t 'constructor) names-option))
(define (record-predicate r-t)
(r-t 'predicate))
(define (record-accessor r-t field-name)
((r-t 'accessor) field-name))
(define (record-modifier r-t field-name)
((r-t 'modifier) field-name))
(define (record-type-name r-t) (r-t 'name))
(define (record-type-field-names r-t) (r-t 'field-names))
(define (record-type? r-t)
(and (procedure? r-t)
(error "record-type? not implemented" r-t)))
(define (define-record-discloser r-t proc)
"ignoring define-record-discloser form")

54
alt/reroot.scm
View File

@ -1,54 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; A state space is a tree with the state at the root. Each node other
; than the root is a triple <before, after, parent>, represented in
; this implementation as a structure ((before . after) . parent).
; Moving from one state to another means re-rooting the tree by pointer
; reversal.
(define *here* (list #f))
(define original-cwcc call-with-current-continuation)
(define (call-with-current-continuation proc)
(let ((here *here*))
(original-cwcc (lambda (cont)
(proc (lambda results
(reroot! here)
(apply cont results)))))))
(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)))))
(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)))))
; -----
;
;(define r #f) (define s #f) (define (p x) (write x) (newline))
;(define (tst)
; (set! r *here*)
; (set! s (cons (cons (lambda () (p 'in)) (lambda () (p 'out))) *here*))
; (reroot! s))
;
;
;(define (check) ;Algorithm invariants
; (if (not (null? (cdr *here*)))
; (error "confusion #1"))
; (if (car *here*)
; (error "confusion #2")))

142
alt/schemetoc-features.scm
View File

@ -1,142 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; BUG: (+ (expt 2 28) (expt 2 28)), (* (expt 2 28) 2)
(define-external schemetoc-error ;(schemetoc-error symbol format-string . args)
"scdebug" "error_v")
(eval-when (eval)
(define schemetoc-error error))
; SIGNALS
(define (error message . irritants)
(if (symbol? message)
(apply schemetoc-error message irritants)
(apply schemetoc-error
"Error:"
(apply string-append
message
(map (lambda (x) "~% ~s")
irritants))
irritants)))
(define (warn message . irritants)
(display-error-message "Warning: " message irritants))
(define (display-error-message heading message irritants)
(display heading)
(display message)
(newline)
(let ((spaces (list->string
(map (lambda (c) #\space) (string->list heading)))))
(for-each (lambda (irritant)
(display spaces)
(write irritant)
(newline))
irritants)))
(define (signal type . stuff)
(apply warn "condition signalled" type stuff))
(define (syntax-error . rest) ; Must return a valid expression.
(apply warn rest)
''syntax-error)
(define (call-error message proc . args)
(error message (cons proc args)))
; HANDLE
;(define (ignore-errors thunk)
; (call-with-current-continuation
; (lambda (k)
; (let* ((save (lambda rest
; (k (cons 'error rest))))
; (swap (lambda ()
; (let ((temp *error-handler*))
; (set! *error-handler* save)
; (set! save temp)))))
; (dynamic-wind swap thunk swap)))))
; Joel Bartlett's rewrite, which doesn't elicit compiler bug.
(define (ignore-errors thunk)
(call-with-current-continuation
(lambda (k)
(let* ((save *error-handler*)
(on-error (lambda rest (k (cons 'error rest))))
(in (lambda () (set! *error-handler* on-error)))
(out (lambda () (set! *error-handler* save))))
(dynamic-wind in thunk out)))))
; FEATURES
(define force-output flush-buffer)
(define (string-hash s)
(let ((n (string-length s)))
(do ((i 0 (+ i 1))
(h 0 (+ h (char->ascii (string-ref s i)))))
((>= i n) h))))
(define (make-immutable! thing) #f)
(define (immutable? thing) #f)
(define (unspecific) (if #f #f))
; BITWISE
(define (arithmetic-shift x n)
(if (< x 0)
(let ((r (- -1 (arithmetic-shift (- -1 x) n))))
(if (> n 0)
(- r (- (arithmetic-shift 1 n) 1))
r))
(if (>= n 0) ;shift left?
(if (and (<= n 8)
(exact? x)
(< x 4194304))
(bit-lsh x n)
(* x (expt 2 n)))
(if (and (<= n 28) (exact? x))
(bit-rsh x (- n))
(floor (* x (expt 2. n)))))))
(define (bitwise-and x y)
(if (and (< x 0) (< y 0))
(- -1 (bit-or (- -1 x) (- -1 y)))
(bit-and x y)))
(define (bitwise-ior x y)
(if (or (< x 0) (< y 0))
(- -1 (bit-and (- -1 x) (- -1 y)))
(bit-or x y)))
; ASCII
(define char->ascii char->integer)
(define ascii->char integer->char)
; CODE-VECTORS (= alt/code-vectors.scm)
(define *code-vector-marker* (list '*code-vector-marker*))
(define (make-code-vector len init)
(let ((t (make-vector (+ len 1) init)))
(vector-set! t 0 *code-vector-marker*)
t))
(define (code-vector? obj)
(and (vector? obj)
(> (vector-length obj) 0)
(eq? (vector-ref obj 0) *code-vector-marker*)))
(define (code-vector-length t) (- (vector-length t) 1))
(define (code-vector-ref t i) (vector-ref t (+ i 1)))
(define (code-vector-set! t i x) (vector-set! t (+ i 1) x))

120
alt/schemetoc-record.scm
View File

@ -1,120 +0,0 @@
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; This is file schemetoc-record.scm.
; Synchronize any changes with the other *record.scm files.
;;;; Records
(define (make-record-type type-id field-names)
(define unique (lambda () the-descriptor))
(define size (+ (length field-names) 1))
(define (constructor . names-option)
(let* ((names (if (null? names-option)
field-names
(car names-option)))
(foo (cons unique
(map (lambda (name) 'uninitialized) field-names)))
(number-of-inits (length names))
(indexes (map field-index names)))
(lambda field-values
(if (= (length field-values) number-of-inits)
(let ((record (list->%record foo)))
(for-each (lambda (index value)
(%record-set! record index value))
indexes
field-values)
(%record-methods-set! record usual-record-methods)
record)
(error "wrong number of arguments to record constructor"
field-values type-id names)))))
(define (predicate obj)
(and (%record? obj)
(= (%record-length obj) size)
(eq? (%record-ref obj 0) unique)))
(define (accessor name)
(let ((i (field-index name)))
(lambda (record)
(if (predicate record) ;Faster: (eq? (%record-ref record 0) unique)
(%record-ref record i)
(error "invalid argument to record accessor"
record type-id name)))))
(define (modifier name)
(let ((i (field-index name)))
(lambda (record new-value)
(if (predicate record) ;Faster: (eq? (%record-ref record 0) unique)
(%record-set! record i new-value)
(error "invalid argument to record modifier"
record type-id name)))))
(define (field-index name)
(let loop ((l field-names) (i 1))
(if (null? l)
(error "bad field name" name)
(if (eq? name (car l))
i
(loop (cdr l) (+ i 1))))))
(define (discloser r) (list type-id))
(define the-descriptor
(lambda (request)
(case request
((constructor) constructor)
((predicate) predicate)
((accessor) accessor)
((modifier) modifier)
((identification) type-id)
((field-names) field-names)
((discloser) discloser)
((set-discloser!) (lambda (d) (set! discloser d))))))
the-descriptor)
(define (record-type x)
(if (%record? x)
(let ((probe (%record-ref x 0)))
(if (procedure? probe)
(probe)
#f))
#f))
(define (record-type-identification r-t)
(r-t 'identification))
(define (record-type-field-names r-t)
(r-t 'field-names))
(define (record-constructor r-t . names-option)
(apply (r-t 'constructor) names-option))
(define (record-predicate r-t)
(r-t 'predicate))
(define (record-accessor r-t field-name)
((r-t 'accessor) field-name))
(define (record-modifier r-t field-name)
((r-t 'modifier) field-name))
(define (define-record-discloser r-t proc)
((r-t 'set-discloser!) proc))
(define (disclose-record r)
(((record-type r) 'discloser) r))
(define usual-record-methods
(list (cons '%to-write
(lambda (r port indent levels length seen)
(write-char #\# port)
(write-char %record-prefix-char port)
(list (disclose-record r))))))
(set! %record-prefix-char #\~)

8
alt/silly.scm
View File

@ -1,8 +0,0 @@
(define (reverse-list->string l n)
;; Significantly faster than (list->string (reverse l))
(let ((s (make-string n #\x)))
(let loop ((i (- n 1)) (l l))
(if (< i 0) s (begin (string-set! s i (car l))
(loop (- i 1) (cdr l)))))))

204
alt/syntax.scm
View File

@ -1,204 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; This definition of define-syntax is appropriate for Scheme-to-C.
(define-macro define-syntax
(lambda (form expander)
(expander `(define-macro ,(cadr form)
(let ((transformer ,(caddr form)))
(lambda (form expander)
(expander (transformer form
(lambda (x) x)
eq?)
expander))))
expander)))
; Rewrite-rule compiler (a.k.a. "extend-syntax")
; Example:
;
; (define-syntax or
; (syntax-rules ()
; ((or) #f)
; ((or e) e)
; ((or e1 e ...) (let ((temp e1))
; (if temp temp (or e ...))))))
(define-syntax syntax-rules
(let ()
(define name? symbol?)
(define (segment-pattern? pattern)
(and (segment-template? pattern)
(or (null? (cddr pattern))
(syntax-error "segment matching not implemented" pattern))))
(define (segment-template? pattern)
(and (pair? pattern)
(pair? (cdr pattern))
(memq (cadr pattern) indicators-for-zero-or-more)))
(define indicators-for-zero-or-more (list (string->symbol "...") '---))
(lambda (exp r c)
(define %input (r '%input)) ;Gensym these, if you like.
(define %compare (r '%compare))
(define %rename (r '%rename))
(define %tail (r '%tail))
(define %temp (r '%temp))
(define rules (cddr exp))
(define subkeywords (cadr exp))
(define (make-transformer rules)
`(lambda (,%input ,%rename ,%compare)
(let ((,%tail (cdr ,%input)))
(cond ,@(map process-rule rules)
(else
(syntax-error
"use of macro doesn't match definition"
,%input))))))
(define (process-rule rule)
(if (and (pair? rule)
(pair? (cdr rule))
(null? (cddr rule)))
(let ((pattern (cdar rule))
(template (cadr rule)))
`((and ,@(process-match %tail pattern))
(let* ,(process-pattern pattern
%tail
(lambda (x) x))
,(process-template template
0
(meta-variables pattern 0 '())))))
(syntax-error "ill-formed syntax rule" rule)))
; Generate code to test whether input expression matches pattern
(define (process-match input pattern)
(cond ((name? pattern)
(if (member pattern subkeywords)
`((,%compare ,input (,%rename ',pattern)))
`()))
((segment-pattern? pattern)
(process-segment-match input (car pattern)))
((pair? pattern)
`((let ((,%temp ,input))
(and (pair? ,%temp)
,@(process-match `(car ,%temp) (car pattern))
,@(process-match `(cdr ,%temp) (cdr pattern))))))
((or (null? pattern) (boolean? pattern) (char? pattern))
`((eq? ,input ',pattern)))
(else
`((equal? ,input ',pattern)))))
(define (process-segment-match input pattern)
(let ((conjuncts (process-match '(car l) pattern)))
(if (null? conjuncts)
`((list? ,input)) ;+++
`((let loop ((l ,input))
(or (null? l)
(and (pair? l)
,@conjuncts
(loop (cdr l)))))))))
; Generate code to take apart the input expression
; This is pretty bad, but it seems to work (can't say why).
(define (process-pattern pattern path mapit)
(cond ((name? pattern)
(if (memq pattern subkeywords)
'()
(list (list pattern (mapit path)))))
((segment-pattern? pattern)
(process-pattern (car pattern)
%temp
(lambda (x) ;temp is free in x
(mapit (if (eq? %temp x)
path ;+++
`(map (lambda (,%temp) ,x)
,path))))))
((pair? pattern)
(append (process-pattern (car pattern) `(car ,path) mapit)
(process-pattern (cdr pattern) `(cdr ,path) mapit)))
(else '())))
; Generate code to compose the output expression according to template
(define (process-template template rank env)
(cond ((name? template)
(let ((probe (assq template env)))
(if probe
(if (<= (cdr probe) rank)
template
(syntax-error "template rank error (too few ...'s?)"
template))
`(,%rename ',template))))
((segment-template? template)
(let ((vars
(free-meta-variables (car template) (+ rank 1) env '())))
(if (null? vars)
(syntax-error "too many ...'s" template)
(let* ((x (process-template (car template)
(+ rank 1)
env))
(gen (if (equal? (list x) vars)
x ;+++
`(map (lambda ,vars ,x)
,@vars))))
(if (null? (cddr template))
gen ;+++
`(append ,gen ,(process-template (cddr template)
rank env)))))))
((pair? template)
`(cons ,(process-template (car template) rank env)
,(process-template (cdr template) rank env)))
(else `(quote ,template))))
; Return an association list of (var . rank)
(define (meta-variables pattern rank vars)
(cond ((name? pattern)
(if (memq pattern subkeywords)
vars
(cons (cons pattern rank) vars)))
((segment-pattern? pattern)
(meta-variables (car pattern) (+ rank 1) vars))
((pair? pattern)
(meta-variables (car pattern) rank
(meta-variables (cdr pattern) rank vars)))
(else vars)))
; Return a list of meta-variables of given higher rank
(define (free-meta-variables template rank env free)
(cond ((name? template)
(if (and (not (memq template free))
(let ((probe (assq template env)))
(and probe (>= (cdr probe) rank))))
(cons template free)
free))
((segment-template? template)
(free-meta-variables (car template)
rank env
(free-meta-variables (cddr template)
rank env free)))
((pair? template)
(free-meta-variables (car template)
rank env
(free-meta-variables (cdr template)
rank env free)))
(else free)))
c ;ignored
;; Kludge for Scheme 48 static linker.
;; `(cons ,(make-transformer rules)
;; ',(find-free-names-in-syntax-rules subkeywords rules))
(make-transformer rules))))

118
alt/t-features.scm
View File

@ -1,118 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; This is file t-features.scm.
; Synchronize any changes with all the other *-features.scm files.
; This hasn't been tested in a long time.
(define (get-from-t name)
(*value t-implementation-env name))
; (define error (get-from-t 'error)) - already present
; (define warn (get-from-t 'warn)) - already present?
(define (interaction-environment)
scheme-user-env) ;Foo
(define scheme-report-environment
(let ((env (interaction-environment))) ;Isn't there a scheme-env?
(lambda (n) env)))
(define (ignore-errors thunk)
'(error "ignore-errors isn't implemented"))
(define force-output (get-from-t 'force-output))
(define char->ascii char->integer)
(define ascii->char integer->char)
(define (string-hash s)
(let ((n (string-length s)))
(do ((i 0 (+ i 1))
(h 0 (+ h (char->ascii (string-ref s i)))))
((>= i n) h))))
;==============================================================================
; Bitwise logical operations on integers
; T's ASH doesn't work on negative numbers
(define arithmetic-shift
(let ((fx-ashl (get-from-t 'fx-ashl))
(fx-ashr (get-from-t 'fx-ashr)))
(lambda (integer count)
(if (>= count 0)
(fx-ashl integer count)
(fx-ashr integer (- 0 count))))))
; This is from Olin Shivers:
; (define (correct-ash n m)
; (cond ((or (= m 0) (= n 0)) n)
; ((> n 0) (ash n m))
; ;; shifting a negative number.
; ((> m 0) ; left shift
; (- (ash (- n) m)))
; (else ; right shift
; (lognot (ash (lognot n) m)))))
(define bitwise-and (get-from-t 'fx-and))
(define bitwise-ior (get-from-t 'fx-ior))
;==============================================================================
; Code vectors
(define make-bytev (get-from-t 'make-bytev))
(define code-vector? (get-from-t 'bytev?))
(define code-vector-length (get-from-t 'bytev-length))
(define code-vector-ref (get-from-t 'bref-8))
(define code-vector-set! ((get-from-t 'setter) code-vector-ref))
(define (make-code-vector size . init)
(let ((vec (make-bytev size)))
(if (not (null? init))
(code-vector-fill! vec (car init)))
vec))
(define (code-vector-fill! cv x)
(do ((i 0 (+ i 1)))
((>= i (code-vector-length cv)))
(code-vector-set! cv i x)))
;==============================================================================
; Bug fixes and modernizations
; I think syntax-rules will be needed, as well.
; Simulate a modernized DEFINE-SYNTAX.
(#[syntax define-syntax] (define-syntax name xformer)
`(#[syntax define-syntax] (,name . %tail%)
(,xformer (cons ',name %tail%)
(lambda (x) x) ;rename
eq?))) ;compare
; T's MAKE-VECTOR and MAKE-STRING ignore their init argument.
(define make-vector
(let ((broken-make-vector (get-from-t 'make-vector)))
(lambda (size . init)
(let ((vec (broken-make-vector size)))
(if (not (null? init))
(vector-fill! vec (car init)))
vec))))
(define make-string
(let ((make-string (get-from-t 'make-string))
(string-fill (get-from-t 'string-fill)))
(lambda (size . init-option)
(if (null? init-option)
(make-string size)
(string-fill (make-string size) (car init-option))))))
; Dynamic-wind.
(define (dynamic-wind before during after)
(before)
(let ((result (during)))
(after)
result))

57
alt/t-record.scm
View File

@ -1,57 +0,0 @@
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; This is file t-record.scm.
; Synchronize any changes with the other *record.scm files.
;;;; Records
(define make-record-type
(let ((make-stype (*value t-standard-env 'make-stype))
(crawl-exhibit (*value t-standard-env 'crawl-exhibit))
(exhibit-structure (*value t-standard-env 'exhibit-structure))
(structure-type (*value t-standard-env 'structure-type))
(object-hash (*value t-standard-env 'object-hash))
(print (*value t-standard-env 'print))
(format (*value t-standard-env 'format)))
(lambda (id names)
(letrec ((rtd
(make-stype id names
(#[syntax object] #f
((crawl-exhibit self)
(exhibit-structure self))
((print self port)
(format port "#{Record~_~S~_~S}" id (object-hash self)))
((structure-type self) rtd)))))
rtd))))
(define record-predicate (*value t-standard-env 'stype-predicator))
(define record-accessor (*value t-standard-env 'stype-selector))
(define (record-modifier rtd name)
(setter (record-accessor rtd name)))
(define (record-constructor rtd names)
(let ((number-of-inits (length names))
(modifiers (map (lambda (name) (record-modifier rtd name))
names))
(make ((*value t-implementation-env 'stype-constructor) rtd)))
(lambda values
(let ((record (make)))
(let loop ((vals values)
(ups modifiers))
(cond ((null? vals)
(if (null? ups)
record
(error "too few arguments to record constructor"
values type-id names)))
((null? ups)
(error "too many arguments to record constructor"
values type-id names))
(else
((car ups) record (car vals))
(loop (cdr vals) (cdr ups)))))))))
(define (define-record-discloser rtd proc) 'unimplemented)

14
alt/table.scm
View File

@ -1,14 +0,0 @@
; unworthy of copyright notice
(define (make-table . hash-procedure-option) (list 'table))
(define (table-ref table key)
(let ((probe (assq key (cdr table))))
(if probe (cdr probe) #f)))
(define (table-set! table key value)
(let ((probe (assq key (cdr table))))
(if probe
(set-cdr! probe value)
(set-cdr! table (cons (cons key value) (cdr table))))))

21
alt/template.scm
View File

@ -1,21 +0,0 @@
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Templates implemented as vectors.
(define *template-marker* (list '*template-marker*))
(define (make-template len init)
(let ((t (make-vector (+ len 1) init)))
(vector-set! t 0 *template-marker*)
t))
(define (template? obj)
(and (vector? obj)
(> (vector-length obj) 0)
(eq? (vector-ref obj 0) *template-marker*)))
(define (template-length t) (- (vector-length t) 1))
(define (template-ref t i) (vector-ref t (+ i 1)))
(define (template-set! t i x) (vector-set! t (+ i 1) x))

19
alt/values.scm
View File

@ -1,19 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Multiple return values
(define multiple-value-token (vector 'multiple-value-token))
(define (values . things)
(if (and (pair? things)
(null? (cdr things)))
(car things)
(cons multiple-value-token things)))
(define (call-with-values producer consumer)
(let ((things (producer)))
(if (and (pair? things)
(eq? (car things) multiple-value-token))
(apply consumer (cdr things))
(consumer things))))

8
alt/weak.scm
View File

@ -1,8 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
(define (make-weak-pointer x) (cons '<weak> x))
(define weak-pointer-ref cdr)
(define (weak-pointer? x)
(and (pair? x) (eq? (car x) '<weak>)))

573
bcomp/comp.scm
View File

@ -1,573 +0,0 @@
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; This is file comp.scm.
;;;; The byte-code compiler
; This is a two-phase compiler. The first phase does macro expansion,
; variable resolution, and instruction selection, and computes the
; size of the code vector. The second phase (assembly) creates the
; code vector, "template" (literals vector), and debugging data
; structures.
; The output of the first phase (the COMPILE- and INSTRUCTION-
; routines) and the input to the second phase (SEGMENT->TEMPLATE) is a
; "segment." A segment is a pair (size . proc) where size is the size
; of the code segment in bytes, and proc is a procedure that during
; phase 2 will store the segment's bytes into the code vector.
; A "cenv" maps lexical variables to <level, offset> pairs. Level is
; the variable's distance from the root of the environment; 0 means
; outermost level, and higher numbers mean deeper lexical levels. The
; offset is the position of the variable within its level's
; environment vector.
; Optimizations are marked with +++, and may be flushed if desired.
(define (compile-top exp cenv depth cont)
(compile exp (initial-cenv cenv) depth cont))
; Main dispatch for compiling a single expression.
(define (compile exp cenv depth cont)
(let ((node (type-check (classify exp cenv) cenv)))
((operator-table-ref compilators (node-operator-id node))
node
cenv
depth
cont)))
; Specialists
(define compilators
(make-operator-table (lambda (node cenv depth cont)
(generate-trap cont
"not valid in expression context"
(schemify node cenv)))
(lambda (frob) ;for let-syntax, with-aliases, etc.
(lambda (node cenv depth cont)
(call-with-values (lambda () (frob node cenv))
(lambda (form cenv)
(compile form cenv depth cont)))))))
(define (define-compilator name type proc)
(operator-define! compilators name type proc))
(define-compilator 'literal #f
(lambda (node cenv depth cont)
(let ((obj (node-form node)))
(if (eq? obj #f)
;; +++ hack for bootstrap from Schemes that don't distinguish #f/()
(deliver-value (instruction (enum op false)) cont)
(compile-constant obj depth cont)))))
(define-compilator 'quote syntax-type
(lambda (node cenv depth cont)
(let ((exp (node-form node)))
cenv ;ignored
(let ((obj (cadr exp)))
(compile-constant obj depth cont)))))
(define (compile-constant obj depth cont)
(if (ignore-values-cont? cont)
empty-segment ;+++ dead code
(deliver-value (instruction-with-literal (enum op literal) obj)
cont)))
; Variable reference
(define-compilator 'name #f
(lambda (node cenv depth cont)
(let* ((binding (name-node-binding node cenv))
(name (node-form node)))
(deliver-value (if (and (binding? binding)
(pair? (binding-place binding)))
(let* ((level+over (binding-place binding))
(back (- (environment-level cenv)
(car level+over)))
(over (cdr level+over)))
(case back
((0) (instruction (enum op local0) over)) ;+++
((1) (instruction (enum op local1) over)) ;+++
((2) (instruction (enum op local2) over)) ;+++
(else (instruction (enum op local) back over))))
(instruction-with-location
(enum op global)
(get-location binding cenv name value-type)))
cont))))
; Assignment
(define-compilator 'set! syntax-type
(lambda (node cenv depth cont)
(let* ((exp (node-form node))
(lhs-node (classify (cadr exp) cenv))
(name (node-form lhs-node))
;; Error if not a name node...
(binding (name-node-binding lhs-node cenv)))
(sequentially
(compile (caddr exp) cenv depth (named-cont name))
(deliver-value
(if (and (binding? binding) (pair? (binding-place binding)))
(let ((level+over (binding-place binding)))
(instruction (enum op set-local!)
(- (environment-level cenv) (car level+over))
(cdr level+over)))
(instruction-with-location (enum op set-global!)
(get-location binding cenv name usual-variable-type)))
cont)))))
; Conditional
(define-compilator 'if syntax-type
(lambda (node cenv depth cont)
(let ((exp (node-form node))
(alt-label (make-label))
(join-label (make-label)))
(sequentially
;; Test
(compile (cadr exp) cenv depth (fall-through-cont node 1))
(instruction-using-label (enum op jump-if-false) alt-label)
;; Consequent
(compile (caddr exp) cenv depth cont)
(if (fall-through-cont? cont)
(instruction-using-label (enum op jump) join-label)
empty-segment)
;; Alternate
(attach-label alt-label
(compile (cadddr exp) cenv depth cont))
(attach-label join-label
empty-segment)))))
(define-compilator 'begin syntax-type
(lambda (node cenv depth cont)
(let ((exp (node-form node)))
(compile-begin (cdr exp) cenv depth cont))))
(define compile-begin
(let ((operator/begin (get-operator 'begin)))
(lambda (exp-list cenv depth cont)
(if (null? exp-list)
(generate-trap cont "null begin")
(let ((dummy
(make-node operator/begin ;For debugging database
`(begin ,@exp-list))))
(let loop ((exp-list exp-list) (i 1))
(if (null? (cdr exp-list))
(compile (car exp-list) cenv depth cont)
(careful-sequentially
(compile (car exp-list) cenv depth
(ignore-values-cont dummy i))
(loop (cdr exp-list) (+ i 1))
depth
cont))))))))
; Compile a call
(define (compile-call node cenv depth cont)
(if (node-ref node 'type-error)
(compile-unknown-call node cenv depth cont)
(let ((proc-node (classify (car (node-form node)) cenv)))
(if (and (lambda-node? proc-node)
(not (n-ary? (cadr (node-form proc-node)))))
(compile-redex proc-node (cdr (node-form node)) cenv depth cont)
(let ((new-node (maybe-transform-call proc-node node cenv)))
(if (eq? new-node node)
(compile-unknown-call node cenv depth cont)
(compile new-node cenv depth cont)))))))
(define-compilator 'call #f compile-call)
; A redex is a call of the form ((lambda (x1 ... xn) body ...) e1 ... en).
(define lambda-node? (node-predicate 'lambda))
(define (compile-redex proc-node args cenv depth cont)
(let* ((proc-exp (node-form proc-node))
(formals (cadr proc-exp))
(body (cddr proc-exp)))
(if (null? formals)
(compile-body body cenv depth cont) ;+++
(maybe-push-continuation
(sequentially
(push-all-with-names args formals cenv 0)
(compile-lambda-code formals body cenv (cont-name cont)))
depth
cont))))
; Compile a call to a computed procedure.
(define (compile-unknown-call node cenv depth cont)
(let ((exp (node-form node)))
(let ((call (sequentially (push-arguments node cenv 0)
(compile (car exp)
cenv
(length (cdr exp))
(fall-through-cont node 0))
(instruction (enum op call) (length (cdr exp))))))
(maybe-push-continuation call depth cont))))
(define (maybe-push-continuation code depth cont)
(if (return-cont? cont)
code
(let ((label (make-label)))
(sequentially (instruction-using-label (enum op make-cont)
label
depth)
(note-source-code (cont-source-info cont)
code)
(attach-label label
(cont-segment cont))))))
; Continuation is implicitly fall-through.
(define (push-arguments node cenv depth)
(let recur ((args (cdr (node-form node))) (depth depth) (i 1))
(if (null? args)
empty-segment
(sequentially (compile (car args) cenv depth
(fall-through-cont node i))
(instruction (enum op push))
(recur (cdr args) (+ depth 1) (+ i 1))))))
(define (push-all-with-names exp-list names cenv depth)
(if (null? exp-list)
empty-segment
(sequentially (compile (car exp-list)
cenv depth
(named-cont (car names)))
(instruction (enum op push))
(push-all-with-names (cdr exp-list)
(cdr names)
cenv
(+ depth 1)))))
; OK, now that you've got all that under your belt, here's LAMBDA.
(define-compilator 'lambda syntax-type
(lambda (node cenv depth cont)
(let ((exp (node-form node))
(name (cont-name cont)))
(deliver-value
(instruction-with-template (enum op closure)
(compile-lambda exp
cenv
;; Hack for constructors.
;; Cf. disclose method
;; (if name #t #f)
#f)
name)
cont))))
(define (compile-lambda exp cenv body-name)
(let* ((formals (cadr exp))
(nargs (number-of-required-args formals)))
(sequentially
;; Check number of arguments
(if (n-ary? formals)
(if (pair? formals)
(instruction (enum op check-nargs>=) nargs)
empty-segment) ;+++ (lambda x ...) needs no check
(instruction (enum op check-nargs=) nargs))
(compile-lambda-code formals (cddr exp) cenv body-name))))
; name isn't the name of the procedure, it's the name to be given to
; the value that the procedure will return.
(define (compile-lambda-code formals body cenv name)
(if (null? formals)
(compile-body body ;+++ Don't make null environment
cenv
0
(return-cont name))
;; (if (node-ref node 'no-inferior-lambdas) ...)
(sequentially
(let ((nargs (number-of-required-args formals)))
(if (n-ary? formals)
(sequentially
(instruction (enum op make-rest-list) nargs)
(instruction (enum op push))
(instruction (enum op make-env) (+ nargs 1)))
(instruction (enum op make-env) nargs)))
(let* ((vars (normalize-formals formals))
(cenv (bind-vars (reverse vars) cenv)))
(note-environment
vars
(compile-body body
cenv
0
(return-cont name)))))))
(define compile-letrec
(let ((operator/lambda (get-operator 'lambda syntax-type))
(operator/set! (get-operator 'set! syntax-type))
(operator/call (get-operator 'call))
(operator/unassigned (get-operator 'unassigned)))
(lambda (node cenv depth cont)
;; (if (node-ref node 'pure-letrec) ...)
(let* ((exp (node-form node))
(specs (cadr exp))
(body (cddr exp)))
(compile-redex (make-node operator/lambda
`(lambda ,(map car specs)
,@(map (lambda (spec)
(make-node operator/set!
`(set! ,@spec)))
specs)
,(make-node
operator/call
`(,(make-node operator/lambda
`(lambda () ,@body))))))
(map (lambda (spec)
(make-node operator/unassigned
`(unassigned)))
specs)
cenv depth cont)))))
(define-compilator 'letrec syntax-type compile-letrec)
; --------------------
; Deal with internal defines (ugh)
(define (compile-body body cenv depth cont)
(scan-body body
cenv
(lambda (defs exps)
(if (null? defs)
(compile-begin exps cenv depth cont)
(compile-letrec
(make-node operator/letrec
`(letrec ,(map (lambda (node)
(cdr (node-form node)))
defs)
,@exps))
cenv depth cont)))))
(define operator/letrec (get-operator 'letrec))
; --------------------
; Compile-time continuations
;
; A compile-time continuation is a pair (segment . name). Segment is
; one of the following:
; a return instruction - invoke the current full continuation.
; empty-segment - fall through to subsequent instructions.
; an ignore-values instruction - ignore values, then fall through.
; If name is non-#f, then the value delivered to subsequent
; instructions will be assigned to a variable. If the value being
; assigned is a lambda, we can give that lambda that name, for
; debugging purposes.
(define (make-cont seg source-info) (cons seg source-info))
(define cont-segment car)
(define cont-source-info cdr)
; Eventually we may be able to optimize jumps to jumps. Can't yet.
;(define (make-jump-cont jump cont)
; (if (fall-through-cont? cont)
; (make-cont jump (cont-name cont))
; cont))
(define return-cont-segment (instruction (enum op return)))
(define (return-cont name)
(make-cont return-cont-segment name))
(define (return-cont? cont)
(eq? (cont-segment cont) return-cont-segment))
; Fall through into next instruction
(define (fall-through-cont node i)
(make-cont empty-segment (cons i node)))
(define (fall-through-cont? cont)
(not (return-cont? cont)))
; Ignore return value, then fall through
(define ignore-values-segment
(instruction (enum op ignore-values)))
(define (ignore-values-cont node i)
(make-cont ignore-values-segment (cons i node)))
(define (ignore-values-cont? cont)
(eq? (cont-segment cont) ignore-values-segment))
; Value is in *val*; deliver it to its continuation.
; No need to generate an ignore-values instruction in this case.
(define (deliver-value segment cont)
(if (ignore-values-cont? cont) ;+++
segment
(sequentially segment (cont-segment cont))))
; For putting names to lambda expressions:
(define (named-cont name)
(make-cont empty-segment name))
(define (cont-name cont)
(if (pair? (cont-source-info cont))
#f
(cont-source-info cont)))
; --------------------
; Compile-time environments
(define (bind-vars names cenv)
(let ((level (+ (environment-level cenv) 1)))
(lambda (name)
(if (eq? name funny-name/lexical-level)
level
(let loop ((over 1) (names names))
(cond ((null? names)
(lookup cenv name))
((eq? name (car names))
(make-binding usual-variable-type (cons level over) #f))
(else (loop (+ over 1) (cdr names)))))))))
(define (initial-cenv cenv)
(bind1 funny-name/lexical-level -1 cenv))
(define (environment-level cenv)
(lookup cenv funny-name/lexical-level))
(define funny-name/lexical-level (string->symbol "Lexical nesting level"))
; Find lookup result that was cached by classifier
(define (name-node-binding node cenv)
(or (node-ref node 'binding)
(node-form node))) ; = (lookup cenv (node-form node))
; --------------------
; Utilities
; Produce something for source code that contains a compile-time error.
(define (generate-trap cont . stuff)
(apply warn stuff)
(sequentially (instruction-with-literal (enum op literal)
(cons 'error stuff))
(deliver-value (instruction (enum op trap))
cont)))
; Make a segment smaller, if it seems necessary, by introducing an
; extra template. A segment is "too big" if it accesses more literals
; than the size of the operand in a literal-accessing instruction.
; The number of literals is unknowable given current representations,
; so we conservatively shrink the segment when its size exceeds 2
; times the largest admissible operand value, figuring that it takes
; at least 2 instruction bytes to use a literal.
(define (careful-sequentially seg1 seg2 depth cont)
(if (and (= depth 0)
(> (+ (segment-size seg1) (segment-size seg2))
large-segment-size))
(if (> (segment-size seg1) (segment-size seg2))
(sequentially (shrink-segment seg1 (fall-through-cont #f #f))
seg2)
(sequentially seg1
(shrink-segment seg2 cont)))
(sequentially seg1 seg2)))
(define large-segment-size (* byte-limit 2))
(define (shrink-segment seg cont)
(maybe-push-continuation
(sequentially (instruction-with-template
(enum op closure)
(if (return-cont? cont)
seg
(sequentially seg
(instruction (enum op return))))
#f)
(instruction (enum op call) 0))
0
cont))
; --------------------
; Type checking. This gets called on all nodes.
(define (type-check node cenv)
(if *type-check?*
(let ((form (node-form node)))
(if (pair? form)
(let ((proc-node (car form)))
(if (node? proc-node)
(let ((proc-type (node-type proc-node cenv)))
(cond ((procedure-type? proc-type)
(if (restrictive? proc-type)
(let* ((args (if (eq? *type-check?* 'heavy)
(map (lambda (exp)
(classify exp cenv))
(cdr form))
(cdr form)))
(args-type (make-some-values-type
(map (lambda (arg)
(meet-type
(node-type arg cenv)
value-type))
args)))
(node (make-similar-node node
(cons proc-node
args))))
(if (not (meet? args-type
(procedure-type-domain proc-type)))
(diagnose-call-error node proc-type cenv))
node)
node))
((not (meet? proc-type any-procedure-type))
;; Could also check args for one-valuedness.
(let ((message "non-procedure in operator position"))
(warn message
(schemify node cenv)
`(procedure: ,proc-type))
(node-set! node 'type-error message))
node)
(else node)))
node))
node))
node))
(define (set-type-check?! check?)
(set! *type-check?* check?))
(define *type-check?* 'heavy)
(define (diagnose-call-error node proc-type cenv)
(let ((message
(cond ((not (fixed-arity-procedure-type? proc-type))
"invalid arguments")
((= (procedure-type-arity proc-type)
(length (cdr (node-form node))))
"argument type error")
(else
"wrong number of arguments"))))
(warn message
(schemify node cenv)
`(procedure wants:
,(rail-type->sexp (procedure-type-domain proc-type)
#f))
`(arguments are: ,(map (lambda (arg)
(type->sexp (node-type arg cenv) #t))
(cdr (node-form node)))))
(node-set! node 'type-error message)))
; Type system loophole
(define-compilator 'loophole syntax-type
(lambda (node cenv depth cont)
(compile (caddr (node-form node)) cenv depth cont)))

35
bcomp/config.scm
View File

@ -1,35 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; For DEFINE-STRUCTURE macro
(define (make-a-package opens-thunk accesses-thunk tower
dir clauses name)
(make-package opens-thunk accesses-thunk
#t ;unstable
tower
dir
clauses
#f
name))
(define (loser . rest)
(error "init-defpackage! neglected"))
(define interface-of structure-interface)
(define *verify-later!* (lambda (thunk) #f))
(define (verify-later! thunk)
(*verify-later!* thunk))
(define (set-verify-later! proc)
(set! *verify-later!* proc))
(define (note-name! thing name)
(cond ((interface? thing)
(note-interface-name! thing name))
((structure? thing)
(note-structure-name! thing name)))
thing)

384
bcomp/cprim.scm
View File

@ -1,384 +0,0 @@
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; This is file cprim.scm.
;;;; Compiling primitive procedures and calls to them.
(define (define-compiler-primitive name type compilator closed)
(define-compilator name type
(or compilator compile-unknown-call))
(define-closed-compilator name closed))
; Closed-compiled versions of primitives are handled separately.
(define closed-compilators
(make-operator-table (lambda ()
(error "unknown primitive procedure"))))
(define (define-closed-compilator name proc)
(operator-define! closed-compilators name #f proc))
; (primitive-procedure name) => a procedure
(define-compilator 'primitive-procedure syntax-type
(lambda (node cenv depth cont)
(let ((name (cadr (node-form node))))
(deliver-value (instruction-with-template
(enum op closure)
((get-closed-compilator (get-operator name)))
(cont-name cont))
cont))))
(define (get-closed-compilator op)
(operator-lookup closed-compilators op))
; --------------------
; Direct primitives.
; The simplest kind of primitive has fixed arity, corresponds to some
; single VM instruction, and takes its arguments in the usual way (all
; on the stack except the last).
(define (direct-compilator type opcode)
(lambda (node cenv depth cont)
(let ((args (cdr (node-form node))))
(sequentially (if (null? args)
empty-segment
(push-all-but-last args cenv depth node))
(deliver-value (instruction opcode) cont)))))
(define (direct-closed-compilator opcode)
(lambda ()
(let ((arg-specs (vector-ref opcode-arg-specs opcode)))
(sequentially (if (pair? arg-specs)
(sequentially
(instruction (enum op check-nargs=) (car arg-specs))
(instruction (enum op pop)))
(instruction (enum op check-nargs=) 0))
(instruction opcode)
(instruction (enum op return))))))
(define (nargs->domain nargs)
(do ((nargs nargs (- nargs 1))
(l '() (cons value-type l)))
((= nargs 0) (make-some-values-type l))))
; Define all the primitives that correspond to opcodes in the obvious way.
(do ((opcode 0 (+ opcode 1)))
((= opcode op-count))
(let ((arg-specs (vector-ref opcode-arg-specs opcode))
(name (enumerand->name opcode op)))
(cond ((memq name '(external-call return-from-interrupt return)))
((null? arg-specs)
(let ((type (proc () value-type)))
(define-compiler-primitive name type
(direct-compilator type opcode)
(direct-closed-compilator opcode))))
((not (number? (car arg-specs))))
(else
(let ((type (procedure-type (nargs->domain (car arg-specs))
(if (eq? name 'with-continuation)
any-values-type
;; Return a single value.
value-type)
;; nonrestrictive - domain might be
;; specialized later
#t)))
(define-compiler-primitive name type
(direct-compilator type opcode)
(direct-closed-compilator opcode)))))))
; --------------------
; Simple primitives are executed using a fixed instruction or
; instruction sequence.
(define (define-simple-primitive name type segment)
(let ((winner? (fixed-arity-procedure-type? type)))
(let ((nargs (if winner?
(procedure-type-arity type)
(error "n-ary simple primitive?!" name type))))
(define-compiler-primitive name type
(simple-compilator segment)
(simple-closed-compilator nargs segment)))))
(define (simple-compilator segment)
(lambda (node cenv depth cont)
(let ((args (cdr (node-form node))))
(sequentially (if (null? args)
empty-segment
(push-all-but-last args cenv depth node))
(deliver-value segment cont)))))
(define (simple-closed-compilator nargs segment)
(lambda ()
(sequentially (instruction (enum op check-nargs=) nargs)
(instruction (enum op pop))
segment
(instruction (enum op return)))))
(define (symbol-append . syms)
(string->symbol (apply string-append
(map symbol->string syms))))
(define (define-stob-predicate name stob-name)
(define-simple-primitive name
(proc (value-type) boolean-type)
(instruction (enum op stored-object-has-type?)
(name->enumerand stob-name stob))))
(define-stob-predicate 'code-vector? 'code-vector)
(define-stob-predicate 'string? 'string)
; Define primitives for record-like stored objects (e.g. pairs).
(define (define-data-struct-primitives name predicate maker . slots)
(let* ((def-prim (lambda (name type op . stuff)
(define-simple-primitive name type
(apply instruction (cons op stuff)))))
(type-byte (name->enumerand name stob))
(type (sexp->type (symbol-append ': name) #t)))
(define-stob-predicate predicate name)
(if (not (eq? maker 'make-symbol)) ; Symbols are made using op/intern.
(def-prim maker
(procedure-type (nargs->domain (length slots)) type #t)
(enum op make-stored-object)
(length slots)
type-byte))
(do ((i 0 (+ i 1))
(slots slots (cdr slots)))
((null? slots))
(let ((slot (car slots)))
(if (car slot)
(def-prim (car slot)
(proc (type) value-type)
(enum op stored-object-ref) type-byte i))
(if (cadr slot)
(def-prim (cadr slot)
(proc (type value-type) unspecific-type)
(enum op stored-object-set!) type-byte i))))))
(for-each (lambda (stuff)
(apply define-data-struct-primitives stuff))
stob-data)
; Define primitives for vector-like stored objects.
(define (define-vector-primitives name element-type make length ref set!)
(let* ((type-byte (name->enumerand name stob))
(def-prim (lambda (name type op)
(define-simple-primitive name type
(instruction op type-byte))))
(type (sexp->type (symbol-append ': name) #t)))
(define-stob-predicate (symbol-append name '?) name)
(def-prim (symbol-append 'make- name)
(proc (exact-integer-type element-type) type)
make)
(def-prim (symbol-append name '- 'length)
(proc (type) exact-integer-type)
length)
(def-prim (symbol-append name '- 'ref)
(proc (type exact-integer-type) element-type)
ref)
(def-prim (symbol-append name '- 'set!)
(proc (type exact-integer-type element-type) unspecific-type)
set!)))
(for-each (lambda (name)
(define-vector-primitives name value-type
(enum op make-vector-object)
(enum op stored-object-length)
(enum op stored-object-indexed-ref)
(enum op stored-object-indexed-set!)))
'(vector record continuation extended-number template))
; SIGNAL-CONDITION is the same as TRAP.
(define-simple-primitive 'signal-condition (proc (pair-type) unspecific-type)
(instruction (enum op trap)))
; (primitive-catch (lambda (cont) ...))
(define-compiler-primitive 'primitive-catch #f
;; (primitive-catch (lambda (cont) ...))
(lambda (node cenv depth cont)
(let* ((exp (node-form node))
(args (cdr exp)))
(maybe-push-continuation
(sequentially (instruction (enum op current-cont))
(instruction (enum op push))
;; If lambda exp, should do compile-lambda-code to
;; avoid consing closure...
(compile (car args) cenv 1
(fall-through-cont node 1))
(instruction (enum op call) 1))
0
cont)))
(lambda ()
(sequentially (instruction (enum op check-nargs=) 1)
(instruction (enum op make-env) 1) ;Seems unavoidable.
(instruction (enum op current-cont))
(instruction (enum op push))
(instruction (enum op local0) 1)
(instruction (enum op call) 1))))
; (call-with-values (lambda () ...producer...)
; (lambda args ...consumer...))
(define-compiler-primitive 'call-with-values #f
(lambda (node cenv depth cont)
(let ((args (cdr (node-form node))))
(let ((producer (car args))
(consumer (cadr args)))
(maybe-push-continuation
(sequentially (compile consumer cenv 0 (fall-through-cont node 2))
(instruction (enum op push))
(maybe-push-continuation ; nothing maybe about it
(compile-call (classify `(,producer) cenv)
cenv 0
(return-cont #f))
1
(fall-through-cont #f 0))
;; Was:
;; (compile-call (classify `(,producer) cenv)
;; cenv 1
;; (fall-through-cont node 1))
(instruction (enum op call-with-values)))
depth
cont))))
(lambda ()
;; producer and consumer on stack
(let ((label (make-label)))
(sequentially (instruction (enum op check-nargs=) 2)
(instruction (enum op make-env) 2)
(instruction (enum op local0) 1) ;consumer
(instruction (enum op push))
(instruction-using-label (enum op make-cont) label 1)
(instruction (enum op local0) 2) ;producer
(instruction (enum op call) 0)
(attach-label label
(instruction (enum op call-with-values)))))))
; --------------------
; Variable-arity primitives
(define (define-n-ary-compiler-primitive name result-type min-nargs
compilator closed)
(define-compiler-primitive name
(if result-type
(procedure-type any-arguments-type result-type #f)
#f)
(if compilator
(n-ary-primitive-compilator name min-nargs compilator)
compile-unknown-call)
closed))
(define (n-ary-primitive-compilator name min-nargs compilator)
(lambda (node cenv depth cont)
(let ((exp (node-form node)))
(if (>= (length (cdr exp)) min-nargs)
(compilator node cenv depth cont)
(begin (warn "too few arguments to primitive"
(schemify node cenv))
(compile-unknown-call node cenv depth cont))))))
; APPLY wants to first spread the list, then load the procedure.
; The list argument has to be in *VAL* so that its length can be checked
; before the instruction is begun.
(define-n-ary-compiler-primitive 'apply #f 2
(lambda (node cenv depth cont)
(let ((exp (node-form node))) ; (apply proc arg1 arg2 arg3 rest)
(let* ((proc+args+rest (cdr exp))
(rest+args ; (rest arg3 arg2 arg1)
(reverse (cdr proc+args+rest)))
(args (cdr rest+args)) ; (arg3 arg2 arg1)
(args+proc+rest ; (arg1 arg2 arg3 proc rest)
(reverse (cons (car rest+args)
(cons (car proc+args+rest) args)))))
(maybe-push-continuation
(sequentially (push-all-but-last args+proc+rest cenv 0 #f)
;; Operand is number of non-final arguments
(instruction (enum op apply) (length args)))
depth
cont))))
(lambda ()
(sequentially (instruction (enum op check-nargs=) 2)
(instruction (enum op pop))
(instruction (enum op apply) 0))))
; (values value1 value2 ...)
(define-n-ary-compiler-primitive 'values #f 0
(lambda (node cenv depth cont)
(let ((args (cdr (node-form node))))
(maybe-push-continuation (sequentially (push-arguments node cenv 0)
(instruction (enum op return-values)
(length args)))
depth
cont)))
(lambda () (instruction (enum op values))))
; (error message irritant1 irritant2)
; => (trap (cons 'error (cons message (cons irritant1 (cons irritant2 '())))))
(let ((cons-instruction
(instruction (enum op make-stored-object) 2 (enum stob pair))))
(define-n-ary-compiler-primitive 'error error-type 1
(lambda (node cenv depth cont)
(let ((exp (node-form node)))
(let ((args (cdr exp)))
(sequentially (instruction-with-literal (enum op literal) 'error)
(instruction (enum op push))
(push-arguments node cenv (+ depth 1))
(instruction-with-literal (enum op literal) '())
(apply sequentially
(map (lambda (arg) cons-instruction) args))
cons-instruction
(deliver-value (instruction (enum op trap)) cont)))))
(lambda ()
(sequentially (instruction (enum op make-rest-list) 0)
(instruction (enum op push))
(instruction-with-literal (enum op literal) 'error)
(instruction (enum op push))
(instruction (enum op stack-ref) 1)
cons-instruction
(instruction (enum op trap))
(instruction (enum op return))))))
; (external-call external-routine arg ...)
(define-n-ary-compiler-primitive 'external-call value-type 1
#f ;Must set *nargs*
(lambda ()
(sequentially (instruction (enum op check-nargs>=) 1)
(instruction (enum op external-call))
(instruction (enum op return)))))
; --------------------
; Utility
(define (push-all-but-last args cenv depth source-info)
(let recur ((args args) (depth depth) (i 1))
(let ((first-code
(compile (car args) cenv depth (fall-through-cont source-info i))))
(if (null? (cdr args))
first-code
(sequentially first-code
(instruction (enum op push))
(recur (cdr args) (+ depth 1) (+ i 1)))))))

89
bcomp/ddata.scm
View File

@ -1,89 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Stuff moved from segment.scm 6/5/93
; Debug-data records are for communicating information from the
; compiler to various debugging tools.
; Entries in an environment-maps list have the form
; #(parent-uid pc-in-parent (env-map ...))
(define-record-type debug-data :debug-data
(make-debug-data uid name parent pc-in-parent env-maps source)
debug-data?
(uid debug-data-uid)
(name debug-data-name)
(parent debug-data-parent)
(pc-in-parent debug-data-pc-in-parent)
(env-maps debug-data-env-maps set-debug-data-env-maps!)
(source debug-data-source set-debug-data-source!))
(define (new-debug-data name parent pc-in-parent)
(make-debug-data (new-template-uid) name parent pc-in-parent '() '()))
(define-record-discloser :debug-data
(lambda (dd)
(list 'debug-data (debug-data-uid dd) (debug-data-name dd))))
; "Info" means either a debug data record or an integer index into a
; table of same. An "info" is stored in a reserved place in every
; template.
(define (debug-data->info debug-data)
(make-immutable! debug-data)
(if (interesting-debug-data? debug-data)
(if (tabulate-debug-data?)
(begin (note-debug-data! debug-data)
(debug-data-uid debug-data))
debug-data)
(debug-data-uid debug-data))) ;+++
(define (get-debug-data info) ;info->debug-data
(cond ((debug-data? info) info)
((integer? info)
(table-ref (debug-data-table) info))
(else #f)))
(define (note-debug-data! dd)
(table-set! (debug-data-table) (debug-data-uid dd) dd))
(define (interesting-debug-data? debug-data)
(and (debug-data? debug-data)
(or (debug-data-name debug-data)
(interesting-debug-data? (debug-data-parent debug-data))
(not (null? (debug-data-env-maps debug-data)))
(not (null? (debug-data-source debug-data))))))
; We can follow parent links to get a full description of procedure
; nesting: "foo in bar in unnamed in baz"
(define (debug-data-names info)
(let ((dd (get-debug-data info)))
(if dd
(cons (debug-data-name dd)
(debug-data-names (debug-data-parent dd)))
'())))
; Associating names with templates
(define (template-debug-data tem)
(get-debug-data (template-info tem)))
(define (template-id tem)
(let ((info (template-info tem)))
(if (debug-data? info)
(debug-data-uid info)
info)))
(define (template-name tem)
(let ((probe (template-debug-data tem)))
(if probe
(debug-data-name probe)
#f)))
(define (template-names tem)
(debug-data-names (template-info tem)))

35
bcomp/for-reify.scm
View File

@ -1,35 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Things used by the expression returned by REIFY-STRUCTURES.
; Cf. link/reify.scm.
(define (operator name type-exp)
(get-operator name (sexp->type type-exp #t)))
(define (simple-interface names types)
(make-simple-interface #f
(map (lambda (name type)
(list name (sexp->type type #t)))
(vector->list names)
(vector->list types))))
(define (package names locs get-location uid)
(let ((end (vector-length names))
(p (make-package list list ;(lambda () '())
#f #f "" '()
uid #f)))
(set-package-loaded?! p #t)
(do ((i 0 (+ i 1)))
((= i end))
(let* ((name (vector-ref names i))
(probe (package-lookup p name)))
(if (not (binding? probe))
(package-define! p
name
usual-variable-type ;May get clobbered later
(get-location (vector-ref locs i))))))
(make-table-immutable! (package-definitions p))
p))
(define (transform names+proc env type-exp source name)
(make-transform names+proc env (sexp->type type-exp #t) source name))

88
bcomp/interface.scm
View File

@ -1,88 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Interfaces
(define-record-type interface :interface
(really-make-interface ref walk clients name)
interface?
(ref ref-method)
(walk walk-method)
(clients interface-clients)
(name interface-name set-interface-name!))
(define-record-discloser :interface
(lambda (int) (list 'interface (interface-name int))))
(define (interface-ref int name)
((ref-method int) name))
(define (for-each-declaration proc int)
((walk-method int) proc))
(define (note-reference-to-interface! int thing)
(let ((pop (interface-clients int)))
(if pop
(add-to-population! thing pop)
;; If it's compound, we really ought to descend into its components
)))
; If name is #f, then the interface is anonymous, so we don't need to
; make a population.
(define (make-interface ref walk name)
(really-make-interface ref walk
(make-population)
name))
; Simple interfaces (export (name type) ...)
(define (make-simple-interface name items)
(let ((table (make-table name-hash)))
(for-each (lambda (item)
(if (pair? item)
(let ((name (car item))
(type (cadr item)))
(if (or (null? name) (pair? name))
;; Allow ((name1 name2 ...) type)
(for-each (lambda (name)
(table-set! table name type))
name)
(table-set! table name type)))
(table-set! table item undeclared-type)))
items)
(make-table-immutable! table)
(really-make-simple-interface table name)))
(define (really-make-simple-interface table name)
(make-interface (lambda (name) (table-ref table name))
(lambda (proc) (table-walk proc table))
name))
; Compoune interfaces
(define (make-compound-interface name . ints)
(let ((int
(make-interface (lambda (name)
(let loop ((ints ints))
(if (null? ints)
#f
(or (interface-ref (car ints) name)
(loop (cdr ints))))))
(lambda (proc)
(for-each (lambda (int)
(for-each-declaration proc int))
ints))
name)))
(for-each (lambda (i)
(note-reference-to-interface! i int))
ints)
int))
(define (note-interface-name! int name)
(if (and name (not (interface-name int)))
(set-interface-name! int name)))

229
bcomp/module-language.scm
View File

@ -1,229 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; The DEFINE-INTERFACE and DEFINE-STRUCTURE macros.
(define-syntax def
(syntax-rules ()
((def (?name . ?args) ?body ...)
(really-def () ?name (lambda ?args ?body ...)))
((def ?name ...)
(really-def () ?name ...))))
(define-syntax really-def
(syntax-rules ()
((really-def (?name ...) ?exp)
(define-multiple (?name ...)
(begin (verify-later! (lambda () ?name))
...
?exp)))
((really-def (?name ...) ?name1 ?etc ...)
(really-def (?name ... ?name1) ?etc ...))))
(define-syntax define-multiple
(syntax-rules ()
((define-multiple (?name) ?exp)
(define ?name (note-name! ?exp '?name)))
((define-multiple (?name ...) ?exp)
(begin (define ?name)
...
(let ((frob (lambda things
(begin (set! ?name
(note-name! (car things) '?name))
(set! things (cdr things)))
...)))
(call-with-values (lambda () ?exp) frob))))))
; Interfaces
; <definition> ::= (define-interface <name> <int>)
; <int> ::= <name> | (export <item> ...) | (compound-interface <int> ...)
(define-syntax define-interface
(syntax-rules ()
((define-interface ?name ?int)
(def ?name ?int))))
(define-syntax export
(syntax-rules ()
((export ?item ...)
(really-export #f ?item ...))))
(define-syntax compound-interface
(syntax-rules ()
((compound-interface ?int ...)
(make-compound-interface #f ?int ...))))
; <item> ::= <name> | (<name> <type>) | ((<name> ...) <type>)
(define-syntax export
(lambda (e r c)
(let ((items (cdr e)))
(let loop ((items items)
(plain '())
(others '()))
(if (null? items)
`(,(r 'make-simple-interface)
#f
(,(r 'list) (,(r 'quote) ,(list (reverse plain)
':undeclared))
,@(reverse others)))
(let ((item (car items)))
(if (pair? item)
(loop (cdr items)
plain
(cons `(,(r 'list) (,(r 'quote) ,(car item))
,(cadr item))
others))
(loop (cdr items)
(cons item plain)
others)))))))
(make-simple-interface list quote value))
; Structures
(define-syntax define-structure
(syntax-rules ()
((define-structure ?name ?int ?clause1 ?clause ...)
(def ?name (structure ?int ?clause1 ?clause ...)))
;; For compatibility. Use DEF instead.
((define-structure ?name ?exp)
(def ?name ?exp))))
(define-syntax define-structures
(syntax-rules ()
((define-structures ((?name ?int) ...)
?clause ...)
(def ?name ... (structures (?int ...) ?clause ...)))))
(define-syntax structure
(syntax-rules ()
((structure ?int ?clause ...)
(structures (?int) ?clause ...))))
(define-syntax structures
(syntax-rules ()
((structures (?int ...) ?clause ...)
(let ((p (a-package #f ?clause ...)))
(values (make-structure p (lambda () ?int))
...)))))
; Packages
(define-syntax a-package
(let ()
(define (parse-package-clauses clauses rename compare)
(let ((%open (rename 'open))
(%access (rename 'access))
(%for-syntax (rename 'for-syntax)))
(let loop ((clauses clauses)
(opens '())
(accesses '())
(for-syntaxes '())
(others '()))
(cond ((null? clauses)
(values opens accesses for-syntaxes (reverse others)))
((not (list? (car clauses)))
(display "Ignoring invalid define-structures clause")
(newline)
(write (car clauses)) (newline)
(loop (cdr clauses)
opens
accesses
for-syntaxes
others))
(else
(let ((keyword (caar clauses)))
(cond ((compare keyword %open)
(loop (cdr clauses)
(append opens (cdar clauses))
accesses
for-syntaxes
others))
((compare keyword %access)
(loop (cdr clauses)
opens
(append (cdar clauses) accesses)
for-syntaxes
others))
((compare keyword %for-syntax)
(loop (cdr clauses)
opens
accesses
(append (cdar clauses) for-syntaxes)
others))
(else
(loop (cdr clauses)
opens
accesses
for-syntaxes
(cons (car clauses) others))))))))))
(lambda (form rename compare)
(let ((names (cadr form))
(clauses (cddr form)))
(call-with-values (lambda ()
(parse-package-clauses clauses rename compare))
(lambda (opens accesses for-syntaxes others)
(let ((%make (rename 'make-a-package))
(%lambda (rename 'lambda))
(%cons (rename 'cons))
(%list (rename 'list))
(%quote (rename 'quote))
(%a-package (rename 'a-package))
(%file-name (rename '%file-name%)))
`(,%make (,%lambda () (,%list ,@opens))
(,%lambda ()
(,%list ,@(map (lambda (a)
`(,%cons (,%quote ,a) ,a))
accesses)))
(,(string->symbol ".make-reflective-tower.")
(,%quote ,for-syntaxes)
(,%quote ,names))
(,%file-name)
(,%quote ,others)
(,%quote ,(cadr form)))))))))
(cons lambda list make-a-package quote %file-name%))
(define-syntax receive
(syntax-rules ()
((receive (?var ...) ?producer . ?body)
(call-with-values (lambda () ?producer)
(lambda (?var ...)
(note-name! ?var '?var) ...
(let () . ?body))))))
; (DEFINE-REFLECTIVE-TOWER-MAKER <proc>)
; <proc> should be an expression that evaluates to a procedure of
; two arguments. The first argument is a list of DEFINE-STRUCTURE
; clauses, and the second is some identifying information (no
; semantic content). The procedure should return a "reflective
; tower", which is a pair (<eval-proc> . <env>). To evaluate the
; right-hand side of a DEFINE-SYNTAX (LET-SYNTAX, etc.) form,
; <eval-proc> is called on the right-hand side and <env>.
; Got that?
(define-syntax define-reflective-tower-maker
(lambda (e r c)
`(,(r 'define) ,(string->symbol ".make-reflective-tower.") ,(cadr e)))
(define))
(define-syntax export-reflective-tower-maker
(lambda (e r c)
`(,(r 'export) ,(string->symbol ".make-reflective-tower.")))
(export))
; Modules = package combinators...
(define-syntax define-module
(syntax-rules ()
((define-module (?name . ?args) ?body ...)
(def ?name (lambda ?args ?body ...)))))

711
bcomp/mtype.scm
View File

@ -1,711 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Type lattice.
; Sorry this is so hairy, but before it was written, type checking
; consumed 15% of compile time.
; f : t1 -> t2 restrictive means:
; if x : t1 then (f x) : t2 (possible error!), else (f x) : error.
; f : t1 -> t2 nonrestrictive means:
; There exists an x : t1 such that (f x) : t2.
(define-record-type meta-type :meta-type
(really-make-type mask more info)
meta-type?
(mask type-mask)
(more type-more)
(info type-info))
(define-record-discloser :meta-type
(lambda (t)
`(type ,(let ((m (type-mask t)))
(or (table-ref mask->name-table m) m))
,(let ((more (type-more t)))
(if (and (pair? more) (eq? (cdr more) t))
'*
more))
,(type-info t))))
(define (make-type mask more info)
(make-immutable!
(really-make-type mask more info)))
(define name->type-table (make-table))
(define mask->name-table (make-table))
(define (name->type x)
(or (table-ref name->type-table x)
(make-other-type x)))
(define (set-type-name! type name)
(table-set! name->type-table name type)
(if (not (or (type-info type)
(type-more type)))
(table-set! mask->name-table (type-mask type) name)))
; Masks
; Top of lattice has mask = -1, bottom has mask = 0.
(define *mask* 1)
(define (new-type-bit)
(let ((m *mask*))
(set! *mask* (arithmetic-shift *mask* 1))
m))
(define (mask->type mask)
(make-type mask #f #f))
(define bottom-type (mask->type 0))
(define error-type bottom-type)
(define (bottom-type? t)
(= (type-mask t) 0))
(set-type-name! bottom-type ':error)
(define (new-atomic-type)
(mask->type (new-type-bit)))
(define (named-atomic-type name)
(let ((t (new-atomic-type)))
(set-type-name! t name)
t))
; --------------------
; Top of the lattice.
(define syntax-type (named-atomic-type ':syntax))
(define other-static-type (new-atomic-type))
; --------------------
; "Rails" are argument sequence or return value sequences.
; Four constructors:
; empty-rail-type
; (rail-type t1 t2)
; (optional-rail-type t1 t2)
; (make-rest-type t)
; If a type's two-or-more? bit is set, then
; more = (head . tail).
; Otherwise, more = #f.
(define empty-rail-type (new-atomic-type))
(define (rail-type t1 t2) ;CONS analog
(cond ((empty-rail-type? t2) t1)
((bottom-type? t1) t1)
((bottom-type? t2) t2)
((and (optional-type? t1)
(rest-type? t2)
(same-type? t1 (head-type t2)))
;; Turn (&opt t &rest t) into (&rest t)
t2)
((or (optional-type? t1)
(optional-type? t2))
(make-type (bitwise-ior (type-mask t1) mask/two-or-more)
(make-immutable! (cons t1 t2))
#f))
(else
(make-type mask/two-or-more
(make-immutable! (cons t1 t2))
(type-info t1)))))
(define (make-optional-type t)
(if (type-more t)
(warn "peculiar type in make-optional-type" t))
(make-type (bitwise-ior (type-mask t) mask/no-values)
#f
(type-info t)))
(define (make-rest-type t)
(if (bottom-type? t)
t
(let* ((z (cons (make-optional-type t) #f))
(t (make-type (bitwise-ior (type-mask t) mask/&rest)
z
(type-info t))))
(set-cdr! z t)
(make-immutable! z)
t)))
(define (head-type t) ;Can return an &opt type
(let ((more (type-more t)))
(if more
(car more)
t)))
(define (head-type-really t) ;Always returns a value type
(let ((h (head-type t)))
(if (optional-type? h)
(make-type (bitwise-and (type-mask h) (bitwise-not mask/no-values))
#f
(type-info h))
h)))
(define (tail-type t)
(if (empty-rail-type? t)
;; bottom-type ?
(warn "rail-type of empty rail" t))
(let ((more (type-more t)))
(if more
(cdr more)
empty-rail-type)))
(define (empty-rail-type? t)
(= (bitwise-and (type-mask t) mask/one-or-more) 0))
(define (rest-type? t) ;For terminating recursions
(let ((more (type-more t)))
(and more
(eq? (cdr more) t))))
(define (optional-type? t)
(> (bitwise-and (type-mask t) mask/no-values) 0))
; The no-values type has one element, the rail of length zero.
; The two-or-more type consists of all rails of length two
; or more.
(define mask/no-values (type-mask empty-rail-type))
(define mask/two-or-more (new-type-bit))
(define mask/&rest (bitwise-ior (type-mask empty-rail-type)
mask/two-or-more))
(table-set! mask->name-table mask/no-values ':no-values)
(define value-type (mask->type (bitwise-not (- *mask* 1))))
(set-type-name! value-type ':value)
(define mask/value (type-mask value-type))
(define (value-type? t)
(let ((m (type-mask t)))
(= (bitwise-and m mask/value) m)))
(define any-values-type
(make-rest-type value-type))
(set-type-name! any-values-type ':values)
(define any-arguments-type any-values-type)
(define mask/one-or-more
(bitwise-ior mask/value mask/two-or-more))
; --------------------
; Lattice operations.
; Equivalence
(define (same-type? t1 t2)
(or (eq? t1 t2)
(and (= (type-mask t1) (type-mask t2))
(let ((more1 (type-more t1))
(more2 (type-more t2)))
(if more1
(and more2
(if (eq? (cdr more1) t1)
(eq? (cdr more2) t2)
(if (eq? (cdr more2) t2)
#f
(and (same-type? (car more1) (car more2))
(same-type? (cdr more1) (cdr more2))))))
(not more2)))
(let ((info1 (type-info t1))
(info2 (type-info t2)))
(or (eq? info1 info2)
(and (pair? info1)
(pair? info2)
(same-type? (car info1) (car info2)) ;Procedure
(same-type? (cadr info1) (cadr info2))
(eq? (caddr info1) (caddr info2))))))))
(define (subtype? t1 t2) ;*** optimize later
(same-type? t1 (meet-type t1 t2)))
; (mask->type mask/procedure) represents the TOP of the procedure
; subhierarchy.
(define (meet-type t1 t2)
(if (same-type? t1 t2)
t1
(let ((m (bitwise-and (type-mask t1) (type-mask t2))))
(cond ((> (bitwise-and m mask/two-or-more) 0)
(meet-rail t1 t2))
((eq? (type-info t1) (type-info t2))
(make-type m #f (type-info t1)))
((> (bitwise-and m mask/other) 0)
(let ((i1 (other-type-info t1))
(i2 (other-type-info t2)))
(if (and i1 i2)
(mask->type (bitwise-and m (bitwise-not mask/other)))
(make-type m
#f
(or i1 i2)))))
((> (bitwise-and m mask/procedure) 0)
(meet-procedure m t1 t2))
(else (mask->type m))))))
(define (other-type-info t)
(let ((i (type-info t)))
(if (pair? i) #f i)))
(define (p name x) (write `(,name ,x)) (newline) x)
(define (meet-rail t1 t2)
(let ((t (meet-type (head-type t1) (head-type t2))))
(if (and (rest-type? t1)
(rest-type? t2))
(make-rest-type t)
(rail-type t (meet-type (tail-type t1)
(tail-type t2))))))
; Start with these assumptions:
;
; . (meet? t1 t2) == (not (bottom-type? (meet-type t1 t2)))
; . (subtype? t1 t2) == (same-type? t1 (meet-type t1 t2))
; . (subtype? t1 t2) == (same-type? t2 (join-type t1 t2))
; . We signal a type error if not (intersect? have want).
; . We infer the type of a parameter by intersecting the want-types
; of all definitely-reached points of use.
;
; 1. If both types are nonrestrictive, we have to JOIN both domains
; and codomains (if we are to avoid conjunctive types).
;
; (+ (f 1) (car (f 'a))) [reconstructing type of f by computing meet of all contexts]
; => meet (proc (:integer) :number nonr) (proc (:symbol) :pair nonr)
; => (proc ((join :integer :symbol) (join :number :pair)) nonr), yes?
;
; 2. If both types are restrictive, we need to MEET both domains and
; codomains.
;
; (define (foo) 3), (export (foo (proc (:value) :value)))
; Error - disjoint domains.
;
; (define (foo) 'baz), (export (foo (proc () :number)))
; Error - disjoint codomains.
;
; 3. If one is restrictive and the other isn't then we still need to
; MEET on both sides.
;
; (with-output-to-file "foo" car)
; => meet (proc () :any nonr), (proc (:pair) :value restr)
; => Error - disjoint domains.
;
; (frob (lambda () 'a)) where (define (frob f) (+ (f) 1))
; => meet (proc () :symbol restr), (proc () :number nonr)
; => Error - disjoint codomains.
;
; Does export checking look for (intersect? want have), or for
; (subtype? want have) ? We should be able to narrow something as we
; export it, but not widen it.
;
; (define (foo . x) 3), (export (foo (proc (value) value)))
; No problem, since the domain of the first contains the domain of the second.
;
; (define (foo x . x) (+ x 3)), (export (foo (proc (value) value)))
; Dubious; the domains intersect but are incomparable. The meet
; should be (proc (number) number).
;
; (define (foo x) (numerator x)), (export (foo (proc (real) integer)))
; This is dubious, since the stated domain certainly contains values
; that will be rejected. (But then, what about divide by zero, or
; vector indexing?)
;
; (define (foo x) (numerator x)), (export (foo (proc (integer) integer)))
; This should definitely be OK.
(define (meet-procedure m t1 t2)
(let ((dom1 (procedure-type-domain t1))
(dom2 (procedure-type-domain t2))
(cod1 (procedure-type-codomain t1))
(cod2 (procedure-type-codomain t2)))
(cond ((or (restrictive? t1) (restrictive? t2))
(let ((dom (meet-type dom1 dom2))
(cod (meet-type cod1 cod2)))
(if (or (bottom-type? dom)
(and (bottom-type? cod)
(not (bottom-type? cod1)) ;uck
(not (bottom-type? cod2))))
(mask->type (bitwise-and m (bitwise-not mask/procedure)))
(make-procedure-type m
dom
cod
#t))))
((and (subtype? dom2 dom1) (subtype? cod2 cod1))
;; exists x : dom1 s.t. (f x) : cod1 adds no info
(make-procedure-type m dom2 cod2 #f))
(else
;; Arbitrary choice.
(make-procedure-type m dom1 cod1 #f)))))
; MEET? is the operation used all the time by the compiler. We want
; getting a yes answer to be as fast as possible. We could do
;
; (define (meet? t1 t2) (not (bottom-type? (meet-type t1 t2))))
;
; but that would be too slow.
(define (meet? t1 t2)
(or (eq? t1 t2)
(let ((m (bitwise-and (type-mask t1) (type-mask t2))))
(cond ((= m mask/two-or-more)
(and (meet? (head-type t1) (head-type t2))
(meet? (tail-type t1) (tail-type t2))))
((= m 0) #f)
((eq? (type-info t1) (type-info t2)) #t)
((= m mask/other)
(not (and (other-type-info t1) (other-type-info t2))))
((= m mask/procedure) (meet-procedure? t1 t2))
(else #t)))))
(define (meet-procedure? t1 t2)
(if (or (restrictive? t1) (restrictive? t2))
(and (meet? (procedure-type-domain t1) (procedure-type-domain t2))
(meet? (procedure-type-codomain t1) (procedure-type-codomain t2)))
#t))
; Join
(define (join-type t1 t2)
(if (same-type? t1 t2)
t1
(let ((m (bitwise-ior (type-mask t1) (type-mask t2))))
(if (> (bitwise-and m mask/two-or-more) 0)
(join-rail t1 t2)
(let ((info1 (type-info t1)) (info2 (type-info t2)))
(cond ((equal? info1 info2)
(make-type m #f (type-info t1)))
((> (bitwise-and m mask/other) 0)
(make-type m #f #f))
((> (bitwise-and m mask/procedure) 0)
(join-procedure m t1 t2))
(else
(error "This shouldn't happen" t1 t2))))))))
(define (join-rail t1 t2)
(let ((t (join-type (head-type t1) (head-type t2))))
(if (and (rest-type? t1)
(rest-type? t2))
(make-rest-type t)
(rail-type t
(if (type-more t1)
(if (type-more t2)
(join-type (tail-type t1)
(tail-type t2))
(tail-type t1))
(tail-type t2))))))
; This is pretty gross.
(define (join-procedure m t1 t2)
(if (procedure-type? t1)
(if (procedure-type? t2)
(let ((dom1 (procedure-type-domain t1))
(dom2 (procedure-type-domain t2))
(cod1 (procedure-type-codomain t1))
(cod2 (procedure-type-codomain t2)))
(make-procedure-type m
(join-type dom1 dom2) ;Error when outside here
(join-type cod1 cod2)
(and (restrictive? t1) (restrictive? t2))))
(make-type m #f (type-info t1)))
(make-type m #f (type-info t2))))
; --------------------
; Value types.
; First, the ten indivisible number types.
(define number-hierarchy
'(:integer :rational :real :complex :number))
(let loop ((names number-hierarchy)
(exact bottom-type)
(inexact bottom-type))
(if (null? names)
(begin (set-type-name! exact ':exact)
(set-type-name! inexact ':inexact))
(let* ((exact (join-type exact (new-atomic-type)))
(inexact (join-type inexact (new-atomic-type))))
(set-type-name! (join-type exact inexact)
(car names))
(loop (cdr names)
exact
inexact))))
(define integer-type (name->type ':integer))
(define rational-type (name->type ':rational))
(define real-type (name->type ':real))
(define complex-type (name->type ':complex))
(define number-type (name->type ':number))
(define exact-type (name->type ':exact))
(define inexact-type (name->type ':inexact))
(define exact-integer-type (meet-type integer-type exact-type))
(set-type-name! exact-integer-type ':exact-integer)
; Next, all the others.
(define boolean-type (named-atomic-type ':boolean))
(define pair-type (named-atomic-type ':pair))
(define null-type (named-atomic-type ':null))
(define record-type (named-atomic-type ':record))
(define any-procedure-type (named-atomic-type ':procedure))
; ???
; (define procedure-nonbottom-type (new-atomic-type))
; (define procedure-bottom-type (new-atomic-type))
; (define mask/procedure (meet procedure-nonbottom-type procedure-bottom-type))
; OTHER-VALUE-TYPE is a catchall for all the other ones we don't
; anticipate (for now including string, vector, char, etc.).
(define other-value-type (named-atomic-type ':other))
(define mask/other (type-mask other-value-type))
(define (make-other-type id)
(let ((t (make-type mask/other #f id)))
(set-type-name! t id)
t))
(define char-type (make-other-type ':char))
(define unspecific-type (make-other-type ':unspecific))
(define string-type (make-other-type ':string))
(define symbol-type (make-other-type ':symbol))
(define vector-type (make-other-type ':vector))
(define escape-type (make-other-type ':escape))
(define structure-type (make-other-type ':structure))
; --------------------
; Procedures.
(define mask/procedure (type-mask any-procedure-type))
(define (procedure-type dom cod r?)
(make-procedure-type mask/procedure dom cod r?))
(define (make-procedure-type m dom cod r?)
(make-type m
#f
(if (and (not r?)
(same-type? dom value-type)
(same-type? cod value-type))
#f ;LUB of all procedure types
(list dom cod r?))))
(define (procedure-type-domain t)
(let ((info (type-info t)))
(if (pair? info)
(car info)
any-values-type)))
(define (procedure-type-codomain t)
(let ((info (type-info t)))
(if (pair? info)
(cadr info)
any-values-type)))
(define (restrictive? t)
(let ((info (type-info t)))
(if (pair? info)
(caddr info)
#f)))
; --------------------
; Conversion to and from S-expression.
(define (sexp->type x r?)
(cond ((symbol? x)
(name->type x))
((pair? x)
(case (car x)
((some-values)
(sexp->values-type (cdr x) #t r?))
((proc)
(let ((r? (if (or (null? (cdddr x))
(eq? (cadddr x) r?))
r?
(not r?))))
(procedure-type (sexp->values-type (cadr x) #t (not r?))
(sexp->type (caddr x) r?)
r?)))
((meet)
(if (null? (cdr x))
bottom-type
(let ((l (map (lambda (x) (sexp->type x r?)) (cdr x))))
(reduce meet-type (car l) (cdr l)))))
((join)
(let ((l (map (lambda (x) (sexp->type x r?)) (cdr x))))
(reduce join-type (car l) (cdr l))))
((mask->type)
(mask->type (cadr x)))
(else (error "unrecognized type" x))))
(else (error "unrecognized type" x))))
(define (sexp->values-type l req? r?)
(cond ((null? l) empty-rail-type)
((eq? (car l) '&rest)
(make-rest-type (sexp->type (cadr l) r?)))
((eq? (car l) '&opt)
(sexp->values-type (cdr l) #f r?))
(else
(let ((t (sexp->type (car l) r?)))
(rail-type (if req? t (make-optional-type t))
(sexp->values-type (cdr l)
req?
r?))))))
; Convert type to S-expression
(define (type->sexp t r?)
(if (> (bitwise-and (type-mask t) mask/&rest) 0)
(if (same-type? t any-values-type)
':values
`(some-values ,@(rail-type->sexp t r?)))
(let ((j (disjoin-type t)))
(cond ((null? j) ':error)
((null? (cdr j))
(atomic-type->sexp (car j) r?))
(else
`(join ,@(map (lambda (t)
(atomic-type->sexp t r?))
j)))))))
(define (atomic-type->sexp t r?)
(let ((m (type-mask t)))
(cond ((and (not (type-info t))
(table-ref mask->name-table m)))
((= m mask/other)
(or (type-info t) ':value)) ;not quite
((= m mask/procedure)
(let ((r (restrictive? t)))
`(proc ,(rail-type->sexp (procedure-type-domain t)
(not r))
,(type->sexp (procedure-type-codomain t) r)
,@(if (eq? r r?)
'()
`(,r)))))
((type-info t)
`(ill-formed ,(type-mask t) ,(type-info t)))
((subtype? t exact-type)
`(meet :exact
,(type->sexp (mask->type (let ((m (type-mask t)))
(bitwise-ior m (arithmetic-shift m 1))))
#t)))
((subtype? t inexact-type)
`(meet :inexact
,(type->sexp (mask->type (let ((m (type-mask t)))
(bitwise-ior m (arithmetic-shift m -1))))
#t)))
;; ((meet? t number-type) ...)
(else
`(mask->type ,(type-mask t))))))
(define (rail-type->sexp t r?)
(let recur ((t t) (prev-req? #t) (r? r?))
(cond ((empty-rail-type? t) '())
((rest-type? t)
`(&rest ,(type->sexp (head-type-really t) r?)))
((optional-type? t)
(let ((tail (cons (type->sexp (head-type-really t) r?)
(recur (tail-type t) #f r?))))
(if prev-req?
`(&opt ,@tail)
tail)))
(else
(cons (type->sexp (head-type t) r?)
(recur (tail-type t) #t r?))))))
; Decompose a type into components
(define (disjoin-type t)
(cond ((bottom-type? t) '())
((and (not (type-info t))
(table-ref mask->name-table (type-mask t)))
(list t))
((meet? t other-value-type)
(cons (meet-type t other-value-type)
(disjoin-rest t mask/other)))
((meet? t any-procedure-type)
(cons (meet-type t any-procedure-type)
(disjoin-rest t mask/procedure)))
((meet? t number-type)
(cons (meet-type t number-type)
(disjoin-rest t mask/number)))
(else
(do ((i 1 (arithmetic-shift i 1)))
((> (bitwise-and (type-mask t) i) 0)
(cons (mask->type i)
(disjoin-rest t i)))))))
(define (disjoin-rest t mask)
(disjoin-type (mask->type (bitwise-and (type-mask t)
(bitwise-not mask)))))
(define mask/number (type-mask number-type))
; --------------------
; obsolescent? see lambda and values reconstructors in recon.scm
(define (make-some-values-type types)
(if (null? types)
empty-rail-type
(rail-type (car types) (make-some-values-type (cdr types)))))
(define-syntax proc
(syntax-rules ()
((proc (?type ...) ?cod)
(procedure-type (some-values ?type ...) ?cod #t))
((proc (?type ...) ?cod ?r)
(procedure-type (some-values ?type ...) ?cod ?r))))
(define-syntax some-values
(syntax-rules (&opt &rest)
((some-values) empty-rail-type)
((some-values &opt) empty-rail-type)
((some-values ?t) ?t)
((some-values &rest ?t) (make-rest-type ?t))
((some-values &opt &rest ?t) (make-rest-type ?t))
((some-values &opt ?t1 . ?ts)
(rail-type (make-optional-type ?t1)
(some-values &opt . ?ts)))
((some-values ?t1 . ?ts)
(rail-type ?t1 (some-values . ?ts)))))
(define (procedure-type? t)
(= (type-mask t) mask/procedure))
(define (fixed-arity-procedure-type? t)
(and (procedure-type? t)
(let loop ((d (procedure-type-domain t)))
(cond ((empty-rail-type? d) #t)
((optional-type? d) #f)
(else (loop (tail-type d)))))))
(define (procedure-type-arity t)
(do ((d (procedure-type-domain t) (tail-type d))
(i 0 (+ i 1)))
((empty-rail-type? d) i)
(if (optional-type? d)
(error "this shouldn't happen" t d))))
(define (procedure-type-argument-types t)
(let recur ((d (procedure-type-domain t)))
(cond ((empty-rail-type? d) '())
((optional-type? d)
(call-error "lossage" procedure-type-argument-types t))
(else
(cons (head-type d)
(recur (tail-type d)))))))

425
bcomp/package.scm
View File

@ -1,425 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Structures 'n' packages.
; --------------------
; Structures
(define-record-type structure :structure
(really-make-structure package interface-thunk interface clients name)
structure?
(interface-thunk structure-interface-thunk)
(interface structure-interface-really set-structure-interface!)
(package structure-package) ; allow #f
(clients structure-clients)
(name structure-name set-structure-name!))
(define-record-discloser :structure
(lambda (s) (list 'structure
(package-uid (structure-package s))
(structure-name s))))
(define (structure-interface s)
(or (structure-interface-really s)
(begin (initialize-structure! s)
(structure-interface-really s))))
(define (initialize-structure! s)
(let ((int ((structure-interface-thunk s))))
(if (interface? int)
(begin (set-structure-interface! s int)
(note-reference-to-interface! int s))
(call-error "invalid interface" initialize-structure! s))))
(define (make-structure package int-thunk . name-option)
(if (not (package? package))
(call-error "invalid package" make-structure package int-thunk))
(let ((struct (really-make-structure package
(if (procedure? int-thunk)
int-thunk
(lambda () int-thunk))
#f
(make-population)
#f)))
(if (not (null? name-option))
(note-structure-name! struct (car name-option)))
(add-to-population! struct (package-clients package))
struct))
(define (structure-unstable? struct)
(package-unstable? (structure-package struct)))
(define (for-each-export proc struct)
(let ((int (structure-interface struct)))
(for-each-declaration
(lambda (name want-type)
(let ((binding (structure-lookup struct name #t)))
(proc name
(if (and (binding? binding)
(eq? want-type undeclared-type))
(let ((type (binding-type binding)))
(if (variable-type? type)
(variable-value-type type)
type))
want-type)
binding)))
int)))
(define (note-structure-name! struct name)
(if (and name (not (structure-name struct)))
(begin (set-structure-name! struct name)
(note-package-name! (structure-package struct) name))))
; --------------------
; Packages
(define-record-type package :package
(really-make-package uid
opens-thunk opens accesses-thunk
definitions
get-location
plist
cached
clients
unstable?
file-name clauses loaded?)
package?
(uid package-uid)
(opens package-opens-really set-package-opens!)
(definitions package-definitions)
(unstable? package-unstable?)
(integrate? package-integrate? set-package-integrate?!)
;; For EVAL and LOAD (which can only be done in unstable packages)
(get-location package-get-location set-package-get-location!)
(file-name package-file-name)
(clauses package-clauses)
(loaded? package-loaded? set-package-loaded?!)
(env package->environment set-package->environment!)
;; For package mutation
(opens-thunk package-opens-thunk set-package-opens-thunk!)
(accesses-thunk package-accesses-thunk)
(plist package-plist set-package-plist!)
(clients package-clients)
(cached package-cached))
(define-record-discloser :package
(lambda (p)
(let ((name (package-name p)))
(if name
(list 'package (package-uid p) name)
(list 'package (package-uid p))))))
(define (make-package opens-thunk accesses-thunk unstable? tower file clauses
uid name)
(let ((p (really-make-package
(if uid
(begin (if (>= uid *package-uid*)
(set! *package-uid* (+ uid 1)))
uid)
(new-package-uid))
opens-thunk
#f ;opens
accesses-thunk ;thunk returning alist
(make-table name-hash) ;definitions
(fluid $get-location) ;procedure for making new locations
'() ;property list...
(make-table name-hash) ;bindings cached in templates
(make-population) ;structures
unstable? ;unstable (suitable for EVAL)?
file ;file containing DEFINE-STRUCTURE form
clauses ;misc. DEFINE-STRUCTURE clauses
#f))) ;loaded?
(note-package-name! p name)
(set-package->environment! p (really-package->environment p))
(if unstable? ;+++
(define-funny-names! p tower))
p))
(define (really-package->environment p)
(lambda (name)
(package-lookup p name)))
; Unique id's
(define (new-package-uid)
(let ((uid *package-uid*)) ;unique identifier
(set! *package-uid* (+ *package-uid* 1))
uid))
(define *package-uid* 0)
; Package names
(define package-name-table (make-table))
(define (package-name package)
(table-ref package-name-table (package-uid package)))
(define (note-package-name! package name)
(if name
(let ((uid (package-uid package)))
(if (not (table-ref package-name-table uid))
(table-set! package-name-table uid name)))))
(define (package-opens p)
(initialize-package-if-necessary! p)
(package-opens-really p))
(define (initialize-package-if-necessary! p)
(if (not (package-opens-really p))
(initialize-package! p)))
(define (package-accesses p) ;=> alist
((package-accesses-thunk p)))
; --------------------
; A simple package has no ACCESSes or other far-out clauses.
(define (make-simple-package opens unstable? tower . name-option)
(if (not (list? opens))
(error "invalid package opens list" opens))
(let ((p (make-package (lambda () opens)
(lambda () '()) ;accesses-thunk
unstable?
tower
"" ;file containing DEFINE-STRUCTURE form
'() ;clauses
#f ;uid
(if (null? name-option)
#f
(car name-option)))))
(set-package-loaded?! p #t)
p))
; --------------------
; The definitions table
; Each entry in the package-definitions table is a binding
; #(type place static). "Place" will typically be a location,
; but it doesn't have to be.
(define (package-definition p name)
(initialize-package-if-necessary! p)
(let ((probe (table-ref (package-definitions p) name)))
(if probe
(maybe-fix-place probe)
#f)))
; Disgusting. Interface predates invention of "binding" records.
(define (package-define! p name type-or-static . place-option)
(let ((place (if (null? place-option)
#f
(car place-option))))
(cond ((transform? type-or-static)
(really-package-define! p name
(transform-type type-or-static)
place
type-or-static))
((operator? type-or-static)
(really-package-define! p name
(operator-type type-or-static)
place
type-or-static))
(else
(really-package-define! p name
type-or-static
place
#f)))))
(define (really-package-define! p name type place static)
(let ((probe (table-ref (package-definitions p) name)))
(if probe
(begin (clobber-binding! probe type place static)
(binding-place (maybe-fix-place probe)))
(let ((place (or place (get-new-location p name))))
(table-set! (package-definitions p)
name
(make-binding type place static))
place))))
; --------------------
; Lookup
; Look up a name in a package. Returns a binding if bound, or a name if
; not. In the unbound case, the name returned is either the original
; name or, if the name is generated, the name's underlying symbol.
(define (package-lookup p name)
(really-package-lookup p name (package-integrate? p)))
(define (really-package-lookup p name integrate?)
(let ((probe (package-definition p name)))
(cond (probe
(if integrate?
probe
(forget-integration probe)))
((generated? name)
(generic-lookup (generated-env name)
(generated-symbol name)))
(else
(let loop ((opens (package-opens-really p)))
(if (null? opens)
name ;Unbound
(or (structure-lookup (car opens) name integrate?)
(loop (cdr opens)))))))))
; Get a name's binding in a structure. If the structure doesn't
; export the name, this returns #f. If the structure exports the name
; but the name isn't bound, it returns the name.
(define (structure-lookup struct name integrate?)
(let ((type (interface-ref (structure-interface struct) name)))
(if type
(impose-type type
(really-package-lookup (structure-package struct)
name
integrate?)
integrate?)
#f)))
(define (generic-lookup env name)
(cond ((package? env)
(package-lookup env name))
((structure? env)
(or (structure-lookup env name
(package-integrate? (structure-package env)))
(call-error "not exported" generic-lookup env name)))
((procedure? env)
(lookup env name))
(else
(error "invalid environment" env name))))
; --------------------
; Package initialization
(define (initialize-package! p)
(let ((opens ((package-opens-thunk p))))
(set-package-opens! p opens)
(for-each (lambda (struct)
(if (structure-unstable? struct)
(add-to-population! p (structure-clients struct))))
opens))
(for-each (lambda (name+struct)
;; Cf. CLASSIFY method for STRUCTURE-REF
(really-package-define! p
(car name+struct)
structure-type
#f
(cdr name+struct)))
(package-accesses p)))
(define (define-funny-names! p tower)
(package-define-funny! p funny-name/the-package p)
(if tower
(package-define-funny! p funny-name/reflective-tower
tower)))
(define (package-define-funny! p name static)
(table-set! (package-definitions p)
name
(make-binding syntax-type (cons 'dummy-place name) static)))
; The following funny name is bound in every package to the package
; itself. This is a special hack used by the byte-code compiler
; (procedures LOCATION-FOR-UNDEFINED and NOTE-CACHING) so that it can
; extract the underlying package from any environment.
(define funny-name/the-package (string->symbol ".the-package."))
(define (extract-package-from-environment env)
(get-funny env funny-name/the-package))
; (define (package->environment? env)
; (eq? env (package->environment
; (extract-package-from-environment env))))
; --------------------
; For implementation of INTEGRATE-ALL-PRIMITIVES! in scanner, etc.
(define (for-each-definition proc p)
(table-walk (lambda (name binding)
(proc name (maybe-fix-place binding)))
(package-definitions p)))
; --------------------
; Locations
(define (get-new-location p name)
((package-get-location p) p name))
; Default new-location method for new packages
(define (make-new-location p name)
(let ((uid *location-uid*))
(set! *location-uid* (+ *location-uid* 1))
(table-set! location-info-table uid
(make-immutable!
(cons (name->symbol name) (package-uid p))))
(make-undefined-location uid)))
(define $get-location (make-fluid make-new-location))
(define *location-uid* 5000) ; 1510 in initial system as of 1/22/94
(define location-info-table (make-table))
(define (flush-location-names)
(set! location-info-table (make-table))
;; (set! package-name-table (make-table)) ;hmm, not much of a space saver
)
; --------------------
; Extra
(define (package-get p ind)
(cond ((assq ind (package-plist p)) => cdr)
(else #f)))
(define (package-put! p ind val)
(cond ((assq ind (package-plist p)) => (lambda (z) (set-cdr! z val)))
(else (set-package-plist! p (cons (cons ind val)
(package-plist p))))))
; compiler calls this
(define (package-note-caching p name place)
(if (package-unstable? p) ;?????
(if (not (table-ref (package-definitions p) name))
(let loop ((opens (package-opens p)))
(if (not (null? opens))
(if (interface-ref (structure-interface (car opens))
name)
(begin (table-set! (package-cached p) name place)
(package-note-caching
(structure-package (car opens))
name place))
(loop (cdr opens)))))))
place)
; Special kludge for shadowing and package mutation.
; Ignore this on first reading. See env/shadow.scm.
(define (maybe-fix-place b)
(let ((place (binding-place b)))
(if (and (location? place)
(vector? (location-id place)))
(set-binding-place! b (follow-forwarding-pointers place))))
b)
(define (follow-forwarding-pointers place)
(let ((id (location-id place)))
(if (vector? id)
(follow-forwarding-pointers (vector-ref id 0))
place)))
; (put 'package-define! 'scheme-indent-hook 2)

383
bcomp/recon.scm
View File

@ -1,383 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Rudimentary type reconstruction, hardly worthy of the name.
; Currently, NODE-TYPE is called in two places. One is to determine
; the type of the right-hand side of a DEFINE for a variable that is
; never assigned, so uses of the variable can be checked later. The
; other is when compiling a call, to check types of arguments and
; produce warning messages.
; This is heuristic, to say the least. It's not clear what the right
; interface or formalism is for Scheme; I'm still experimenting.
; Obviously we can't do Hindley-Milner inference. Not only does
; Scheme have subtyping, but it also has dependent types up the wazoo.
; For example, the following is perfectly correct Scheme:
;
; (define (foo x y) (if (even? x) (car y) (vector-ref y 3)))
(define (node-type node env)
;; Ignore env, since we don't ever call CLASSIFY or LOOKUP.
(reconstruct node 'fast any-values-type))
(define (reconstruct-type node env)
(reconstruct node '() any-values-type))
(define (reconstruct node constrained want-type)
(cond ((node? node)
((operator-table-ref reconstructors (node-operator-id node))
node constrained want-type))
((pair? node) any-values-type)
((name? node) value-type)
(else (constant-type node))))
(define reconstructors
(make-operator-table (lambda (node constrained want-type)
(reconstruct-call node constrained want-type))))
(define (define-reconstructor name type proc)
(operator-define! reconstructors name type proc))
(define-reconstructor 'lambda syntax-type
(lambda (node constrained want-type)
(if (eq? constrained 'fast)
any-procedure-type
(let ((form (node-form node))
(var-nodes (node-ref node 'var-nodes))
(want-result (careful-codomain want-type)))
(let ((formals (cadr form)))
(if var-nodes
(let* ((alist (map (lambda (node) (cons node value-type))
var-nodes))
;; We can't do (append alist constrained) because the
;; lambda might not be called...
(cod (reconstruct-body (cddr form)
alist
want-result)))
(procedure-type (if (n-ary? formals)
any-values-type ;lose
(make-some-values-type (map cdr alist)))
cod
#t))
(procedure-type
(if (n-ary? formals)
any-values-type ;lose
(make-some-values-type (map (lambda (f) value-type)
formals)))
(reconstruct-body (cddr form) constrained want-result)
#t)))))))
(define (careful-codomain proc-type)
(if (procedure-type? proc-type)
(procedure-type-codomain proc-type)
any-values-type))
(define (reconstruct-body body constrained want-type)
(if (null? (cdr body))
(reconstruct (car body) constrained want-type)
any-values-type))
(define operator/name (get-operator 'name))
(define-reconstructor 'name 'leaf
(lambda (node constrained want-type)
(if (eq? constrained 'fast)
(reconstruct-name node)
(let ((z (assq node constrained)))
(if z
(let ((type (meet-type (cdr z) want-type)))
(begin (set-cdr! z type)
type))
(reconstruct-name node))))))
(define (reconstruct-name node)
(let ((probe (node-ref node 'binding)))
(if (binding? probe)
(let ((t (binding-type probe)))
(cond ((variable-type? t) (variable-value-type t))
((subtype? t value-type) t)
(else value-type)))
value-type)))
(define (reconstruct-call node constrained want-type)
(let* ((form (node-form node))
(op-type (reconstruct (car form)
constrained
(procedure-type any-arguments-type
want-type
#f)))
(args (cdr form))
(lose (lambda ()
(for-each (lambda (arg)
(examine arg constrained value-type))
args))))
(if (procedure-type? op-type)
(begin (if (restrictive? op-type)
(let loop ((args args)
(dom (procedure-type-domain op-type)))
(if (not (or (null? args)
(empty-rail-type? dom)))
(begin (examine (car args)
constrained
(head-type dom))
(loop (cdr args) (tail-type dom)))))
(lose))
(procedure-type-codomain op-type))
(begin (lose)
any-values-type))))
(define-reconstructor 'literal 'leaf
(lambda (node constrained want-type)
(constant-type (node-form node))))
(define-reconstructor 'quote syntax-type
(lambda (node constrained want-type)
(constant-type (cadr (node-form node)))))
(define-reconstructor 'if syntax-type
(lambda (node constrained want-type)
(let ((form (node-form node)))
(examine (cadr form) constrained value-type)
;; Fork off two different constrain sets
(let ((con-alist (fork-constraints constrained))
(alt-alist (fork-constraints constrained)))
(let ((con-type (reconstruct (caddr form) con-alist want-type))
(alt-type (reconstruct (cadddr form) alt-alist want-type)))
(if (pair? constrained)
(for-each (lambda (c1 c2 c)
(set-cdr! c (join-type (cdr c1) (cdr c2))))
con-alist
alt-alist
constrained))
(join-type con-type alt-type))))))
(define (fork-constraints constrained)
(if (pair? constrained)
(map (lambda (x) (cons (car x) (cdr x)))
constrained)
constrained))
(define-reconstructor 'begin syntax-type
(lambda (node constrained want-type)
;; This is unsound - there might be a throw out of some subform
;; other than the final one.
(do ((forms (cdr (node-form node)) (cdr forms)))
((null? (cdr forms))
(reconstruct (car forms) constrained want-type))
(examine (car forms) constrained any-values-type))))
(define (examine node constrained want-type)
(if (pair? constrained)
(reconstruct node constrained want-type)
want-type))
(define-reconstructor 'set! syntax-type
(lambda (node constrained want-type)
(examine (caddr (node-form node)) constrained value-type)
unspecific-type))
(define-reconstructor 'letrec syntax-type
(lambda (node constrained want-type)
(let ((form (node-form node)))
(if (eq? constrained 'fast)
(reconstruct (last form) 'fast want-type)
(let ((types (map (lambda (spec)
(reconstruct (cadr spec) constrained value-type))
(cadr form))))
(reconstruct (last form)
(let ((nodes (node-ref node 'var-nodes)))
(if nodes
(append (map cons nodes types)
constrained)
constrained))
want-type))))))
(define-reconstructor 'primitive-procedure syntax-type
(lambda (node constrained want-type)
(operator-type (get-operator (cadr (node-form node)))))) ;mumble
(define-reconstructor 'loophole syntax-type
(lambda (node constrained want-type)
(let ((args (cdr (node-form node))))
(examine (cadr args) constrained any-values-type)
(sexp->type (schemify (car args)) #t)))) ;Foo
(define (node->type node)
(if (node? node)
(let ((form (node-form node)))
(if (pair? form)
(map node->type form)
(desyntaxify form)))
(desyntaxify node)))
(define-reconstructor 'define syntax-type
(lambda (node constrained want-type)
':definition))
(define-reconstructor 'define-syntax syntax-type
(lambda (node constrained want-type)
':definition))
(define call-node? (node-predicate 'call))
(define name-node? (node-predicate 'name))
(define begin-node? (node-predicate 'begin))
; --------------------
; Primitive procedures:
(define-reconstructor 'values any-procedure-type
(lambda (node constrained want-type)
(make-some-values-type (map (lambda (node)
(meet-type
(reconstruct node constrained value-type)
value-type))
(cdr (node-form node))))))
(define-reconstructor 'call-with-values
(proc ((proc () any-values-type #f)
any-procedure-type)
any-values-type)
(lambda (node constrained want-type)
(let* ((args (cdr (node-form node)))
(thunk-type (reconstruct (car args)
constrained
(procedure-type empty-rail-type
any-values-type
#f))))
(careful-codomain
(reconstruct (cadr args)
constrained
(procedure-type (careful-codomain thunk-type)
any-values-type
#f))))))
(define (reconstruct-apply node constrained want-type)
(let* ((args (cdr (node-form node)))
(proc-type (reconstruct (car args)
constrained
any-procedure-type)))
(for-each (lambda (arg) (examine arg constrained value-type))
(cdr args))
(careful-codomain proc-type)))
(define-reconstructor 'apply
(proc (any-procedure-type &rest value-type) any-values-type)
reconstruct-apply)
(define-reconstructor 'primitive-catch
(proc ((proc (escape-type) any-values-type #f))
any-values-type)
reconstruct-apply)
; --------------------
; Types of simple primitives.
(define (declare-operator-type ops type)
(if (list? ops)
(for-each (lambda (op) (get-operator op type))
ops)
(get-operator ops type)))
(declare-operator-type 'with-continuation
(proc (escape-type (proc () any-values-type #f))
any-arguments-type))
(declare-operator-type 'eq?
(proc (value-type value-type) boolean-type))
(declare-operator-type '(number? integer? rational? real? complex?
char? eof-object? input-port? output-port?)
(proc (value-type) boolean-type))
(declare-operator-type 'exact?
(proc (number-type) boolean-type))
(declare-operator-type 'exact->inexact (proc (exact-type) inexact-type))
(declare-operator-type 'inexact->exact (proc (inexact-type) exact-type))
(declare-operator-type '(exp log sin cos tan asin acos sqrt)
(proc (number-type) number-type))
(declare-operator-type '(atan)
(proc (number-type number-type) number-type))
(declare-operator-type '(floor)
(proc (real-type) integer-type))
(declare-operator-type '(real-part imag-part angle magnitude)
(proc (complex-type) real-type))
(declare-operator-type '(numerator denominator)
(proc (rational-type) integer-type))
(declare-operator-type '(+ * - /)
(proc (number-type number-type) number-type))
(declare-operator-type '(= <)
(proc (real-type real-type) boolean-type))
(declare-operator-type '(make-polar make-rectangular)
(proc (real-type real-type) complex-type))
(declare-operator-type '(quotient remainder)
(proc (integer-type integer-type) integer-type))
(declare-operator-type '(bitwise-not)
(proc (exact-integer-type) exact-integer-type))
(declare-operator-type '(bitwise-and bitwise-ior bitwise-xor
arithmetic-shift)
(proc (exact-integer-type exact-integer-type)
exact-integer-type))
(declare-operator-type '(char=? char<?)
(proc (char-type char-type) boolean-type))
(declare-operator-type 'char->ascii
(proc (char-type) exact-integer-type))
(declare-operator-type 'ascii->char
(proc (exact-integer-type) char-type))
(declare-operator-type 'string=?
(proc (string-type string-type) boolean-type))
(declare-operator-type 'open-port
;; Can return #f
(proc (string-type exact-integer-type) value-type))
(declare-operator-type 'cons (proc (value-type value-type) pair-type))
(declare-operator-type 'intern (proc (string-type vector-type) symbol-type))
; Can't do I/O until the meta-types interface exports input-port-type and
; output-port-type.
(define (constant-type x)
(cond ((number? x)
(meet-type (if (exact? x) exact-type inexact-type)
(cond ((integer? x) integer-type)
((rational? x) rational-type)
((real? x) real-type)
((complex? x) complex-type)
(else number-type))))
((boolean? x) boolean-type)
((pair? x) pair-type)
((string? x) string-type)
((char? x) char-type)
((null? x) null-type)
((symbol? x) symbol-type)
((vector? x) vector-type)
(else value-type)))

253
bcomp/rules.scm
View File

@ -1,253 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; The syntax-rules macro (new in R5RS)
; Example:
;
; (define-syntax or
; (syntax-rules ()
; ((or) #f)
; ((or e) e)
; ((or e1 e ...) (let ((temp e1))
; (if temp temp (or e ...))))))
(define-usual-macro 'syntax-rules 1
(lambda (r c subkeywords . rules)
;; Pair of the procedure and list of auxiliary names
`(,(r 'cons)
,(process-rules rules subkeywords r c)
(,(r 'quote) ,(find-free-names-in-syntax-rules subkeywords rules))))
'(append and car cdr cond cons else eq? equal? lambda let let* map
pair? quote values))
(define (process-rules rules subkeywords r c)
(define %append (r 'append))
(define %and (r 'and))
(define %car (r 'car))
(define %cdr (r 'cdr))
(define %compare (r 'compare))
(define %cond (r 'cond))
(define %cons (r 'cons))
(define %else (r 'else))
(define %eq? (r 'eq?))
(define %equal? (r 'equal?))
(define %input (r 'input))
(define %lambda (r 'lambda))
(define %let (r 'let))
(define %let* (r 'let*))
(define %map (r 'map))
(define %pair? (r 'pair?))
(define %quote (r 'quote))
(define %rename (r 'rename))
(define %tail (r 'tail))
(define %temp (r 'temp))
(define (make-transformer rules)
`(,%lambda (,%input ,%rename ,%compare)
(,%let ((,%tail (,%cdr ,%input)))
(,%cond ,@(map process-rule rules)
(,%else ,%input))))) ;Error when left unchanged.
(define (process-rule rule)
(if (and (pair? rule)
(pair? (cdr rule))
(null? (cddr rule)))
(let ((pattern (cdar rule))
(template (cadr rule)))
`((,%and ,@(process-match %tail pattern))
(,%let* ,(process-pattern pattern
%tail
(lambda (x) x))
,(process-template template
0
(meta-variables pattern 0 '())))))
(syntax-error "ill-formed syntax rule" rule)))
; Generate code to test whether input expression matches pattern
(define (process-match input pattern)
(cond ((name? pattern)
(if (member pattern subkeywords)
`((,%compare ,input (,%rename ',pattern)))
`()))
((segment-pattern? pattern)
(process-segment-match input (car pattern)))
((pair? pattern)
`((,%let ((,%temp ,input))
(,%and (,%pair? ,%temp)
,@(process-match `(,%car ,%temp) (car pattern))
,@(process-match `(,%cdr ,%temp) (cdr pattern))))))
((or (null? pattern) (boolean? pattern) (char? pattern))
`((,%eq? ,input ',pattern)))
(else
`((,%equal? ,input ',pattern)))))
(define (process-segment-match input pattern)
(let ((conjuncts (process-match '(car l) pattern)))
(if (null? conjuncts)
`((list? ,input)) ;+++
`((let loop ((l ,input))
(or (null? l)
(and (pair? l)
,@conjuncts
(loop (cdr l)))))))))
; Generate code to take apart the input expression
; This is pretty bad, but it seems to work (can't say why).
(define (process-pattern pattern path mapit)
(cond ((name? pattern)
(if (memq pattern subkeywords)
'()
(list (list pattern (mapit path)))))
((segment-pattern? pattern)
(process-pattern (car pattern)
%temp
(lambda (x) ;temp is free in x
(mapit (if (eq? %temp x)
path ;+++
`(,%map (,%lambda (,%temp) ,x)
,path))))))
((pair? pattern)
(append (process-pattern (car pattern) `(,%car ,path) mapit)
(process-pattern (cdr pattern) `(,%cdr ,path) mapit)))
(else '())))
; Generate code to compose the output expression according to template
(define (process-template template dim env)
(cond ((name? template)
(let ((probe (assq template env)))
(if probe
(if (<= (cdr probe) dim)
template
(syntax-error "template dimension error (too few ...'s?)"
template))
`(,%rename ',template))))
((segment-template? template)
(let ((vars
(free-meta-variables (car template) (+ dim 1) env '())))
(if (null? vars)
(syntax-error "too many ...'s" template)
(let* ((x (process-template (car template)
(+ dim 1)
env))
(gen (if (equal? (list x) vars)
x ;+++
`(,%map (,%lambda ,vars ,x)
,@vars))))
(if (null? (cddr template))
gen ;+++
`(,%append ,gen ,(process-template (cddr template)
dim env)))))))
((pair? template)
`(,%cons ,(process-template (car template) dim env)
,(process-template (cdr template) dim env)))
(else `(,%quote ,template))))
; Return an association list of (var . dim)
(define (meta-variables pattern dim vars)
(cond ((name? pattern)
(if (memq pattern subkeywords)
vars
(cons (cons pattern dim) vars)))
((segment-pattern? pattern)
(meta-variables (car pattern) (+ dim 1) vars))
((pair? pattern)
(meta-variables (car pattern) dim
(meta-variables (cdr pattern) dim vars)))
(else vars)))
; Return a list of meta-variables of given higher dim
(define (free-meta-variables template dim env free)
(cond ((name? template)
(if (and (not (memq template free))
(let ((probe (assq template env)))
(and probe (>= (cdr probe) dim))))
(cons template free)
free))
((segment-template? template)
(free-meta-variables (car template)
dim env
(free-meta-variables (cddr template)
dim env free)))
((pair? template)
(free-meta-variables (car template)
dim env
(free-meta-variables (cdr template)
dim env free)))
(else free)))
(make-transformer rules))
(define (segment-pattern? pattern)
(and (segment-template? pattern)
(or (null? (cddr pattern))
(syntax-error "segment matching not implemented" pattern))))
(define (segment-template? pattern)
(and (pair? pattern)
(pair? (cdr pattern))
(memq (cadr pattern) indicators-for-zero-or-more)))
(define indicators-for-zero-or-more (list (string->symbol "...")))
;(define (name? thing)
; (or (symbol? thing)
; (not (or (pair? thing) ;Kludge!
; (null? thing)
; (number? thing)
; (boolean? thing)
; (char? thing)
; (string? thing)))))
; The following is used by Scheme 48's static linker.
(define (find-free-names-in-syntax-rules subkeywords rules)
(define (meta-variables pattern vars)
(cond ((name? pattern)
(if (memq pattern subkeywords)
vars
(cons pattern vars)))
((segment-pattern? pattern)
(meta-variables (car pattern) ;vars
(meta-variables (cddr pattern) vars)))
((pair? pattern)
(meta-variables (car pattern)
(meta-variables (cdr pattern) vars)))
(else vars)))
(define (free-names template vars names)
(cond ((name? template)
(if (or (memq template vars)
(memq template names))
names
(cons template names)))
((segment-template? template)
(free-names (car template)
vars
(free-names (cddr template) vars names)))
((pair? template)
(free-names (car template)
vars
(free-names (cdr template) vars names)))
(else names)))
(do ((rules rules (cdr rules))
(names subkeywords
(let ((rule (car rules)))
(free-names (cadr rule)
(meta-variables (cdar rule) '())
names))))
((null? rules) names)))

125
bcomp/schemify.scm
View File

@ -1,125 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; schemify
; Flush nodes and generated names in favor of something a little more
; readable. Eventually, (schemify node) ought to produce an
; s-expression that has the same semantics as node, when node is fully
; expanded.
(define (schemify node . env-option)
(schemify1 node (if (null? env-option) #f (car env-option))))
(define (schemify1 node env)
(if (node? node)
(or (node-ref node 'schemify)
(let ((form ((operator-table-ref schemifiers (node-operator-id node))
node env)))
(node-set! node 'schemify form)
form))
(schemify-sexp node env)))
(define schemifiers
(make-operator-table (lambda (node env)
(let ((form (node-form node)))
(if (list? form)
(map (lambda (f) (schemify1 f env)) form)
form)))))
(define (define-schemifier name type proc)
(operator-define! schemifiers name type proc))
(define-schemifier 'name 'leaf
(lambda (node env)
(name->qualified (node-form node) env)))
(define-schemifier 'quote syntax-type
(lambda (node env)
(let ((form (node-form node)))
(list (schemify1 (car form) env) (cadr form)))))
; Convert an alias (generated name) to S-expression form ("qualified name").
;
; As an optimization, we elide intermediate steps in the lookup path
; when possible. E.g.
; #(>> #(>> #(>> define-record-type define-accessors)
; define-accessor)
; record-ref)
; is replaced with
; #(>> define-record-type record-ref)
(define (name->qualified name env)
(if env
(if (generated? name)
(if (same-denotation? (lookup env name)
(lookup env (generated-symbol name)))
(generated-symbol name) ;+++
(make-qualified
(let recur ((name (generated-parent-name name)))
(if (generated? name)
(let ((parent (generated-parent-name name)))
(if (let ((b1 (lookup env name))
(b2 (lookup env parent)))
(or (same-denotation? b1 b2)
(and (binding? b1)
(binding? b2)
(let ((s1 (binding-static b1))
(s2 (binding-static b2)))
(and (transform? s1)
(transform? s2)
(eq? (transform-env s1)
(transform-env s2)))))))
(recur parent) ;+++
`#(>> ,(recur parent)
,(generated-symbol name))))
name))
(generated-symbol name)))
name)
(desyntaxify name)))
; lambda, let-syntax, letrec-syntax...
(define-schemifier 'letrec syntax-type
(lambda (node env)
(let ((form (node-form node)))
`(letrec ,(map (lambda (spec)
`(,(car spec) ,(schemify1 (cadr spec) env)))
(cadr form))
,@(map (lambda (f) (schemify1 f env))
(cddr form))))))
(define (schemify-sexp thing env)
(cond ((name? thing)
(name->qualified thing env))
((pair? thing)
(let ((x (schemify-sexp (car thing) env))
(y (schemify-sexp (cdr thing) env)))
(if (and (eq? x (car thing))
(eq? y (cdr thing)))
thing ;+++
(cons x y))))
((vector? thing)
(let ((new (make-vector (vector-length thing) #f)))
(let loop ((i 0) (same? #t))
(if (>= i (vector-length thing))
(if same? thing new) ;+++
(let ((x (schemify-sexp (vector-ref thing i) env)))
(vector-set! new i x)
(loop (+ i 1)
(and same? (eq? x (vector-ref thing i)))))))))
(else thing)))
; Qualified names
(define (make-qualified transform-name sym)
(vector '>> transform-name sym))
(define (qualified? thing)
(and (vector? thing)
(= (vector-length thing) 3)
(eq? (vector-ref thing 0) '>>)))
(define (qualified-parent-name q) (vector-ref q 1))
(define (qualified-symbol q) (vector-ref q 2))

230
bcomp/segment.scm
View File

@ -1,230 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; The byte code compiler's assembly phase.
(define make-segment cons)
(define segment-size car);number of bytes that will be taken in the code vector
(define segment-emitter cdr)
(define (segment->template segment name pc-in-parent)
(let* ((cv (make-code-vector (segment-size segment) 0))
(astate (make-astate cv))
(parent-data (fluid $debug-data))
(name (if (if (name? name)
(keep-procedure-names?)
(keep-file-names?)) ;string, or pair, or something
name #f))
(debug-data (new-debug-data (if (name? name) (name->symbol name) name)
parent-data ;(debug-data-if-interesting ?)
pc-in-parent)))
(let-fluid $debug-data debug-data
(lambda ()
(let ((maps (emit-with-environment-maps! astate segment)))
(set-debug-data-env-maps! debug-data maps)
(make-immutable! cv)
(segment-data->template cv
(debug-data->info debug-data)
(reverse (astate-literals astate))))))))
(define (segment-data->template cv debug-data literals)
(let ((template (make-template (+ template-overhead (length literals)) 0)))
(set-template-code! template cv)
(set-template-info! template debug-data)
(do ((lits literals (cdr lits))
(i template-overhead (+ i 1)))
((null? lits) template)
(template-set! template i (car lits)))))
; "astate" is short for "assembly state"
(define-record-type assembly-state :assembly-state
(make-assembly-state cv pc count lits)
(cv astate-code-vector)
(pc astate-pc set-astate-pc!)
(count astate-count set-astate-count!)
(lits astate-literals set-astate-literals!))
(define (make-astate cv)
(make-assembly-state cv 0 template-overhead '()))
(define (emit-byte! a byte)
(code-vector-set! (astate-code-vector a) (astate-pc a) byte)
(set-astate-pc! a (+ (astate-pc a) 1)))
(define (emit-literal! a thing)
(emit-byte! a
(let ((probe (position thing (astate-literals a)))
(count (astate-count a)))
(if probe
;; +++ Eliminate duplicate entries.
;; Not necessary, just a modest space saver [how much?].
;; Measurably slows down compilation.
;; when 1 thing, lits = (x), count = 3, probe = 0, want 2
(- (- count probe) 1)
(begin
(if (>= count byte-limit)
(error "compiler bug: too many literals"
thing))
(set-astate-literals! a (cons thing (astate-literals a)))
(set-astate-count! a (+ count 1))
count)))))
(define (emit-segment! astate segment)
((segment-emitter segment) astate))
; Segment constructors
(define empty-segment
(make-segment 0 (lambda (astate) #f)))
(define (instruction opcode . operands)
(make-segment (+ 1 (length operands))
(lambda (astate)
(emit-byte! astate opcode)
(for-each (lambda (operand)
(emit-byte! astate operand))
operands))))
(define (sequentially . segments)
(reduce sequentially-2 empty-segment segments))
(define (sequentially-2 seg1 seg2)
(cond ((eq? seg1 empty-segment) seg2) ;+++ speed up the compiler a tad
((eq? seg2 empty-segment) seg1) ;+++
(else
(make-segment (+ (segment-size seg1)
(segment-size seg2))
(lambda (astate)
(emit-segment! astate seg1)
(emit-segment! astate seg2)))))) ;tail call
; Literals are obtained from the template.
(define (instruction-with-literal opcode thing)
(make-segment 2
(lambda (astate)
(emit-byte! astate opcode)
(emit-literal! astate thing))))
; So are locations.
(define (instruction-with-location opcode thunk)
(make-segment 2
(lambda (astate)
(emit-byte! astate opcode)
;; But: there really ought to be multiple entries
;; depending on how the name is qualified.
(emit-literal! astate (thunk)))))
; Templates for inferior closures are also obtained from the
; (parent's) template.
(define (instruction-with-template opcode segment name)
(make-segment 2
(lambda (astate)
(emit-byte! astate opcode)
(emit-literal! astate
(segment->template segment
name
(astate-pc astate))))))
; Labels. Each label maintains a list of pairs (instr . origin).
; Instr is the index of the first of two bytes that will hold the jump
; target offset, and the offset stored will be (- jump-target origin).
(define (make-label) (list #f))
(define (instruction-using-label opcode label . rest)
(let ((segment (apply instruction opcode 0 0 rest)))
(make-segment (segment-size segment)
(lambda (astate)
(let ((instr (+ (astate-pc astate) 1)))
(emit-segment! astate segment)
(if (car label)
(warn "backward jumps not supported")
(set-cdr! label
(cons (cons instr (astate-pc astate))
(cdr label)))))))))
(define (attach-label label segment)
(make-segment
(segment-size segment)
(lambda (astate)
(let ((pc (astate-pc astate))
(cv (astate-code-vector astate)))
(for-each (lambda (instr+origin)
(let ((instr (car instr+origin))
(origin (cdr instr+origin)))
(let ((offset (- pc origin)))
(code-vector-set! cv instr
(quotient offset byte-limit))
(code-vector-set! cv (+ instr 1)
(remainder offset byte-limit)))))
(cdr label))
(set-car! label pc)
(emit-segment! astate segment)))))
; byte-limit is larger than the largest value that will fit in one opcode
; byte.
(define byte-limit (expt 2 bits-used-per-byte))
; Special segments for maintaining debugging information. Not
; essential for proper functioning of compiler.
(define $debug-data (make-fluid #f))
; Keep track of source code at continuations.
(define (note-source-code info segment)
(if (keep-source-code?)
(make-segment (segment-size segment)
(lambda (astate)
(emit-segment! astate segment)
(let ((dd (fluid $debug-data)))
(set-debug-data-source!
dd
(cons (cons (astate-pc astate)
;; Abbreviate this somehow?
(if (pair? info)
(cons (car info)
(schemify (cdr info)))
;; Name might be generated...
info))
(debug-data-source dd))))))
segment))
; Keep track of variable names from lexical environments.
; Each environment map has the form
; #(pc-before pc-after (var ...) (env-map ...))
(define (note-environment vars segment)
(if (keep-environment-maps?)
(make-segment (segment-size segment)
(lambda (astate)
(let* ((pc-before (astate-pc astate))
(env-maps
(emit-with-environment-maps! astate segment)))
(set-fluid! $environment-maps
(cons (vector pc-before
(astate-pc astate)
(list->vector
(map name->symbol vars))
env-maps)
(fluid $environment-maps))))))
segment))
(define (emit-with-environment-maps! astate segment)
(let-fluid $environment-maps '()
(lambda ()
(emit-segment! astate segment)
(fluid $environment-maps))))
(define $environment-maps (make-fluid '()))
(define environment-maps-table (make-table))

79
bcomp/state.scm
View File

@ -1,79 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Compiler state, including flags controlling debug data retention.
; Package and location uids and the location name table should be here
; as well...
; Will the use of a fluid variable significantly degrade performance?
(define (new-template-uid)
(let ((uid *template-uid*))
(set! *template-uid* (+ *template-uid* 1))
uid))
(define *template-uid* 5000) ; 1548 in initial system as of 1/22/94
(define (template-uid) *template-uid*)
(define (set-template-uid! uid) (set! *template-uid* uid))
; These variables really ought to be dynamically scoped, not global.
; Fix this some day.
(define debug-flag-names '(names maps files source tabulate table))
(define type/debug-flags
(make-record-type 'debug-flags debug-flag-names))
(define make-debug-flags
(record-constructor type/debug-flags debug-flag-names))
(define $debug-flags
(make-fluid (make-debug-flags #t ;proc names
#f ;env maps
#f ;no file names
#f ;no cont source
#f ;no tabulate
(make-table))))
(define (debug-flag-accessor name)
(let ((access (record-accessor type/debug-flags name)))
(lambda () (access (fluid $debug-flags)))))
(define (debug-flag-modifier name)
(let ((modify (record-modifier type/debug-flags name)))
(lambda (new) (modify (fluid $debug-flags) new))))
(define keep-source-code? (debug-flag-accessor 'source))
(define keep-environment-maps? (debug-flag-accessor 'maps))
(define keep-procedure-names? (debug-flag-accessor 'names))
(define keep-file-names? (debug-flag-accessor 'files))
(define tabulate-debug-data? (debug-flag-accessor 'tabulate))
(define debug-data-table (debug-flag-accessor 'table))
; Kludge for static linker.
(define (with-fresh-compiler-state template-uid-origin thunk)
(let-fluid $debug-flags (make-debug-flags #t ;proc names
#f ;env maps
#f ;no file names
#f ;no cont source
#t ;tabulate ***
(make-table))
(lambda ()
(saving-and-restoring (lambda () *template-uid*)
(lambda (s) (set! *template-uid* s))
template-uid-origin
thunk))))
(define (saving-and-restoring fetch store! other thunk)
(let ((swap (lambda ()
(let ((temp (fetch)))
(store! other)
(set! other temp)))))
(dynamic-wind swap thunk swap)))

825
bcomp/syntax.scm
View File

@ -1,825 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Syntactic stuff: transforms and operators.
(define usual-operator-type
(procedure-type any-arguments-type value-type #f))
; --------------------
; Operators (= special operators and primitives)
(define-record-type operator :operator
(make-operator type nargs uid name)
operator?
(type operator-type set-operator-type!)
(nargs operator-nargs)
(uid operator-uid)
(name operator-name))
(define-record-discloser :operator
(lambda (s)
(list 'operator
(operator-name s)
(type->sexp (operator-type s) #t))))
(define (get-operator name . type-option)
(let ((type (if (null? type-option) #f (car type-option)))
(probe (table-ref operators-table name)))
(if (operator? probe)
(let ((previous-type (operator-type probe)))
(cond ((not type))
((symbol? type) ; 'leaf or 'internal
(if (not (eq? type previous-type))
(warn "operator type inconsistency" name type previous-type)))
((subtype? type previous-type) ;Improvement
(set-operator-type! probe type))
((not (subtype? previous-type type))
(warn "operator type inconsistency"
name
(type->sexp previous-type 'foo)
(type->sexp type 'foo))))
probe)
(let* ((uid *operator-uid*)
(type (or type usual-operator-type))
(op (make-operator type
(if (and (not (symbol? type))
(fixed-arity-procedure-type? type))
(procedure-type-arity type)
#f)
uid
name)))
(if (>= uid number-of-operators)
(warn "too many operators" (operator-name op) (operator-type op)))
(set! *operator-uid* (+ *operator-uid* 1))
(table-set! operators-table (operator-name op) op)
(vector-set! the-operators uid op)
op))))
(define *operator-uid* 0)
(define operators-table (make-table))
(define number-of-operators 200) ;Fixed-size limits bad, but speed good
(define the-operators (make-vector number-of-operators #f))
; --------------------
; Operator tables (for fast dispatch)
(define (make-operator-table default . mumble-option)
(let ((v (make-vector number-of-operators default)))
(if (not (null? mumble-option))
(define-usual-suspects v (car mumble-option)))
v))
(define operator-table-ref vector-ref)
(define (operator-lookup table op)
(operator-table-ref table (operator-uid op)))
(define (operator-define! table name proc-or-type . proc-option)
(if (null? proc-option)
(vector-set! table ;Obsolescent
(operator-uid (if (pair? name)
(get-operator (car name) (cadr name))
(get-operator name)))
proc-or-type)
(vector-set! table
(operator-uid (get-operator name proc-or-type))
(car proc-option))))
; --------------------
; Nodes
; A node is an annotated expression (or definition or other form).
; The FORM component of a node is an S-expression of the same form as
; the S-expression representation of the expression. E.g. for
; literals, the form is the literal value; for variables the form is
; the variable name; for IF expressions the form is a 4-element list
; (ignored test con alt). Nodes also have a tag identifying what kind
; of node it is (literal, variable, if, etc.) and a property list.
(define-record-type node :node
(really-make-node uid form plist)
node?
(uid node-operator-id)
(form node-form)
(plist node-plist set-node-plist!))
(define-record-discloser :node
(lambda (n) (list (operator-name (node-operator n)) (node-form n))))
(define (make-node operator form)
(really-make-node (operator-uid operator) form '()))
(define (node-ref node key)
(let ((probe (assq key (node-plist node))))
(if probe (cdr probe) #f)))
(define (node-set! node key value) ;gross
(if value
(let ((probe (assq key (node-plist node))))
(if probe
(set-cdr! probe value)
(set-node-plist! node (cons (cons key value) (node-plist node)))))
(let loop ((l (node-plist node)) (prev #f))
(cond ((null? l) 'lose)
((eq? key (caar l))
(if prev
(set-cdr! prev (cdr l))
(set-node-plist! node (cdr l))))
(else (loop (cdr l) l))))))
(define (node-operator node)
(vector-ref the-operators (node-operator-id node)))
(define (node-predicate name . type-option)
(let ((id (operator-uid (apply get-operator name type-option))))
(lambda (node)
(= (node-operator-id node) id))))
(define (make-similar-node node form)
(if (equal? form (node-form node))
node
(make-node (node-operator node) form)))
; --------------------
; Generated names
; Generated names make lexically-scoped macros work. They're the same
; as what Alan Bawden and Chris Hanson call "aliases". The parent
; field is always another name (perhaps generated). The parent chain
; provides an access path to the name's binding, should one ever be
; needed. That is: If name M is bound to a transform T that generates
; name G as an alias for name N, then M is (generated-parent-name G),
; so we can get the binding of G by accessing the binding of N in T's
; environment of closure, and we get T by looking up M in the
; environment in which M is *used*.
(define-record-type generated :generated
(make-generated symbol token env parent-name)
generated?
(symbol generated-symbol)
(token generated-token)
(env generated-env)
(parent-name generated-parent-name))
(define-record-discloser :generated
(lambda (name)
(list 'generated (generated-symbol name) (generated-uid name))))
(define (generate-name symbol env parent-name) ;for opt/inline.scm
(make-generated symbol (cons #f #f) env parent-name)) ;foo
(define (generated-uid g)
(let ((t (generated-token g)))
(or (car t)
(let ((uid *generated-uid*))
(set! *generated-uid* (+ *generated-uid* 1))
(set-car! t uid)
uid))))
(define *generated-uid* 0)
(define (name->symbol name)
(if (symbol? name)
name
(string->symbol (string-append (symbol->string (generated-symbol name))
"##"
(number->string (generated-uid name))))))
(define (name-hash name)
(cond ((symbol? name)
(string-hash (symbol->string name)))
((generated? name)
(name-hash (generated-symbol name)))
(else (error "invalid name" name))))
; Used by QUOTE to turn generated names back into symbols
(define (desyntaxify thing)
(cond ((or (boolean? thing) (null? thing) (number? thing)
(symbol? thing) (char? thing))
thing)
((string? thing)
(make-immutable! thing))
((generated? thing) (desyntaxify (generated-symbol thing)))
((pair? thing)
(make-immutable!
(let ((x (desyntaxify (car thing)))
(y (desyntaxify (cdr thing))))
(if (and (eq? x (car thing))
(eq? y (cdr thing)))
thing
(cons x y)))))
((vector? thing)
(make-immutable!
(let ((new (make-vector (vector-length thing) #f)))
(let loop ((i 0) (same? #t))
(if (>= i (vector-length thing))
(if same? thing new)
(let ((x (desyntaxify (vector-ref thing i))))
(vector-set! new i x)
(loop (+ i 1)
(and same? (eq? x (vector-ref thing i))))))))))
((operator? thing)
(warn "operator in quotation" thing)
(operator-name thing)) ;Foo
(else
(warn "invalid datum in quotation" thing)
thing)))
; --------------------
; Transforms
; A transform represents a source-to-source rewrite rule: either a
; macro or an in-line procedure.
(define-record-type transform :transform
(really-make-transform xformer env type aux-names source id)
transform?
(xformer transform-procedure)
(env transform-env)
(type transform-type)
(aux-names transform-aux-names)
(source transform-source) ;for reification
(id transform-id))
(define (make-transform thing env type source id)
(let ((type (if (or (pair? type) (symbol? type))
(sexp->type type #t)
type)))
(make-immutable!
(if (pair? thing)
(really-make-transform (car thing) env type (cdr thing) source id)
(really-make-transform thing env type #f source id)))))
(define-record-discloser :transform
(lambda (m) (list 'transform (transform-id m))))
(define (maybe-transform t exp env-of-use)
(let* ((token (cons #f #f))
(new-env (bind-aliases token t env-of-use))
(rename (make-name-generator (transform-env t)
token
(node-form (car exp))))
(compare
(lambda (name1 name2)
(or (eqv? name1 name2)
(and (name? name1)
(name? name2)
(same-denotation? (lookup new-env name1)
(lookup new-env name2)))))))
(values ((transform-procedure t) exp rename compare)
new-env
token)))
(define (bind-aliases token t env-of-use)
(let ((env-of-definition (transform-env t)))
(if (procedure? env-of-definition)
(lambda (name)
(if (and (generated? name)
(eq? (generated-token name) token))
(lookup env-of-definition (generated-symbol name))
(lookup env-of-use name)))
env-of-use))) ;Lose
(define (make-name-generator env token parent-name)
(let ((alist '())) ;list of (symbol . generated)
(lambda (symbol)
(if (symbol? symbol)
(let ((probe (assq symbol alist)))
(if probe
(cdr probe)
(let ((new-name (make-generated symbol token env parent-name)))
(set! alist (cons (cons symbol new-name)
alist))
new-name)))
(error "non-symbol argument to rename procedure"
symbol parent-name)))))
(define (same-denotation? x y)
(or (equal? x y)
(and (binding? x)
(binding? y)
(eq? (binding-place x) (binding-place y)))))
; --------------------
; Bindings: the things that are usually returned by LOOKUP.
; Representation is #(type place operator-or-transform-or-#f).
; For top-level bindings, place is usually a location.
(define binding? vector?)
(define (binding-type b) (vector-ref b 0))
(define (binding-place b) (vector-ref b 1))
(define (binding-static b) (vector-ref b 2))
(define (set-binding-place! b place) (vector-set! b 1 place))
(define (make-binding type place static)
(let ((b (make-vector 3 place)))
(vector-set! b 0 type)
(vector-set! b 2 static)
b))
(define (clobber-binding! b type place static)
(vector-set! b 0 type)
(if place
(set-binding-place! b place))
(vector-set! b 2 static))
; Return a binding that's similar to the given one, but has its type
; replaced with the given type.
(define (impose-type type b integrate?)
(if (or (eq? type syntax-type)
(not (binding? b)))
b
(make-binding (if (eq? type undeclared-type)
(let ((type (binding-type b)))
(if (variable-type? type)
(variable-value-type type)
type))
type)
(binding-place b)
(if integrate?
(binding-static b)
#f))))
; Return a binding that's similar to the given one, but has any
; procedure integration or other unnecesary static information
; removed. But don't remove static information for macros (or
; structures, interfaces, etc.)
(define (forget-integration b)
(if (and (binding-static b)
(subtype? (binding-type b) any-values-type))
(make-binding (binding-type b)
(binding-place b)
#f)
b))
; --------------------
; Expression classifier. Returns a node.
(define (classify form env)
(cond ((node? form)
(if (and (name-node? form)
(not (node-ref form 'binding)))
(classify-name (node-form form) env)
form))
((name? form)
(classify-name form env))
((pair? form)
(let ((op-node (classify (car form) env)))
(if (name-node? op-node)
(let ((probe (node-ref op-node 'binding)))
(if (binding? probe)
(let ((s (binding-static probe)))
(cond ((operator? s)
(classify-operator-form s op-node form env))
((and (transform? s)
(eq? (binding-type probe) syntax-type))
;; Non-syntax transforms (i.e. procedure
;; integrations) get done by MAYBE-TRANSFORM-CALL.
(classify-macro-application
s (cons op-node (cdr form)) env))
(else
(classify-call op-node form env))))
(classify-call op-node form env)))
(classify-call op-node form env))))
((literal? form)
(classify-literal form))
;; ((qualified? form) ...)
(else
(classify (syntax-error "invalid expression" form) env))))
(define call-node? (node-predicate 'call 'internal))
(define name-node? (node-predicate 'name 'leaf))
(define classify-literal
(let ((op (get-operator 'literal 'leaf)))
(lambda (exp)
(make-node op exp))))
(define classify-call
(let ((operator/call (get-operator 'call 'internal)))
(lambda (proc-node exp env)
(make-node operator/call
(if (eq? proc-node (car exp))
exp ;+++
(cons proc-node (cdr exp)))))))
; An environment is a procedure that takes a name and returns one of
; the following:
;
; 1. A binding record.
; 2. A node, which is taken to be a substitution for the name.
; 3. Another name, meaning that the first name is unbound. The name
; returned will be a symbol even if the original name was generated.
;
; In case 1, CLASSIFY caches the binding as the node's BINDING property.
; In case 2, it simply returns the node.
(define (classify-name name env)
(let ((binding (lookup env name)))
(if (node? binding)
binding
(let ((node (make-node operator/name name)))
(if (not (unbound? binding))
(node-set! node 'binding binding))
node))))
(define operator/name (get-operator 'name 'leaf))
; Expand a macro or in-line procedure application.
(define (classify-macro-application t form env-of-use)
(classify-transform-application
t form env-of-use
(lambda ()
(classify (syntax-error "use of macro doesn't match definition"
(cons (schemify (car form) env-of-use)
(desyntaxify (cdr form))))
env-of-use))))
(define classify-transform-application
(let ((operator/with-aliases (get-operator 'with-aliases syntax-type)))
(lambda (t form env-of-use lose)
(call-with-values (lambda () (maybe-transform t form env-of-use))
(lambda (new-form new-env token)
(cond ((eq? new-form form)
(lose))
((eq? new-env env-of-use)
(classify new-form new-env))
(else
(make-node operator/with-aliases
`(with-aliases ,(car form)
,token
,new-form)))))))))
(define (maybe-transform-call proc-node node env)
(if (name-node? proc-node)
(let ((b (or (node-ref proc-node 'binding)
(lookup env (node-form proc-node)))))
(if (binding? b)
(let ((s (binding-static b)))
(cond ((transform? s)
(classify-transform-application s
(node-form node)
env
(lambda () node)))
;; ((operator? s) (make-node s (node-form node)))
(else node)))
node))
node))
; --------------------
; Specialist classifiers for particular operators
(define (classify-operator-form op op-node form env)
((operator-table-ref classifiers (operator-uid op))
op op-node form env))
(define classifiers
(make-operator-table (lambda (op op-node form env)
(if (let ((nargs (operator-nargs op)))
(or (not nargs)
(= nargs (length (cdr form)))))
(make-node op (cons op-node (cdr form)))
(classify-call op-node form env)))))
(define (define-classifier name proc)
(operator-define! classifiers name syntax-type proc))
; Remove generated names from quotations.
(define-classifier 'quote
(lambda (op op-node exp env)
(make-node op (list op-node (desyntaxify (cadr exp))))))
; Convert one-armed IF to two-armed IF.
(define-classifier 'if
(lambda (op op-node exp env)
(make-node op
(cons op-node
(if (null? (cdddr exp))
(append (cdr exp) (list (unspecific-node)))
(cdr exp))))))
(define unspecific-node
(let ((op (get-operator 'unspecific
(proc () unspecific-type))))
(lambda ()
(make-node op '(unspecific)))))
; Rewrite (define (name . vars) body ...)
; as (define foo (lambda vars body ...)).
(define-classifier 'define
(let ((operator/lambda (get-operator 'lambda syntax-type))
(operator/unassigned (get-operator 'unassigned
(proc () value-type)))) ;foo
(lambda (op op-node form env)
(let ((pat (cadr form)))
(make-node op
(cons op-node
(if (pair? pat)
(list (car pat)
(make-node operator/lambda
`(lambda ,(cdr pat)
,@(cddr form))))
(list pat
(if (null? (cddr form))
(make-node operator/unassigned
`(unassigned))
(caddr form))))))))))
;(define (make-define-node op op-node lhs rhs)
; (make-node op (list op-node lhs rhs)))
(define define-node? (node-predicate 'define))
(define define-syntax-node? (node-predicate 'define-syntax syntax-type))
; For the module system:
(define-classifier 'structure-ref
(lambda (op op-node form env)
(let ((struct-node (classify (cadr form) env))
(lose (lambda ()
(classify (syntax-error "invalid structure reference" form)
env))))
(if (and (name? (caddr form))
(name-node? struct-node))
(let ((b (node-ref struct-node 'binding)))
(if (and (binding? b) (binding-static b)) ; (structure? ...)
(classify (generate-name (desyntaxify (caddr form))
(binding-static b)
(node-form struct-node))
env)
(lose)))
(lose)))))
; Magical Scheme 48 internal thing, mainly for use by the
; DEFINE-PACKAGE macro.
(define-classifier '%file-name%
(let ((operator/quote (get-operator 'quote syntax-type)))
(lambda (op op-node form env)
(make-node operator/quote `',(get-funny env funny-name/source-file-name)))))
(define funny-name/source-file-name
(string->symbol ".source-file-name."))
(define (bind-source-file-name filename env)
(if filename
(bind1 funny-name/source-file-name
(make-binding syntax-type #f filename)
env)
env))
; To do:
; Check syntax of others special forms
; --------------------
; Environments
(define (lookup env name)
(env name))
(define (bind1 name binding env)
(lambda (a-name)
(if (eq? a-name name)
binding
(lookup env a-name))))
; corollary
(define (bind names bindings env)
(cond ((null? names) env)
(else
(bind1 (car names)
(car bindings)
(bind (cdr names) (cdr bindings) env)))))
(define (bindrec names env->bindings env)
(set! env (bind names
(env->bindings (lambda (a-name) (env a-name)))
env))
env)
; --------------------
; Utilities
(define (literal? exp)
(or (number? exp) (char? exp) (string? exp) (boolean? exp)))
(define (number-of-required-args formals)
(do ((l formals (cdr l))
(i 0 (+ i 1)))
((not (pair? l)) i)))
(define (n-ary? formals)
(cond ((null? formals) #f)
((pair? formals) (n-ary? (cdr formals)))
(else #t)))
(define (normalize-formals formals)
(cond ((null? formals) '())
((pair? formals)
(cons (car formals) (normalize-formals (cdr formals))))
(else (list formals))))
(define (syntax? d)
(cond ((operator? d)
(eq? (operator-type d) syntax-type))
((transform? d)
(eq? (transform-type d) syntax-type))
(else #f)))
(define (name? thing)
(or (symbol? thing)
(generated? thing)))
(define unbound? name?)
; --------------------
; LET-SYNTAX and friends
(define (define-usual-suspects table mumble)
(operator-define! table 'let-syntax syntax-type
(mumble (lambda (node env)
(let* ((form (node-form node))
(specs (cadr form)))
(values (caddr form)
(bind (map car specs)
(map (lambda (spec)
(make-binding syntax-type
(list 'let-syntax)
(process-syntax (cadr spec)
env
(car spec)
env)))
specs)
env))))))
(operator-define! table 'letrec-syntax syntax-type
(mumble (lambda (node env)
(let* ((form (node-form node))
(specs (cadr form)))
(values (caddr form)
(bindrec (map car specs)
(lambda (new-env)
(map (lambda (spec)
(make-binding
syntax-type
(list 'letrec-syntax)
(process-syntax (cadr spec)
new-env
(car spec)
new-env)))
specs))
env))))))
(operator-define! table 'with-aliases syntax-type
(mumble (lambda (node env)
(let ((form (node-form node)))
(values (cadddr form)
(bind-aliases (caddr form)
(binding-static
(node-ref (cadr form) 'binding))
env)))))))
(define (process-syntax form env name env-or-whatever)
(let ((eval+env (force (reflective-tower env))))
(make-transform ((car eval+env) form (cdr eval+env))
env-or-whatever syntax-type form name)))
(define (get-funny env name)
(let ((binding (lookup env name)))
(if (binding? binding)
(binding-static binding)
#f)))
; An environment's "reflective tower" is a promise that is expected to
; deliver, when forced, a pair (eval . env).
(define funny-name/reflective-tower
(string->symbol ".reflective-tower."))
(define (reflective-tower env)
(or (get-funny env funny-name/reflective-tower)
(error "environment has no environment for syntax" env)))
; --------------------
; The horror of internal defines
; The continuation argument to SCAN-BODY takes two arguments: a list
; of definition nodes, and a list of other things (nodes and
; expressions).
(define (scan-body forms env cont)
(if (or (null? forms)
(null? (cdr forms)))
(cont '() forms) ;+++ tiny compiler speedup?
(scan-body-forms forms env '()
(lambda (defs exps env)
(cont defs exps)))))
(define (scan-body-forms forms env defs cont)
(if (null? forms)
(cont defs '() env)
(let ((node (classify (car forms) env))
(forms (cdr forms)))
(cond ((define-node? node)
(scan-body-forms forms
(let ((name (cadr (node-form node))))
(bind1 name
;; Shadow, and don't cache lookup
(make-node operator/name name)
env))
(cons node defs)
cont))
((begin-node? node)
(scan-body-forms (cdr (node-form node))
env
defs
(lambda (new-defs exps env)
(cond ((null? exps)
(scan-body-forms forms
env
new-defs
cont))
((eq? new-defs defs)
(cont defs
(append exps forms)
env))
(else (body-lossage node env))))))
(else
(cont defs (cons node forms) env))))))
(define (body-lossage node env)
(syntax-error "definitions and expressions intermixed"
(schemify node env)))
(define begin-node? (node-predicate 'begin syntax-type))
; --------------------
; Variable types
(define (variable-type type)
(list 'variable type))
(define (variable-type? type)
(and (pair? type) (eq? (car type) 'variable)))
(define variable-value-type cadr)
; Used in two places:
; 1. GET-LOCATION checks to see if the context of use (either variable
; reference or assignment) is compatible with the declared type.
; 2. CHECK-STRUCTURE checks to see if the reconstructed type is compatible
; with any type declared in the interface.
(define (compatible-types? have-type want-type)
(if (variable-type? want-type)
(and (variable-type? have-type)
(same-type? (variable-value-type have-type)
(variable-value-type want-type)))
(meet? (if (variable-type? have-type)
(variable-value-type have-type)
have-type)
want-type)))
; Usual type for Scheme variables.
(define usual-variable-type (variable-type value-type))
(define undeclared-type ':undeclared) ;cf. really-export macro
; Associate a reader (parser) with an environment.
(define funny-name/reader (string->symbol ".reader."))
;(define (set-package-reader! p reader)
; (package-define-funny! p funny-name/reader reader))
(define (environment-reader env)
(or (get-funny env funny-name/reader) read))

53
bcomp/type.scm
View File

@ -1,53 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; The types.
(define :syntax
(loophole :type syntax-type))
(define :values
(loophole :type any-values-type))
(define :arguments
(loophole :type any-arguments-type))
(define :value
(loophole :type value-type))
(define procedure
(loophole (proc (:type :type) :type)
(lambda (dom cod) (procedure-type dom cod #t))))
; Use the definitions of PROC and SOME-VALUES from the meta-types module
; Various base types
(define :boolean (loophole :type boolean-type))
(define :char (loophole :type char-type))
(define :null (loophole :type null-type))
(define :unspecific (loophole :type unspecific-type))
(define :number (loophole :type number-type))
(define :complex (loophole :type complex-type))
(define :real (loophole :type real-type))
(define :rational (loophole :type rational-type))
(define :integer (loophole :type integer-type))
(define :exact-integer (loophole :type exact-integer-type))
(define :pair (loophole :type pair-type))
(define :string (loophole :type string-type))
(define :symbol (loophole :type symbol-type))
(define :vector (loophole :type vector-type))
(define :procedure (loophole :type any-procedure-type))
; Temporary
(define :input-port :value)
(define :output-port :value)
(define :error (loophole :type error-type))
(define :escape (loophole :type escape-type))
(define :structure (loophole :type structure-type))
(define :type (loophole :type value-type))

56
bcomp/undefined.scm
View File

@ -1,56 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Added really-noting-undefined-variables proc, which gives you noise control.
; -Olin 6/95.
; Maintain and display a list of undefined names.
(define $note-undefined (make-fluid #f))
(define (note-undefined! p name)
(let ((note (fluid $note-undefined)))
(if note (note p name))))
(define (noting-undefined-variables p thunk)
(really-noting-undefined-variables p (current-output-port) thunk))
(define (really-noting-undefined-variables p noise thunk)
(let* ((losers '())
(foo (lambda (env name)
(let ((probe (assq env losers)))
(if probe
(if (not (member name (cdr probe)))
(set-cdr! probe (cons name (cdr probe))))
(set! losers (cons (list env name) losers)))))))
(let-fluid $note-undefined (lambda (p name)
(if (generated? name)
(foo (generated-env name)
(generated-symbol name))
(foo p name)))
(lambda ()
(dynamic-wind
(lambda () #f)
thunk
(lambda ()
(for-each (lambda (p+names)
(let* ((env (car p+names))
;; Keep the ones that are still unbound:
(names (filter (lambda (nm)
(unbound? (generic-lookup env nm)))
(cdr p+names))))
(cond ((and (not (null? names)) noise)
(display "Undefined" noise)
(if (and p (not (eq? env p)))
(begin (display " in " noise)
(write (car p+names) noise)))
(display ": " noise)
(write (map (lambda (name)
(if (generated? name)
(generated-symbol name)
name))
(reverse names))
noise)
(newline noise)))))
losers)))))))

233
bcomp/usual.scm
View File

@ -1,233 +0,0 @@
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; This is file derive.scm.
;;;; Macro expanders for the standard macros
(define the-usual-transforms (make-table))
(define (define-usual-macro name n proc aux-names)
(table-set! the-usual-transforms
name
(cons (lambda (exp rename compare)
(if (long-enough? (cdr exp) n)
(apply proc rename compare (cdr exp))
exp))
aux-names)))
(define (usual-transform name)
(or (table-ref the-usual-transforms name)
(call-error "no such transform" usual-transform name)))
(define (long-enough? l n)
(if (= n 0)
#t
(and (pair? l) (long-enough? (cdr l) (- n 1)))))
;
(define-usual-macro 'and 0
(lambda (rename compare . conjuncts)
(cond ((null? conjuncts) `#t)
((null? (cdr conjuncts)) (car conjuncts))
(else `(,(rename 'if) ,(car conjuncts)
(,(rename 'and) ,@(cdr conjuncts))
,#f)))) ; bootstrapping does not allow #F embedded in
; quoted structure
'(if and))
; Tortuously crafted so as to avoid dependency on any (unspecific)
; procedure.
(define-usual-macro 'cond 1
(lambda (rename compare . clauses)
(let ((result
(let recur ((clauses clauses))
(if (null? clauses)
'()
(list
(let ((clause (car clauses))
(more-clauses (cdr clauses)))
(cond ((not (pair? clause))
(syntax-error "invalid COND clause" clause))
((and (null? more-clauses)
(compare (car clause) (rename 'else)))
`(,(rename 'begin) ,@(cdr clause)))
((null? (cdr clause))
`(,(rename 'or) ,(car clause)
,@(recur more-clauses)))
((compare (cadr clause) (rename '=>))
(let ((temp (rename 'temp)))
`(,(rename 'let)
((,temp ,(car clause)))
(,(rename 'if) ,temp
(,(caddr clause) ,temp)
,@(recur more-clauses)))))
(else
`(,(rename 'if) ,(car clause)
(,(rename 'begin) ,@(cdr clause))
,@(recur more-clauses))))))))))
(if (null? result)
(syntax-error "empty COND")
(car result))))
'(or cond begin let if begin))
(define-usual-macro 'do 2
(lambda (rename compare . (specs end . body))
(let ((%loop (rename 'loop))
(%letrec (rename 'letrec))
(%lambda (rename 'lambda))
(%cond (rename 'cond)))
`(,%letrec ((,%loop
(,%lambda ,(map car specs)
(,%cond ,end
(else ,@body
(,%loop
,@(map (lambda (y)
(if (null? (cddr y))
(car y)
(caddr y)))
specs)))))))
(,%loop ,@(map cadr specs)))))
'(letrec lambda cond))
(define-usual-macro 'let 2
(lambda (rename compare . (specs . body))
(cond ((list? specs)
`((,(rename 'lambda) ,(map car specs) ,@body)
,@(map cadr specs)))
((name? specs)
(let ((tag specs)
(specs (car body))
(body (cdr body))
(%letrec (rename 'letrec))
(%lambda (rename 'lambda)))
`(,%letrec ((,tag (,%lambda ,(map car specs) ,@body)))
(,tag ,@(map cadr specs)))))
(else (syntax-error "invalid LET syntax"
`(let ,specs ,@body)))))
'(lambda letrec))
(define-usual-macro 'let* 2
(lambda (rename compare . (specs . body))
(if (or (null? specs)
(null? (cdr specs)))
`(,(rename 'let) ,specs ,@body)
`(,(rename 'let) (,(car specs))
(,(rename 'let*) ,(cdr specs) ,@body))))
'(let let*))
(define-usual-macro 'or 0
(lambda (rename compare . disjuncts)
(cond ((null? disjuncts) #f) ;not '#f
((null? (cdr disjuncts)) (car disjuncts))
(else (let ((temp (rename 'temp)))
`(,(rename 'let) ((,temp ,(car disjuncts)))
(,(rename 'if) ,temp
,temp
(,(rename 'or) ,@(cdr disjuncts))))))))
'(let if or))
; CASE needs auxiliary MEMV.
(define-usual-macro 'case 2
(lambda (rename compare . (key . clauses))
(let ((temp (rename 'temp))
(%eqv? (rename 'eq?))
(%memv (rename 'memv))
(%quote (rename 'quote)))
`(,(rename 'let) ((,temp ,key))
(,(rename 'cond) ,@(map (lambda (clause)
`(,(cond ((compare (car clause) (rename 'else))
(car clause))
((null? (car clause))
#f)
((null? (cdar clause)) ;+++
`(,%eqv? ,temp (,%quote ,(caar clause))))
(else
`(,%memv ,temp (,%quote ,(car clause)))))
,@(cdr clause)))
clauses)))))
'(let cond eqv? memv quote))
; Quasiquote
(define-usual-macro 'quasiquote 1
(lambda (rename compare . (x))
(define %quote (rename 'quote))
(define %quasiquote (rename 'quasiquote))
(define %unquote (rename 'unquote))
(define %unquote-splicing (rename 'unquote-splicing))
(define %append (rename 'append))
(define %cons (rename 'cons))
(define %list->vector (rename 'list->vector))
(define (expand-quasiquote x level)
(descend-quasiquote x level finalize-quasiquote))
(define (finalize-quasiquote mode arg)
(cond ((eq? mode 'quote) `(,%quote ,arg))
((eq? mode 'unquote) arg)
((eq? mode 'unquote-splicing)
(syntax-error ",@ in invalid context" arg))
(else `(,mode ,@arg))))
(define (descend-quasiquote x level return)
(cond ((vector? x)
(descend-quasiquote-vector x level return))
((not (pair? x))
(return 'quote x))
((interesting-to-quasiquote? x %quasiquote)
(descend-quasiquote-pair x (+ level 1) return))
((interesting-to-quasiquote? x %unquote)
(cond ((= level 0)
(return 'unquote (cadr x)))
(else
(descend-quasiquote-pair x (- level 1) return))))
((interesting-to-quasiquote? x %unquote-splicing)
(cond ((= level 0)
(return 'unquote-splicing (cadr x)))
(else
(descend-quasiquote-pair x (- level 1) return))))
(else
(descend-quasiquote-pair x level return))))
(define (descend-quasiquote-pair x level return)
(descend-quasiquote (car x) level
(lambda (car-mode car-arg)
(descend-quasiquote (cdr x) level
(lambda (cdr-mode cdr-arg)
(cond ((and (eq? car-mode 'quote) (eq? cdr-mode 'quote))
(return 'quote x))
((eq? car-mode 'unquote-splicing)
;; (,@mumble ...)
(cond ((and (eq? cdr-mode 'quote) (null? cdr-arg))
(return 'unquote
car-arg))
(else
(return %append
(list car-arg (finalize-quasiquote
cdr-mode cdr-arg))))))
(else
(return %cons
(list (finalize-quasiquote car-mode car-arg)
(finalize-quasiquote cdr-mode cdr-arg))))))))))
(define (descend-quasiquote-vector x level return)
(descend-quasiquote (vector->list x) level
(lambda (mode arg)
(case mode
((quote) (return 'quote x))
(else (return %list->vector
(list (finalize-quasiquote mode arg))))))))
(define (interesting-to-quasiquote? x marker)
(and (pair? x) (compare (car x) marker)))
(expand-quasiquote x 0))
'(append cons list->vector quasiquote unquote unquote-splicing))

315
big/array.scm
View File

@ -1,315 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; (make-array <initial-value> <bound1> ...)
; (array-shape <array>)
; (array-ref <array> <index1> ...)
; (array-set! <array> <value> <index1> ...)
; (make-shared-array <array> <linear-map> <bound1> ...)
; (copy-array <array>)
; (array->vector <array>)
; (array <bounds> . <elements>)
;
; All arrays are zero based.
;
; ARRAY-MAP returns a list containing the array's bounds.
;
; The <linear-map> argument to MAKE-SHARED-ARRAY is a linear function
; that maps indices into the shared array into a list of indices into
; the original array. The array returned by MAKE-SHARED-ARRAY shares
; storage with the original array.
;
; (array-ref (make-shared-array a f i1 i2 ... iN) j1 j2 ... jM)
; <==>
; (apply array-ref a (f j1 j2 ... jM))
;
; ARRAY->VECTOR returns a vector containing the elements of an array
; in row-major order.
; An array consists of a vector containing the bounds of the array,
; a vector containing the elements of the array, and a linear map
; expressed as a vector of coefficients and one constant.
; If the map is #(c1 c2 ... cN C0) then the index into the vector of
; elements for (array-ref a i1 i2 ... iN) is
; (+ (* i1 c1) (* i2 c2) ... (* iN cN) C0).
; Interface due to Alan Bawden.
; Implementation by Richard Kelsey.
(define-record-type array
(bounds ; vector of array bounds
map ; vector of coefficients + one constant
elements) ; vector of actual elements
())
(define (array-shape array)
(vector->list (array-bounds array)))
; Calculate the index into an array's element vector that corresponds to
; INDICES. MAP is the array's linear map.
(define (fast-array-index indices map)
(let ((size (- (vector-length map) 1)))
(do ((i 0 (+ i 1))
(j (vector-ref map size)
(+ j (* (vector-ref indices i)
(vector-ref map i)))))
((>= i size) j))))
; The same thing with bounds checking added.
(define (array-index array indices)
(let ((bounds (array-bounds array))
(coefficients (array-map array)))
(let loop ((is indices)
(i 0)
(index (vector-ref coefficients (vector-length bounds))))
(cond ((null? is)
(if (= i (vector-length bounds))
index
(error "wrong number of array indices" array indices)))
((>= i (vector-length bounds))
(error "wrong number of array indices" array indices))
(else
(let ((j (car is)))
(if (and (>= j 0)
(< j (vector-ref bounds i)))
(loop (cdr is)
(+ i 1)
(+ index (* j (vector-ref coefficients i))))
(error "array index out of range" array indices))))))))
(define (array-ref array . indices)
(vector-ref (array-elements array) (array-index array indices)))
(define (array-set! array value . indices)
(vector-set! (array-elements array) (array-index array indices) value))
; This is mostly error checking.
(define (make-array initial bound1 . bounds)
(let* ((all-bounds (cons bound1 bounds))
(bounds (make-vector (length all-bounds)))
(size (do ((bs all-bounds (cdr bs))
(i 0 (+ i 1))
(s 1 (* s (car bs))))
((null? bs) s)
(let ((b (car bs)))
(vector-set! bounds i b)
(if (not (and (integer? b)
(exact? b)
(< 0 b)))
(error "illegal array bounds" all-bounds))))))
(array-maker bounds
(bounds->map bounds)
(make-vector size initial))))
(define (array bounds . elts)
(let* ((array (apply make-array #f bounds))
(elements (array-elements array))
(size (vector-length elements)))
(if (not (= (length elts) size))
(error "ARRAY got the wrong number of elements" bounds elts))
(do ((i 0 (+ i 1))
(elts elts (cdr elts)))
((null? elts))
(vector-set! elements i (car elts)))
array))
; Determine the linear map that corresponds to a simple array with the
; given bounds.
(define (bounds->map bounds)
(do ((i (- (vector-length bounds) 1) (- i 1))
(s 1 (* s (vector-ref bounds i)))
(l '() (cons s l)))
((< i 0)
(list->vector (reverse (cons 0 (reverse l)))))))
; This is mostly error checking. Two different procedures are used to
; check that the shared array does not extend past the original. The
; full check does a complete check, but, as it must check every corner
; of the shared array, it gets very slow as the number of dimensions
; goes up. The simple check just verifies that the all elements of
; the shared array map to elements in the vector of the original.
(define (make-shared-array array linear-map . bounds)
(let ((map (make-shared-array-map array linear-map bounds)))
(if (if (<= (length bounds) maximum-full-bounds-check)
(full-array-bounds-okay? linear-map bounds (array-bounds array))
(simple-array-bounds-okay? map bounds (vector-length
(array-elements array))))
(array-maker (list->vector bounds)
map
(array-elements array))
(error "shared array out of bounds" array linear-map bounds))))
(define maximum-full-bounds-check 5)
; Check that every corner of the array specified by LINEAR and NEW-BOUNDS
; is within OLD-BOUNDS. This checks every corner of the new array.
(define (full-array-bounds-okay? linear new-bounds old-bounds)
(let ((old-bounds (vector->list old-bounds)))
(let label ((bounds (reverse new-bounds)) (args '()))
(if (null? bounds)
(let loop ((res (apply linear args)) (bounds old-bounds))
(cond ((null? res)
(null? bounds))
((and (not (null? bounds))
(<= 0 (car res))
(< (car res) (car bounds)))
(loop (cdr res) (cdr bounds)))
(else #f)))
(and (label (cdr bounds) (cons 0 args))
(label (cdr bounds) (cons (- (car bounds) 1) args)))))))
; Check that the maximum and minimum possible vector indices possible with
; the given bounds and map would fit in an array of the given size.
(define (simple-array-bounds-okay? map bounds size)
(do ((map (vector->list map) (cdr map))
(bounds bounds (cdr bounds))
(min 0 (if (> 0 (car map))
(+ min (* (car map) (- (car bounds) 1)))
min))
(max 0 (if (< 0 (car map))
(+ max (* (car map) (- (car bounds) 1)))
max)))
((null? bounds)
(and (>= 0 (+ min (car map)))
(< size (+ max (car map)))))))
; Determine the coefficients and constant of the composition of
; LINEAR-MAP and the linear map of ARRAY. BOUNDS is used only to
; determine the rank of LINEAR-MAP's domain.
;
; The coefficients are determined by applying first LINEAR-MAP and then
; ARRAY's map to the vectors (1 0 0 ... 0), (0 1 0 ... 0), ..., (0 ... 0 1).
; Applying them to (0 ... 0) gives the constant of the composition.
(define (make-shared-array-map array linear-map bounds)
(let* ((zero (map (lambda (ignore) 0) bounds))
(do-vector (lambda (v)
(or (apply-map array (apply linear-map v))
(error "bad linear map for shared array"
linear-map array bounds))))
(base (do-vector zero)))
(let loop ((bs bounds) (ces '()) (unit (cons 1 (cdr zero))))
(if (null? bs)
(list->vector (reverse (cons base ces)))
(loop (cdr bs)
(cons (- (do-vector unit) base) ces)
(rotate unit))))))
; Apply ARRAY's linear map to the indices in the list VALUES and
; return the resulting vector index. #F is returned if VALUES is not
; the correct length or if any of its elements are out of range.
(define (apply-map array values)
(let ((map (array-map array))
(bounds (array-bounds array)))
(let loop ((values values)
(i 0)
(index (vector-ref map (vector-length bounds))))
(cond ((null? values)
(if (= i (vector-length bounds))
index
#f))
((>= i (vector-length bounds))
#f)
(else
(let ((j (car values)))
(if (and (>= j 0)
(< j (vector-ref bounds i)))
(loop (cdr values)
(+ i 1)
(+ index (* j (vector-ref map i))))
#f)))))))
; Return LIST with its last element moved to the front.
(define (rotate list)
(let ((l (reverse list)))
(cons (car l) (reverse (cdr l)))))
; Copy an array, shrinking the vector if this is subarray that does not
; use all of the original array's elements.
(define (copy-array array)
(array-maker (array-bounds array)
(bounds->map (array-bounds array))
(array->vector array)))
; Make a new vector and copy the elements into it. If ARRAY's map is
; the simple map for it's bounds, then the elements are already in the
; appropriate order and we can just copy the element vector.
(define (array->vector array)
(let* ((size (array-element-count array))
(new (make-vector size)))
(if (and (= size (vector-length (array-elements array)))
(equal? (array-map array) (bounds->map (array-bounds array))))
(copy-vector (array-elements array) new)
(copy-elements array new))
new))
(define (array-element-count array)
(let ((bounds (array-bounds array)))
(do ((i 0 (+ i 1))
(s 1 (* s (vector-ref bounds i))))
((>= i (vector-length bounds))
s))))
(define (copy-vector from to)
(do ((i (- (vector-length to) 1) (- i 1)))
((< i 0))
(vector-set! to i (vector-ref from i))))
; Copy the elements of ARRAY into the vector TO. The copying is done one
; row at a time. POSN is a vector containing the index of the row that
; we are currently copying. After the row is copied, POSN is updated so
; that the next row can be copied. A little more cleverness would make
; this faster by replacing the call to FAST-ARRAY-INDEX with some simple
; arithmetic on J.
(define (copy-elements array to)
(let ((bounds (array-bounds array))
(elements (array-elements array))
(map (array-map array)))
(let* ((size (vector-length bounds))
(posn (make-vector size 0))
(step-size (vector-ref bounds (- size 1)))
(delta (vector-ref map (- size 1))))
(let loop ((i 0))
(do ((i2 i (+ i2 1))
(j (fast-array-index posn map) (+ j delta)))
((>= i2 (+ i step-size)))
(vector-set! to i2 (vector-ref elements j)))
(cond ((< (+ i step-size) (vector-length to))
(let loop2 ((k (- size 2)))
(cond ((= (+ (vector-ref posn k) 1) (vector-ref bounds k))
(vector-set! posn k 0)
(loop2 (- k 1)))
(else
(vector-set! posn k (+ 1 (vector-ref posn k))))))
(loop (+ i step-size))))))))
; Testing.
; (define a1 (make-array 0 4 5))
; 0 1 2 3
; 4 5 6 7
; 8 9 10 11
; 12 13 14 15
; 16 17 18 19
; (make-shared-array-map a1 (lambda (x) (list x x)) '(3))
; 0 5 10, #(5 0)
; (make-shared-array-map a1 (lambda (x) (list 2 (- 4 x))) '(3))
; 18 14 10 #(-4 18)
; (make-shared-array-map a1 (lambda (x y) (list (+ x 1) y)) '(2 4))
; 1 2
; 5 6
; 9 10
; 13 14
; #(1 4 1)

207
big/bigbit.scm
View File

@ -1,207 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Bitwise logical operators on bignums.
(define-opcode-extension bitwise-not &bitwise-not)
(define-opcode-extension bitwise-and &bitwise-and)
(define-opcode-extension bitwise-ior &bitwise-ior)
(define-opcode-extension bitwise-xor &bitwise-xor)
(define-opcode-extension arithmetic-shift &arithmetic-shift)
(define (integer-bitwise-not m)
;; (integer+ (integer-negate m) -1)
(integer- -1 m))
(define (integer-bitwise-and m n)
(if (or (integer= 0 m) (integer= 0 n))
0
(integer-bitwise-op bitwise-and m n)))
(define (integer-bitwise-ior m n)
(cond ((integer= 0 m) n)
((integer= 0 n) m)
(else
(integer-bitwise-op bitwise-ior m n))))
(define (integer-bitwise-xor m n)
(cond ((integer= 0 m) n)
((integer= 0 n) m)
(else
(integer-bitwise-op bitwise-xor m n))))
(define (integer-bitwise-op op m n)
(let ((m (integer->bignum m))
(n (integer->bignum n)))
(let ((finish (lambda (sign-bit mag-op)
(let ((mag (mag-op op
(bignum-magnitude m)
(bignum-magnitude n))))
(make-integer (if (= 0 sign-bit) 1 -1)
(if (= 0 sign-bit)
mag
(negate-magnitude mag)))))))
(if (>= (bignum-sign m) 0)
(if (>= (bignum-sign n) 0)
(finish (op 0 0) magnitude-bitwise-binop-pos-pos)
(finish (op 0 1) magnitude-bitwise-binop-pos-neg))
(if (>= (bignum-sign n) 0)
(finish (op 0 1) magnitude-bitwise-binop-neg-pos)
(finish (op 1 1) magnitude-bitwise-binop-neg-neg))))))
(define radix-mask (- radix 1))
(define (magnitude-bitwise-binop-pos-pos op m n)
(let recur ((m m) (n n))
(if (and (zero-magnitude? m) (zero-magnitude? n))
m
(adjoin-digit (bitwise-and (op (low-digit m) (low-digit n)) radix-mask)
(recur (high-digits m) (high-digits n))))))
; Same as the above, except that one magnitude is that of a negative number.
(define (magnitude-bitwise-binop-neg-pos op m n)
(magnitude-bitwise-binop-pos-neg op n m))
(define (magnitude-bitwise-binop-pos-neg op m n)
(let recur ((m m) (n n) (carry 1))
(if (and (zero-magnitude? n) (zero-magnitude? m))
(integer->magnitude (op 0 carry))
(call-with-values
(lambda ()
(negate-low-digit n carry))
(lambda (n-digit carry)
(adjoin-digit (op (low-digit m) n-digit)
(recur (high-digits m)
(high-digits n)
carry)))))))
; Now both M and N are magnitudes of negative numbers.
(define (magnitude-bitwise-binop-neg-neg op m n)
(let recur ((m m) (n n) (m-carry 1) (n-carry 1))
(if (and (zero-magnitude? n) (zero-magnitude? m))
(integer->magnitude (op m-carry n-carry))
(call-with-values
(lambda ()
(negate-low-digit m m-carry))
(lambda (m-digit m-carry)
(call-with-values
(lambda ()
(negate-low-digit n n-carry))
(lambda (n-digit n-carry)
(adjoin-digit (op m-digit n-digit)
(recur (high-digits m)
(high-digits n)
m-carry
n-carry)))))))))
(define (negate-low-digit m carry)
(let ((m (+ (bitwise-and (bitwise-not (low-digit m))
radix-mask)
carry)))
(if (>= m radix)
(values (- m radix) 1)
(values m 0))))
(define (negate-magnitude m)
(let recur ((m m) (carry 1))
(if (zero-magnitude? m)
(integer->magnitude carry)
(call-with-values
(lambda ()
(negate-low-digit m carry))
(lambda (next carry)
(adjoin-digit next
(recur (high-digits m) carry)))))))
; arithmetic-shift
(define (integer-arithmetic-shift m n)
(let ((m (integer->bignum m)))
(make-integer (bignum-sign m)
(cond ((> n 0)
(shift-left-magnitude (bignum-magnitude m) n))
((= 1 (bignum-sign m))
(shift-right-pos-magnitude (bignum-magnitude m) n))
(else
(shift-right-neg-magnitude (bignum-magnitude m) n))))))
(define (shift-left-magnitude mag n)
(if (< n log-radix)
(let ((mask (- (arithmetic-shift 1 (- log-radix n)) 1)))
(let recur ((mag mag)
(low 0))
(if (zero-magnitude? mag)
(adjoin-digit low zero-magnitude)
;; Split the low digit into left and right parts, and shift
(let ((left (arithmetic-shift (low-digit mag)
(- n log-radix))) ;shift right
(right (arithmetic-shift (bitwise-and (low-digit mag) mask)
n)))
(adjoin-digit (bitwise-ior low right)
(recur (high-digits mag)
left))))))
(adjoin-digit 0 (shift-left-magnitude mag (- n log-radix)))))
(define (shift-right-pos-magnitude mag n)
(if (> n (- 0 log-radix))
(let ((mask (- (arithmetic-shift 1 (- 0 n)) 1)))
(let recur ((mag mag))
(let ((low (low-digit mag))
(high (high-digits mag)))
(adjoin-digit
(bitwise-ior (arithmetic-shift low n)
(arithmetic-shift (bitwise-and mask (low-digit high))
(+ n log-radix)))
(if (zero-magnitude? high)
zero-magnitude
(recur high))))))
(shift-right-pos-magnitude (high-digits mag) (+ n log-radix))))
(define (shift-right-neg-magnitude mag n)
(negate-magnitude
(let digit-recur ((mag mag) (n n) (carry 1))
(call-with-values
(lambda ()
(negate-low-digit mag carry))
(lambda (digits carry)
(if (<= n (- 0 log-radix))
(digit-recur (high-digits mag) (+ n log-radix) carry)
(let ((mask (- (arithmetic-shift 1 (- 0 n)) 1)))
(let recur ((mag mag) (low digits) (carry carry))
(let ((high-digits (high-digits mag)))
(call-with-values
(lambda ()
(negate-low-digit high-digits carry))
(lambda (high carry)
(adjoin-digit
(bitwise-ior (arithmetic-shift low n)
(arithmetic-shift (bitwise-and mask high)
(+ n log-radix)))
(if (zero-magnitude? high-digits)
(integer->magnitude carry)
(recur high-digits high carry))))))))))))))
;(define (tst)
; (let* ((m (random))
; (n (bitwise-and m 63))
; (m1 (integer-arithmetic-shift
; (integer-arithmetic-shift m n)
; (- 0 n))))
; (list n m m1 (= m m1))))
;(define random (make-random 17))
(define-method &bitwise-not ((n :integer)) (integer-bitwise-not n))
(define-method &bitwise-and ((n1 :exact-integer) (n2 :exact-integer))
(integer-bitwise-and n1 n2))
(define-method &bitwise-ior ((n1 :exact-integer) (n2 :exact-integer))
(integer-bitwise-ior n1 n2))
(define-method &bitwise-xor ((n1 :exact-integer) (n2 :exact-integer))
(integer-bitwise-xor n1 n2))
(define-method &arithmetic-shift ((n1 :exact-integer) (n2 :exact-integer))
(integer-arithmetic-shift n1 n2))

44
big/compose-cont.scm
View File

@ -1,44 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
(define (compose-continuation proc cont)
(primitive-cwcc
(lambda (k)
(with-continuation cont ;(if cont cont null-continuation)
(lambda ()
(proc (primitive-cwcc
(lambda (k2) (with-continuation k (lambda () k2))))))))))
; Old definition that relies on details of VM architecture:
;(define null-continuation #f)
;(define null-continuation (make-continuation 4 #f)) ;temp kludge
;(continuation-set! null-continuation 1 0)
;(continuation-set! null-continuation 2
; ;; op/trap = 140
; (segment-data->template (make-code-vector 1 140) #f '()))
;(put 'primitive-cwcc 'scheme-indent-hook 0)
;(put 'with-continuation 'scheme-indent-hook 1)
;(define compose-continuation
; (let ((tem
; (let ((cv (make-code-vector 6 0)))
; (code-vector-set! cv 0 op/push) ;push return value
; (code-vector-set! cv 1 op/local) ;fetch procedure
; (code-vector-set! cv 3 1) ;over = 1
; (code-vector-set! cv 4 op/call)
; (code-vector-set! cv 5 1) ;one argument
; (segment-data->template cv 0 '()))))
; (lambda (proc parent-cont)
; (let ((cont (make-continuation 4 #f)))
; (continuation-set! cont 0 parent-cont)
; (continuation-set! cont 1 0) ;pc
; (continuation-set! cont 2 tem) ;template
; (continuation-set! cont 3 (vector #f proc)) ;environment
; cont))))

93
big/defrecord.scm
View File

@ -1,93 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Syntax for defining record types
; (define-record-type name constructor-fields other-fields)
; Constructor-arguments fields are either <name> or (<name>), the second
; indicating a field whose value can be modified.
; Other-fields are one of:
; (<name> <expression>) = modifiable field with the given value.
; <name> = modifiable field with no initial value.
;(define-record-type job
; ((thunk)
; (dynamic-env)
; number
; inferior-lock
; )
; ((on-queue #f)
; (superior #f)
; (inferiors '())
; (condition #f)
; ))
(define-syntax define-record-type
(let ()
(define s->s symbol->string)
(define s-conc (lambda args (string->symbol (apply string-append args))))
(define spec-name (lambda (s) (if (pair? s) (car s) s)))
(define (filter pred lst)
(if (null? lst)
'()
(if (pred (car lst))
(cons (car lst) (filter pred (cdr lst)))
(filter pred (cdr lst)))))
(lambda (form rename compare)
(let* ((name (cadr form))
(arg-fields (caddr form))
(other-fields (cadddr form))
(init-fields (filter pair? other-fields))
(field-name (lambda (field-name)
(s-conc (s->s name) "-" (s->s field-name))))
(set-name (lambda (field-name)
(s-conc "set-" (s->s name)
"-" (s->s field-name) "!")))
(pred-name (s-conc (s->s name) "?"))
(maker-name (s-conc (s->s name) "-maker"))
(type-name (s-conc "type/" (s->s name)))
(make (rename 'make))
(%make-record-type (rename 'make-record-type))
(%record-constructor (rename 'record-constructor))
(%record-predicate (rename 'record-predicate))
(%record-accessor (rename 'record-accessor))
(%record-modifier (rename 'record-modifier))
(%unspecific (rename 'unspecific))
(%define (rename 'define))
(%let (rename 'let))
(%lambda (rename 'lambda))
(%begin (rename 'begin)))
`(,%begin
(,%define ,type-name
(,%make-record-type ',name
',(map spec-name
(append arg-fields other-fields))))
(,%define ,maker-name
(,%let ((,make (,%record-constructor
,type-name
',(map spec-name
(append arg-fields init-fields)))))
(,%lambda ,(map spec-name arg-fields)
(,make ,@(map spec-name arg-fields)
,@(map cadr init-fields)))))
(,%define ,pred-name (,%record-predicate ,type-name))
,@(map (lambda (spec)
`(,%define ,(field-name (spec-name spec))
(,%record-accessor ,type-name ',(spec-name spec))))
(append arg-fields other-fields))
,@(map (lambda (spec)
`(,%define ,(set-name (spec-name spec))
(,%record-modifier ,type-name ',(spec-name spec))))
(filter pair? arg-fields))
,@(map (lambda (spec)
`(,%define ,(set-name (spec-name spec))
(,%record-modifier ,type-name ',(spec-name spec))))
other-fields))))))

53
big/destructure.scm
View File

@ -1,53 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
(define-syntax destructure
(lambda (form rename compare)
(let ((specs (cadr form))
(body (cddr form))
(%car (rename 'car))
(%cdr (rename 'cdr))
(%vref (rename 'vector-ref))
(%let* (rename 'let*))
(gensym (lambda (i)
(string->symbol (string-append "x" (number->string i)))))
(atom? (lambda (x) (not (pair? x)))))
(letrec ((expand-pattern
(lambda (pattern value i)
(cond ((or (not pattern) (null? pattern))
'())
((vector? pattern)
(let ((xvalue (if (atom? value)
value
(gensym i))))
`(,@(if (eq? value xvalue) '() `((,xvalue ,value)))
,@(expand-vector pattern xvalue i))))
((atom? pattern)
`((,pattern ,value)))
(else
(let ((xvalue (if (atom? value)
value
(gensym i))))
`(,@(if (eq? value xvalue) '() `((,xvalue ,value)))
,@(expand-pattern (car pattern)
`(,%car ,xvalue)
(+ i 1))
,@(if (null? (cdr pattern))
'()
(expand-pattern (cdr pattern)
`(,%cdr ,xvalue)
(+ i 1)))))))))
(expand-vector
(lambda (vec xvalue i)
(do ((j (- (vector-length vec) 1) (- j 1))
(ps '() (append (expand-pattern (vector-ref vec j)
`(,%vref ,xvalue ,j)
(+ i 1))
ps)))
((< j 0) ps)))))
(do ((specs specs (cdr specs))
(res '() (append (expand-pattern (caar specs) (cadar specs) 0)
res)))
((null? specs)
`(,%let* ,res . ,body)))))))

429
big/dump.scm
View File

@ -1,429 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Dump and restore
; Unix has special meanings for
; ETX, FS, DEL, ETB, NAK, DC2, EOT, EM (or SUB?), DC3, DC1, SI, SYN,
; 3 28 127 23 21 18 4 25 26 19 17 15 22
; so avoid using them.
(define type/null #\n)
(define type/true #\t)
(define type/false #\f)
(define type/unspecific #\u)
(define type/pair #\p) ;obj1 obj2
(define type/string #\s) ;length chars
(define type/number #\i) ;#chars rep
(define type/symbol #\y) ;length chars
(define type/char #\c) ;char
(define type/vector #\v) ;length objects
(define type/template #\a) ;length objects
(define type/code-vector #\k) ;length bytes (each byte is 2 hex digits?)
(define type/location #\l) ;uid
(define type/closure #\q) ;template-info
(define type/ellipsis #\e)
(define type/random #\r)
; Recursive entry
(define (dump obj write-char depth)
(cond ((null? obj) (dump-type type/null write-char))
((eq? obj #t) (dump-type type/true write-char))
((eq? obj #f) (dump-type type/false write-char))
((pair? obj) (dump-pair obj write-char depth))
;; Template case needs to precede vector case
((template? obj) (dump-template obj write-char depth))
((vector? obj) (dump-vector obj write-char depth))
((symbol? obj) (dump-symbol obj write-char))
((number? obj) (dump-number obj write-char))
((string? obj) (dump-string obj write-char))
((char? obj) (dump-char-literal obj write-char))
((code-vector? obj) (dump-code-vector obj write-char))
((location? obj) (dump-location obj write-char))
((unspecific? obj) (dump-type type/unspecific write-char))
((closure? obj) (dump-closure obj write-char))
(else (dump-random obj write-char depth))))
(define (restore read-char)
(let ((type (restore-type read-char)))
((vector-ref restorers (char->ascii type)) type read-char)))
(define restorers
(make-vector 256 (lambda (type read-char)
;; Invalid type
(error "invalid type code" type))))
(define (define-restorer! type proc)
(vector-set! restorers (char->ascii type) proc))
; Particular dumpers & restorers
(define-restorer! type/null (lambda (c read-char) '()))
(define-restorer! type/false (lambda (c read-char) #f))
(define-restorer! type/true (lambda (c read-char) #t))
(define-restorer! type/unspecific (lambda (c read-char) (if #f #f)))
; Pairs
(define (dump-pair obj write-char depth)
(if (= depth 0)
(dump-ellipsis obj write-char)
(let ((depth (- depth 1)))
(dump-type type/pair write-char)
(dump (car obj) write-char depth)
(dump (cdr obj) write-char depth))))
(define-restorer! type/pair
(lambda (c write-char)
c ;ignored
(let ((the-car (restore write-char)))
(cons the-car (restore write-char)))))
; Symbols
(define (dump-symbol obj write-char)
(dump-type type/symbol write-char)
(dump-a-string (symbol-case-converter (symbol->string obj)) write-char))
(define-restorer! type/symbol
(lambda (c read-char)
c ;ignored
(string->symbol (symbol-case-converter (restore-a-string read-char)))))
; Numbers
; <space> ... _ represent 0 ... 63,
; {<space> ... {_ represent 64 ... 127, -- { is ascii 123
; |<space> ... |_ represent 128 ... 191, -- | is ascii 124
; }<space> ... }_ represent 192 ... 256. -- } is ascii 125
(define (dump-number n write-char)
(if (not (communicable-number? n))
(error "can't dump this number" n))
(if (and (integer? n)
(>= n 0)
(< n 256))
(dump-byte n write-char)
(begin (dump-type type/number write-char)
;; Note logarithmic recursion
(dump-a-string (number->string n comm-radix) write-char))))
(define (communicable-number? n) #t) ;this gets redefined in client
(define (dump-byte n write-char) ;Dump a number between 0 and 255
(if (< n 64)
(write-char (ascii->char (+ n ascii-space)))
(begin (write-char (ascii->char (+ (arithmetic-shift n -6)
122)))
(write-char (ascii->char (+ (bitwise-and n 63)
ascii-space))))))
(define ascii-space (char->ascii #\space)) ;32
(define (restore-small-integer c read-char)
(- (char->ascii c) ascii-space))
(do ((i (+ ascii-space 63) (- i 1)))
((< i ascii-space))
(define-restorer! (ascii->char i) restore-small-integer))
(define (restore-medium-integer c read-char)
(+ (arithmetic-shift (- (char->ascii c) 122) 6)
(- (char->ascii (read-char)) ascii-space)))
(do ((i 123 (+ i 1)))
((> i 125))
(define-restorer! (ascii->char i) restore-medium-integer))
(define (restore-number read-char)
(let ((c (read-char)))
(if (char=? c type/number)
(string->number (restore-a-string read-char) comm-radix)
(let ((n (char->ascii c)))
(if (> n 122)
(restore-medium-integer c read-char)
(- n ascii-space))))))
(define-restorer! type/number
(lambda (c read-char)
c ;ignored
(string->number (restore-a-string read-char) comm-radix)))
(define comm-radix 16)
; String literals
(define (dump-string obj write-char)
(dump-type type/string write-char)
(dump-a-string obj write-char))
(define-restorer! type/string
(lambda (c read-char)
c ;ignored
(restore-a-string read-char)))
; Characters
(define (dump-char-literal obj write-char)
(dump-type type/char write-char)
(dump-a-char obj write-char))
(define-restorer! type/char
(lambda (c read-char)
c ;ignored
(restore-a-char read-char)))
; Vectors
(define (dump-vector obj write-char depth)
(dump-vector-like obj write-char depth
type/vector vector-length vector-ref))
(define (dump-template obj write-char depth)
(dump-vector-like obj write-char depth
type/template template-length template-ref))
(define (dump-vector-like obj write-char depth type vector-length vector-ref)
(if (= depth 0)
(dump-ellipsis obj write-char)
(let ((depth (- depth 1))
(len (vector-length obj)))
(dump-type type write-char)
(dump-length len write-char)
(do ((i 0 (+ i 1)))
((= i len) 'done)
(dump (vector-ref obj i) write-char depth)))))
(define (restore-vector-like make-vector vector-set!)
(lambda (c read-char)
c ;ignored
(let* ((len (restore-length read-char))
(v (make-vector len #\?)))
(do ((i 0 (+ i 1)))
((= i len) v)
(vector-set! v i (restore read-char))))))
(define-restorer! type/vector
(restore-vector-like make-vector vector-set!))
(define-restorer! type/template
(restore-vector-like make-template template-set!))
; Code vectors
(define (dump-code-vector obj write-char)
(dump-type type/code-vector write-char)
(let ((len (code-vector-length obj)))
(dump-length len write-char)
(do ((i 0 (+ i 1)))
((= i len) 'done)
(dump-byte (code-vector-ref obj i) write-char))))
(define-restorer! type/code-vector
(lambda (c read-char)
c ;ignored
(let* ((len (restore-length read-char))
(cv (make-code-vector len 0)))
(do ((i 0 (+ i 1)))
((= i len) cv)
(code-vector-set! cv i
(restore-number read-char))))))
; Locations
(define (dump-location obj write-char)
(dump-type type/location write-char)
(dump-number (location->uid obj) write-char))
(define (location->uid obj)
(or ((fluid $dump-index) obj)
(location-id obj)))
(define-restorer! type/location
(lambda (c read-char)
c ;ignored
(uid->location (restore-number read-char))))
(define (uid->location uid)
(or ((fluid $restore-index) uid)
(table-ref uid->location-table uid)
(let ((loc (make-undefined-location uid)))
(note-location! loc)
loc)))
(define $restore-index (make-fluid (lambda (uid) #f)))
(define uid->location-table (make-table))
(define (note-location! den)
(table-set! uid->location-table
(location-id den)
den))
(define $dump-index (make-fluid (lambda (loc) #f)))
; For simulation purposes, it's better for location uid's not to
; conflict with any that might be in the base Scheme 48 system. (In the
; real server system there isn't any base Scheme 48 system, so there's
; no danger of conflict.)
; (define location-uid-origin 5000)
; Closure
(define (dump-closure obj write-char)
(dump-type type/closure write-char)
(let ((id (template-info (closure-template obj))))
(dump-number (if (integer? id) id 0) write-char)))
(define-restorer! type/closure
(lambda (c read-char)
c ;ignored
(make-random (list 'closure (restore-number read-char)))))
; Random
(define random-type (make-record-type 'random '(disclosure)))
(define make-random (record-constructor random-type '(disclosure)))
(define-record-discloser random-type
(let ((d (record-accessor random-type 'disclosure)))
(lambda (r) (cons "Remote" (d r)))))
(define (dump-random obj write-char depth)
(dump-type type/random write-char)
(dump (or (disclose obj) (list '?))
write-char
depth))
(define-restorer! type/random
(lambda (c read-char)
(make-random (restore read-char))))
; Ellipsis
(define (dump-ellipsis obj write-char)
(dump-type type/ellipsis write-char))
(define-restorer! type/ellipsis
(lambda (c read-char) (make-random (list (string->symbol "---")))))
; Auxiliaries:
; Strings (not necessarily preceded by type code)
(define (dump-a-string obj write-char)
(let ((len (string-length obj)))
(dump-length len write-char)
(do ((i 0 (+ i 1)))
((= i len) 'done)
(dump-a-char (string-ref obj i) write-char))))
(define (restore-a-string read-char)
(let* ((len (restore-length read-char))
(str (make-string len #\?)))
(do ((i 0 (+ i 1)))
((= i len) str)
(string-set! str i (restore-a-char read-char)))))
(define (dump-a-char c write-char)
(write-char c))
(define (restore-a-char read-char)
(read-char))
; Type characters
(define (dump-type c write-char)
(write-char c))
(define (restore-type read-char)
(read-char))
(define dump-length dump-number)
(define restore-length restore-number)
;(define char->ascii char->integer) -- defined in p-features.scm
;(define ascii->char integer->char) -- ditto
; Miscellaneous support
(define (unspecific? obj)
(eq? obj *unspecific*))
(define *unspecific* (if #f #f)) ;foo
;(define (integer->digit-char n)
; (ascii->char (+ n (if (< n 10) ascii-zero a-minus-ten))))
;
;(define (digit-char->integer c)
; (cond ((char-numeric? c)
; (- (char->ascii c) ascii-zero))
; ((char=? c #\#) 0)
; (else
; (- (char->ascii (char-downcase c)) a-minus-ten))))
;
;(define ascii-zero (char->ascii #\0))
;
;(define a-minus-ten (- (char->integer #\a) 10))
; These modified from s48/boot/transport.scm
(define (string-case-converter string)
(let ((new (make-string (string-length string) #\?)))
(do ((i 0 (+ i 1)))
((>= i (string-length new)) new)
(string-set! new i (invert-case (string-ref string i))))))
(define (invert-case c)
(cond ((char-upper-case? c) (char-downcase c))
((char-lower-case? c) (char-upcase c))
(else c)))
(define symbol-case-converter
(if (char=? (string-ref (symbol->string 't) 0) #\t)
(lambda (string) string)
string-case-converter))
; ASCII
; !"#$%&'()*+,-./0123456789:;<=>?
; @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_
; `abcdefghijklmnopqrstuvwxyz{|}~
;(define (tst x)
; (let ((l '()))
; (dump x (lambda (c) (set! l (cons c l))) -1)
; (let ((l (reverse l)))
; (restore (lambda ()
; (let ((c (car l)))
; (set! l (cdr l))
; c))))))
;(define cwcc call-with-current-continuation)
;
;(define (tst x)
; (letrec ((write-cont (lambda (ignore)
; (dump x
; (lambda (c)
; (cwcc (lambda (k)
; (set! write-cont k)
; (read-cont c))))
; -1)))
; (read-cont #f))
; (restore (lambda ()
; (cwcc (lambda (k)
; (set! read-cont k)
; (write-cont 'ignore)))))))

126
big/external.scm
View File

@ -1,126 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Code for keeping external pointers in a table similar to the symbol table.
;
; The entry points for this code are:
;
; (GET-EXTERNAL string) returns an external pointer
; (LOOKUP-ALL-EXTERNALS) looks up new values for all external pointers;
; ideally this should be called automatically
; on startup
(define *the-external-table* #f)
(define (flush-the-external-table!)
(set! *the-external-table* #f))
(define (restore-the-external-table!)
(set! *the-external-table* (make-string-table))
(vector-for-each (lambda (external)
(table-set! *the-external-table*
(external-name external)
external))
(find-all-xs (enum stob external))))
(define (gc-externals)
(flush-the-external-table!)
(collect)
(restore-the-external-table!))
(define (vector-for-each proc vector)
(do ((i 0 (+ i 1)))
((>= i (vector-length vector))
(unspecific))
(proc (vector-ref vector i))))
(restore-the-external-table!)
;------------------------------------------------------------
(define (get-external name)
(cond ((table-ref *the-external-table* name)
=> (lambda (x) x))
(else
(let ((new (maybe-external-lookup
(make-external name (make-code-vector 4 0)))))
(if new
(table-set! *the-external-table* name new)
(warn "External not found" name))
new))))
(define (maybe-external-lookup external)
(call-with-current-continuation
(lambda (lose)
(with-handler
(lambda (c punt)
(cond ((or (not (exception? c))
(not (= op/external-lookup (exception-opcode c))))
(punt))
(else
(lose #f))))
(lambda ()
(external-lookup external)
external)))))
(define op/external-lookup (enum op external-lookup))
(define (null-terminate str)
;; No longer necessary
(string-append str (string (ascii->char 0))))
;------------------------------------------------------------
(define (lookup-all-externals)
(cond ((try-to-lookup-all-externals)
#t)
(else
(display "GCing to try to remove unbound externals")
(newline)
(gc-externals)
(really-lookup-all-externals))))
; Quietly look up all externals, returning #F if unsuccessful
(define (try-to-lookup-all-externals)
(call-with-current-continuation
(lambda (k)
(lookup-all-externals-with-handler
(lambda (external)
(k #f)))
#t)))
; Look up all externals, printing out the names of those that cannot
; be found.
(define (really-lookup-all-externals)
(let ((okay? #t))
(lookup-all-externals-with-handler
(lambda (external)
(cond (okay?
(display "Remaining unbound external(s):")
(newline)
(set! okay? #f)))
(display " ")
(display (external-name external))
(newline)))
okay?))
; Look up all externals, calling PROC on any that cannot be found.
; This assumes that not finding a value for the name is the only reason why
; op/external-lookup would fail, which isn't quite true. Other possible
; reasons are that the name is not a string, or the value is not a
; code vector.
(define (lookup-all-externals-with-handler proc)
(with-handler
(lambda (c punt)
(if (or (not (exception? c))
(not (= op/external-lookup (exception-opcode c))))
(punt)
(proc (car (exception-arguments c)))))
(lambda ()
(table-walk (lambda (name external)
(external-lookup external))
*the-external-table*))))

115
big/filename.scm
View File

@ -1,115 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Silly file name utilities
; These try to be operating-system independent, but fail, of course.
; Namelist = ((dir ...) basename type)
; or ((dir ...) basename)
; or (dir basename type)
; or (dir basename)
; or basename
(define (namestring namelist dir default-type)
(let* ((namelist (if (list? namelist) namelist (list '() namelist)))
(subdirs (if (list? (car namelist))
(car namelist)
(list (car namelist))))
(basename (cadr namelist))
(type (if (null? (cddr namelist))
(if (string? basename)
#f
default-type)
(caddr namelist))))
(string-append (or dir "")
(apply string-append
(map (lambda (subdir)
(string-append
(namestring-component subdir)
directory-component-separator))
subdirs))
(namestring-component basename)
(if type
(string-append type-component-separator
(namestring-component type))
""))))
(define directory-component-separator "/") ;unix sux
(define type-component-separator ".")
(define (namestring-component x)
(cond ((string? x) x)
((symbol? x)
(list->string (map file-name-preferred-case
(string->list (symbol->string x)))))
(else (error "bogus namelist component" x))))
(define file-name-preferred-case char-downcase)
(define *scheme-file-type* 'scm)
(define *load-file-type* *scheme-file-type*) ;#F for Pseudoscheme or T
; Interface copied from gnu emacs:
;file-name-directory
; Function: Return the directory component in file name NAME.
;file-name-nondirectory
; Function: Return file name NAME sans its directory.
;file-name-absolute-p
; Function: Return t if file FILENAME specifies an absolute path name.
;substitute-in-file-name
; Function: Substitute environment variables referred to in STRING.
;expand-file-name
; Function: Convert FILENAME to absolute, and canonicalize it.
(define (file-name-directory filename)
(substring filename 0 (file-nondirectory-position filename)))
(define (file-name-nondirectory filename)
(substring filename
(file-nondirectory-position filename)
(string-length filename)))
(define (file-nondirectory-position filename)
(let loop ((i (- (string-length filename) 1)))
(cond ((< i 0) 0)
;; Heuristic. Should work for DOS, Unix, VMS, MacOS.
((string-posq (string-ref filename i) "/:>]\\") (+ i 1))
(else (loop (- i 1))))))
(define (string-posq thing s)
(let loop ((i 0))
(cond ((>= i (string-length s)) #f)
((eq? thing (string-ref s i)) i)
(else (loop (+ i 1))))))
; Directory translations.
; E.g. (set-translation! "foo;" "/usr/mumble/foo/")
(define *translations* '())
(define (translations) *translations*)
(define (set-translation! from to)
(let ((probe (assoc from *translations*)))
(if probe
(set-cdr! probe to)
(set! *translations* (cons (cons from to) *translations*)))))
(define (translate name)
(let ((len (string-length name)))
(let loop ((ts *translations*))
(if (null? ts)
name
(let* ((from (caar ts))
(to (cdar ts))
(k (string-length from)))
(if (and to
(<= k len)
(string=? (substring name 0 k) from))
(string-append to (substring name k len))
(loop (cdr ts))))))))

151
big/format.scm
View File

@ -1,151 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Quicky FORMAT
;
; (FORMAT port string . args)
;
; PORT is one of:
; an output port, in which case FORMAT prints to the port;
; #T, FORMAT prints to the current output port;
; #F, FORMAT returns a string.
;
; The following format directives have been implemented:
; ~~ -prints a single ~
; ~A -prints the next argument using DISPLAY
; ~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
;
; FORMAT is case-insensitive with respect to letter directives (~a and ~A have
; the same effect).
; The entry point. Gets the port and writes the output.
; Get the appropriate writer for the port specification.
(define (format port string . args)
(cond ((not port)
(call-with-string-output-port
(lambda (port)
(real-format port string args))))
((eq? port #t)
(real-format (current-output-port) string args))
((output-port? port)
(real-format port string args))
(else
(error "invalid port argument to FORMAT" port))))
; Loop down the format string printing characters and dispatching on directives
; as required. Procedures for the directives are in a vector indexed by
; character codes. Each procedure takes four arguments: the format string,
; the index of the next unsed character in the format string, the list of
; remaining arguments, and the writer. Each should return a list of the unused
; arguments.
(define (real-format out string all-args)
(let loop ((i 0) (args all-args))
(cond ((>= i (string-length string))
(if (null? args)
#f
(error "too many arguments to FORMAT" string all-args)))
((char=? #\~ (string-ref string i))
(if (= (+ i 1) (string-length string))
(error "invalid format string" string i)
(loop (+ i 2)
((vector-ref format-dispatch-vector
(char->ascii (string-ref string (+ i 1))))
string
(+ i 2)
args
out))))
(else
(write-char (string-ref string i) out)
(loop (+ i 1) args)))))
; One more than the highest integer that CHAR->ASCII may return.
(define number-of-char-codes ascii-limit)
; The vector of procedures implementing format directives.
(define format-dispatch-vector
(make-vector number-of-char-codes
(lambda (string i args out)
(error "illegal format command"
string
(string-ref string (- i 1))))))
; This implements FORMATs case-insensitivity.
(define (define-format-command char proc)
(vector-set! format-dispatch-vector (char->ascii char) proc)
(if (char-alphabetic? char)
(vector-set! format-dispatch-vector
(char->ascii (if (char-lower-case? char)
(char-upcase char)
(char-downcase char)))
proc)))
; Write a single ~ character.
(define-format-command #\~
(lambda (string i args out)
(write-char #\~ out)
args))
; Newline
(define-format-command #\%
(lambda (string i args out)
(newline out)
args))
; Fresh-Line
(define-format-command #\&
(lambda (string i args out)
(fresh-line out)
args))
; Display (`A' is for ASCII)
(define-format-command #\a
(lambda (string i args out)
(check-for-format-arg args)
(display (car args) out)
(cdr args)))
; Decimals
(define-format-command #\d
(lambda (string i args out)
(check-for-format-arg args)
(display (number->string (car args) 10) out)
(cdr args)))
; Write (`S' is for S-expression)
(define-format-command #\s
(lambda (string i args out)
(check-for-format-arg args)
(write (car args) out)
(cdr args)))
; Recursion
(define-format-command #\?
(lambda (string i args out)
(check-for-format-arg args)
(check-for-format-arg (cdr args))
(real-format out (car args) (cadr args))
(cddr args)))
; Signal an error if ARGS is empty.
(define (check-for-format-arg args)
(if (null? args)
(error "insufficient number of arguments to FORMAT")))

213
big/general-table.scm
View File

@ -1,213 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Hash table package that allows for different hash and comparison functions.
(define-record-type table :table
(really-make-table size data ref set)
table?
(size table-size set-table-size!)
(data table-data set-table-data!)
(ref table-ref-procedure set-table-ref-procedure!)
(set table-set!-procedure set-table-set!-procedure!))
(define (table-ref table key)
((table-ref-procedure table) table key))
(define (table-set! table key value)
((table-set!-procedure table) table key value))
; These numbers are guesses
(define linear-table-size-limit 15)
(define table-size-limit 100000)
(define (next-table-size count) ; Figure out next good size for table.
(let ((new-size (+ (* count 3) 1)))
(if (>= new-size table-size-limit)
(error "requested table size is too large" new-size))
new-size))
(define (make-table-maker comparison-function hash-function)
(let* ((assoc (make-assoc comparison-function))
(ref-proc (make-linear-table-ref assoc))
(x->hash-table! (make->hash-table assoc hash-function))
(set!-proc (make-linear-table-set! assoc x->hash-table!)))
(lambda ()
(really-make-table 0 #f ref-proc set!-proc))))
; Speed & size hack?! See how well it works out, then revert to
; a-lists if it doesn't.
(define null-entry #f)
(define (new-entry key val others) ;(cons (cons key val) others)
(let ((v (make-vector 3 #f)))
(vector-set! v 0 key)
(vector-set! v 1 val)
(vector-set! v 2 others)
v))
(define (make-assoc pred)
(if (eq? pred eq?)
eq?-assoc ;+++
(lambda (thing alist)
(let loop ((alist alist))
(cond ((not alist)
#f)
((pred thing (vector-ref alist 0))
alist)
(else
(loop (vector-ref alist 2))))))))
(define eq?-assoc
(lambda (thing alist)
(let loop ((alist alist))
(cond ((not alist)
#f)
((eq? thing (vector-ref alist 0))
alist)
(else
(loop (vector-ref alist 2)))))))
; Turn some version of ASSOC into a table reference procedure for a-list
; tables.
(define (make-linear-table-ref assoc)
(lambda (table key)
(let ((probe (assoc key (table-data table))))
(if probe (vector-ref probe 1) #f))))
; Turn some version of ASSOC and a hash function into a table set! procedure
; for a-list tables. If the table gets too big it is turned into a hash table.
(define (make-linear-table-set! assoc x->hash-table!)
(lambda (table key value)
(let* ((data (table-data table))
(probe (assoc key data)))
(cond (probe
(vector-set! probe 1 value))
(else
(set-table-data! table (new-entry key value data))
(let ((size (table-size table)))
(if (< size linear-table-size-limit)
(set-table-size! table (+ size 1))
(x->hash-table! table size))))))))
; Return a function to transform linear tables into hash tables.
(define (make->hash-table assoc hash-function)
(let ((hash-table-ref (make-hash-table-ref assoc hash-function))
(hash-table-set! (make-hash-table-set! assoc hash-function)))
(lambda (table size)
(let ((data (table-data table)))
(set-table-ref-procedure! table hash-table-ref)
(set-table-set!-procedure! table hash-table-set!)
(table-expand-table! table (next-table-size size))
(table-enter-alist! table data)))))
(define (make-hash-table-ref assoc hash-function)
(lambda (table key)
(let* ((data (table-data table))
(h (remainder (hash-function key)
(vector-length data)))
(alist (vector-ref data h))
(probe (assoc key alist)))
(if probe (vector-ref probe 1) #f))))
(define (make-hash-table-set! assoc hash-function)
(lambda (table key value)
(let* ((data (table-data table))
(h (remainder (hash-function key)
(vector-length data)))
(alist (vector-ref data h))
(probe (assoc key alist)))
(cond (probe
(vector-set! probe 1 value))
(else
(vector-set! data h (new-entry key value alist))
(let ((size (+ (table-size table) 1)))
(if (< size (vector-length data))
(set-table-size! table size)
(expand-hash-table! table size))))))))
(define (expand-hash-table! table size)
(let ((data (table-data table)))
(table-expand-table! table (next-table-size size))
(do ((i 0 (+ i 1)))
((>= i (vector-length data)))
(table-enter-alist! table (vector-ref data i)))))
(define (table-enter-alist! table alist)
(let ((set!-proc (table-set!-procedure table)))
(do ((alist alist (vector-ref alist 2)))
((not alist))
(let ((value (vector-ref alist 1)))
(if value (set!-proc table (vector-ref alist 0) value))))))
(define (table-expand-table! table size)
(set-table-size! table 0)
(if (< size table-size-limit)
(set-table-data! table (make-vector size #f))
(error "requested table size is too large" size)))
(define (table-walk proc table)
(really-table-walk (lambda (v)
(let ((value (vector-ref v 1)))
(if value (proc (vector-ref v 0) value))))
table))
(define (really-table-walk proc table)
(let ((data (table-data table)))
(cond ((not data))
((= 3 (vector-length data))
(alist-walk proc data))
(else
(do ((i 0 (+ i 1)))
((>= i (vector-length data)))
(alist-walk proc (vector-ref data i)))))))
(define (alist-walk proc alist)
(do ((alist alist (vector-ref alist 2)))
((not alist))
(proc alist)))
(define (make-table-immutable! table)
(really-table-walk make-immutable! table)
(make-immutable! (table-data table))
(make-immutable! table))
(define (table->entry-list table)
(let ((list '()))
(table-walk (lambda (k v)
(set! list (cons v list)))
table)
list))
; Actual tables
; The default hash function only on works on things that would work in
; a CASE expression. Even then, numbers don't really "work," since
; they are compared using eq?.
(define (default-table-hash-function obj)
(cond ((symbol? obj) (string-hash (symbol->string obj)))
((integer? obj)
(if (< obj 0) (- -1 obj) obj))
((char? obj) (+ 333 (char->integer obj)))
((eq? obj #f) 3001)
((eq? obj #t) 3003)
((null? obj) 3005)
(else (error "value cannot be used as a table key" obj))))
; (define string-hash (structure-ref features string-hash))
(define (symbol-hash symbol)
(string-hash (symbol->string symbol)))
(define make-table
(let ((make-usual-table (make-table-maker eq? default-table-hash-function)))
(lambda hash-function-option
(if (null? hash-function-option)
(make-usual-table)
((make-table-maker eq? (car hash-function-option)))))))
(define make-string-table (make-table-maker string=? string-hash))
(define make-symbol-table (make-table-maker eq? symbol-hash))
(define make-integer-table (make-table-maker = (lambda (x) x)))

144
big/lu-decomp.scm
View File

@ -1,144 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; LU Decomposition (a rewriting of a Pascal program from `Numerical Recipes
; in Pascal'.
; A is an NxN matrix that is updated in place.
; This returns a row permutation vector and the sign of that vector.
(define *lu-decomposition-epsilon* 1.0e-20)
(define (lu-decomposition a)
(let* ((n (car (array-shape a)))
(indx (make-vector n))
(sign 1.0)
(vv (make-vector n)))
(do ((i 0 (+ i 1)))
((>= i n))
(do ((j 0 (+ j 1))
(big 0.0 (max big (abs (array-ref a i j)))))
((>= j n)
(if (= big 0.0)
(error "lu-decomposition matrix has a zero row" a i))
(vector-set! vv i (/ big)))))
(do ((j 0 (+ j 1)))
((>= j n))
(let ()
(define (sum-elts i end)
(do ((k 0 (+ k 1))
(sum (array-ref a i j)
(- sum (* (array-ref a i k)
(array-ref a k j)))))
((>= k end)
sum)))
(do ((i 0 (+ i 1)))
((>= i j))
(array-set! a (sum-elts i i) i j))
(receive (big imax)
(let loop ((i j) (big 0.0) (imax 0))
(if (>= i n)
(values big imax)
(let ((sum (sum-elts i j)))
(array-set! a sum i j)
(let ((temp (* (vector-ref vv i) (abs sum))))
(if (>= temp big)
(loop (+ i 1) temp i)
(loop (+ i 1) big imax))))))
(if (not (= j imax))
(do ((k 0 (+ k 1)))
((>= k n))
(let ((temp (array-ref a imax k)))
(array-set! a (array-ref a j k) imax k)
(array-set! a temp j k))
(set! sign (- sign))
(vector-set! vv imax (vector-ref vv j))))
(vector-set! indx j imax)
(if (= (array-ref a j j) 0.0)
(array-set! a *lu-decomposition-epsilon* j j))
(if (not (= j (- n 1)))
(let ((temp (/ (array-ref a j j))))
(do ((i (+ j 1) (+ i 1)))
((>= i n))
(array-set! a (* (array-ref a i j) temp) i j)))))))
(values indx sign)))
(define (lu-back-substitute a indx b)
(let ((n (car (array-shape a))))
(let loop ((i 0) (ii #f))
(if (< i n)
(let* ((ip (vector-ref indx i))
(temp (vector-ref b ip)))
(vector-set! b ip (vector-ref b i))
(let ((new (if ii
(do ((j ii (+ j 1))
(sum temp (- sum (* (array-ref a i j)
(vector-ref b j)))))
((>= j i)
sum))
temp)))
(vector-set! b i new)
(loop (+ i 1)
(if (or ii (= temp 0.0)) ii i))))))
(do ((i (- n 1) (- i 1)))
((< i 0))
(do ((j (+ i 1) (+ j 1))
(sum (vector-ref b i) (- sum (* (array-ref a i j)
(vector-ref b j)))))
((>= j n)
(vector-set! b i (/ sum (array-ref a i i))))))))
;(define m
; (array '(4 4)
; 1.0 2.0 3.0 -2.0
; 8.0 -6.0 6.0 1.0
; 3.0 -2.0 0.0 -7.0
; 4.0 7.0 2.0 -1.0))
;
;(define b '#(2.0 1.0 3.0 -2.0))
;
;(define (test m b)
; (let* ((a (copy-array m))
; (n (car (array-shape m)))
; (x (make-vector n)))
;
; (do ((i 0 (+ i 1)))
; ((>= i n))
; (vector-set! x i (vector-ref b i)))
;
; (display "b = ")
; (display b)
; (newline)
;
; (call-with-values
; (lambda ()
; (lu-decomposition a))
; (lambda (indx sign)
; (lu-back-substitute a indx x)
;
; (display "x = ")
; (display x)
; (newline)
;
; (let ((y (make-vector (vector-length b))))
; (do ((i 0 (+ i 1)))
; ((>= i n))
; (do ((j 0 (+ j 1))
; (t 0.0 (+ t (* (array-ref m i j) (vector-ref x j)))))
; ((>= j n)
; (vector-set! y i t))))
;
; (display "a * x =")
; (display y)
; (newline))))))

298
big/new-ports.scm
View File

@ -1,298 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Additional port types
(define close-port (structure-ref primitives close-port))
(define write-string (structure-ref ports write-string))
; Keeping track of a port's current row and column.
(define-record-type port-location
()
((row 0)
(column 0)))
(define make-port-location port-location-maker)
(define (update-row-and-column location char)
(cond ((eof-object? char) (values))
((char=? char #\newline)
(set-port-location-row! location (+ 1 (port-location-row location)))
(set-port-location-column! location 0))
(else
(set-port-location-column! location
(+ 1 (port-location-column location))))))
(define (update-row-and-column-from-string location string)
(let loop ((i 0)
(row (port-location-row location))
(column (port-location-column location)))
(cond ((>= i (string-length string))
(set-port-location-row! location row)
(set-port-location-column! location column))
((char=? #\newline (string-ref string i))
(loop (+ i 1) (+ row 1) 0))
(else
(loop (+ i 1) row (+ column 1))))))
; Input ports that keep track of the current row and column.
(define-record-type input-port-data
(sub-port)
((location (make-port-location))))
(define input-port-methods
(make-input-port-methods
(lambda (data)
(close-port (input-port-data-sub-port data)))
(lambda (data)
(let ((char (read-char (input-port-data-sub-port data))))
(update-row-and-column (input-port-data-location data) char)
char))
(lambda (data)
(peek-char (input-port-data-sub-port data)))
(lambda (data)
(char-ready? (input-port-data-sub-port data)))
(lambda (data)
(port-location-column (input-port-data-location data)))
(lambda (data)
(port-location-row (input-port-data-location data)))))
(define (make-tracking-input-port sub-port)
(make-extensible-input-port (input-port-data-maker sub-port)
input-port-methods))
; Output ports that keep track of the current row and column.
(define-record-type output-port-data
(sub-port)
((location (make-port-location))))
(define output-port-methods
(make-output-port-methods
(lambda (data)
(close-port (output-port-data-sub-port data)))
(lambda (data char)
(write-char char (output-port-data-sub-port data))
(update-row-and-column (output-port-data-location data) char))
(lambda (data string)
(write-string string (output-port-data-sub-port data))
(update-row-and-column-from-string (output-port-data-location data)
string))
(lambda (data)
(force-output (output-port-data-sub-port data)))
(lambda (data)
(let ((location (output-port-data-location data)))
(cond ((not (= 0 (port-location-column location)))
(write-char #\newline (output-port-data-sub-port data))
(set-port-location-column! location 0)
(set-port-location-row! location
(+ 1 (port-location-row location)))))))
(lambda (data)
(port-location-column (output-port-data-location data)))
(lambda (data)
(port-location-row (output-port-data-location data)))))
(define (make-tracking-output-port sub-port)
(make-extensible-output-port (output-port-data-maker sub-port)
output-port-methods))
;------------------------------------------------------------------------------
; String input ports
(define-record-type string-input-port-data
(string)
((location (make-port-location))
(index 0)))
(define (make-string-input-port string)
(make-extensible-input-port (string-input-port-data-maker string)
string-input-port-methods))
(define string-input-port-methods
(make-input-port-methods
(lambda (data)
(set-string-input-port-data-index!
(string-length (string-input-port-data-string data))))
(lambda (data)
(let ((string (string-input-port-data-string data))
(index (string-input-port-data-index data)))
(cond ((>= index (string-length string))
eof-object)
(else
(let ((char (string-ref string index)))
(set-string-input-port-data-index! data (+ index 1))
(update-row-and-column (string-input-port-data-location data)
char)
char)))))
(lambda (data)
(let ((string (string-input-port-data-string data))
(index (string-input-port-data-index data)))
(if (>= index (string-length string))
eof-object
(string-ref string index))))
(lambda (data)
(let ((string (string-input-port-data-string data))
(index (string-input-port-data-index data)))
(< index (string-length string))))
(lambda (data)
(port-location-column (string-input-port-data-location data)))
(lambda (data)
(port-location-row (string-input-port-data-location data)))))
;------------------------------------------------------------------------------
; String output ports
(define-record-type string-output-port-data
()
((location (make-port-location))
(strings '())
(index string-port-string-length)
(open? #t)))
(define (make-string-output-port)
(make-extensible-output-port (string-output-port-data-maker)
string-output-port-methods))
; The length of the strings used in STRING-OUTPUT-PORTs.
(define string-port-string-length 80)
; Write a character to a string-output-port. If there is not room in the
; current string, make a new one and put the character in that; otherwise put
; the character in the current string and increment the index.
(define (write-char-to-string char data)
(let ((index (string-output-port-data-index data))
(strings (string-output-port-data-strings data)))
(cond ((>= index string-port-string-length)
(let ((new (make-string string-port-string-length #\space)))
(string-set! new 0 char)
(set-string-output-port-data-strings! data (cons new strings))
(set-string-output-port-data-index! data 1)))
(else
(string-set! (car strings) index char)
(set-string-output-port-data-index! data (+ index 1))))))
; UPDATE-ROW-AND-COLUMN-FROM-STRING could be integrated with this.
(define (write-string-to-string from data)
(let ((index (string-output-port-data-index data))
(strings (string-output-port-data-strings data)))
(let loop ((i 0) (index index) (strings strings))
(cond ((>= i (string-length from))
(set-string-output-port-data-index! data index)
(set-string-output-port-data-strings! data strings))
((>= index string-port-string-length)
(let ((new (make-string string-port-string-length #\space)))
(string-set! new 0 (string-ref from i))
(loop (+ i 1) 1 (cons new strings))))
(else
(string-set! (car strings) index (string-ref from i))
(loop (+ i 1) (+ index 1) strings))))))
; Concatenates all of the strings of characters in WRITER into a single
; string. Nothing is done if WRITER is not a string-output-port.
(define (string-output-port-output port)
(let* ((data (extensible-output-port-local-data port))
(strings (string-output-port-data-strings data))
(index (string-output-port-data-index data)))
(if (null? strings)
""
(let* ((total (+ index (* (length (cdr strings))
string-port-string-length)))
(result (make-string total #\space)))
(do ((i 0 (+ i string-port-string-length))
(s (reverse (cdr strings)) (cdr s)))
((null? s)
(string-insert result (car strings) i index))
(string-insert result (car s) i string-port-string-length))
result))))
; Copy the first COUNT characters from FROM to TO, putting them from START
; onwards.
(define (string-insert to from start count)
(do ((i 0 (+ i 1)))
((>= i count))
(string-set! to (+ start i) (string-ref from i))))
(define string-output-port-methods
(make-output-port-methods
(lambda (data)
(set-string-output-port-data-open?! data #f))
(lambda (data char)
(cond ((string-output-port-data-open? data)
(write-char-to-string char data)
(update-row-and-column (string-output-port-data-location data)
char))
(else
(error "writing to closed port" data)))) ; not a great argument
(lambda (data string)
(cond ((string-output-port-data-open? data)
(write-string-to-string string data)
(update-row-and-column-from-string
(string-output-port-data-location data)
string))
(else
(error "writing to closed port" data)))) ; not a great argument
(lambda (data)
#f) ; nothing to do on a force-output
(lambda (data)
(let ((location (string-output-port-data-location data)))
(cond ((not (string-output-port-data-open? data))
(error "writing to closed port" data)) ; not a great argument
((not (= 0 (port-location-column location)))
(write-char-to-string #\newline data)
(set-port-location-column! location 0)
(set-port-location-row! location
(+ 1 (port-location-row location)))))))
(lambda (data)
(port-location-column (string-output-port-data-location data)))
(lambda (data)
(port-location-row (string-output-port-data-location data)))))
(define (call-with-string-output-port proc)
(let ((port (make-string-output-port)))
(proc port)
(string-output-port-output port)))
;------------------------------------------------------------------------------
; Output ports from a single character writer
(define char-at-a-time-output-port-methods
(make-output-port-methods
(lambda (data) #f) ; nothing to do on a close
(lambda (data char)
(data char))
(lambda (data string)
(do ((i 0 (+ i 1)))
((>= i (string-length string)))
(data (string-ref string i))))
(lambda (data)
#f) ; nothing to do on a force-output
(lambda (data)
(data #\newline))
(lambda (data)
#f)
(lambda (data)
#f)))
(define (make-char-at-a-time-output-port proc)
(make-extensible-output-port proc
char-at-a-time-output-port-methods))
(define (write-one-line port count proc)
(call-with-current-continuation
(lambda (quit)
(proc (make-char-at-a-time-output-port
(lambda (char)
(write-char char port)
(set! count (- count 1))
(if (<= count 0)
(quit #f))))))))
; Unix-specific kludge
(define eof-object (call-with-input-file "/dev/null" read-char))

431
big/pp.scm
View File

@ -1,431 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
;;;; A pretty-printer
; This isn't exactly in the spirit of the rest of the Scheme 48
; system. It's too hairy, and it has unexploited internal generality.
; It really ought to be rewritten. In addition, it seems to be buggy
; -- it sometimes prints unnecessarily wide lines. Usually it's
; better than no pretty printer at all, so we tolerate it.
; From: ramsdell@linus.mitre.org
; Date: Wed, 12 Sep 1990 05:14:49 PDT
;
; As you noted in your comments, pp.scm is not a straight forward
; program. You could add some comments that would greatly ease the task
; of figuring out what his going on. In particular, you should describe
; the interface of various objects---most importantly the interface of a
; formatter. You might also add some description as to what protocol
; they are to follow.
; Other things to implement some day:
; - LET, LET*, LETREC binding lists should be printed vertically if longer
; than about 30 characters
; - COND clauses should all be printed vertically if the COND is vertical
; - Add an option to lowercase or uppercase symbols and named characters.
; - Parameters controlling behavior of printer should be passed around
; - Do something about choosing between #f and ()
; - Insert line breaks intelligently following head of symbol-headed list,
; when necessary
; - Some equivalents of *print-level*, *print-length*, *print-circle*.
; Possible strategies:
; (foo x y z) Horizontal = infinity sticky
; (foo x y One sticky + one + body (e.g. named LET)
; z
; w)
; (foo x One + body
; y
; z)
; (foo x Two + body
; y
; z)
; (foo x Big ell = infinity + body (combination)
; y
; z)
; (foo Little ell, zero + body (combination)
; x
; y)
; (foo Vertical
; x
; y)
;
; Available height/width tradeoffs:
; Combination:
; Horizontal, big ell, or little ell.
; Special form:
; Horizontal, or M sticky + N + body.
; Random (e.g. vector, improper list, non-symbol-headed list):
; Horizontal, or vertical. (Never zero plus body.)
(define (p x . port-option)
(let ((port (if (pair? port-option) (car port-option)
(current-output-port))))
(pretty-print x port 0)
(newline port)))
(define *line-width* 80)
(define *single-line-special-form-limit* 30)
; Stream primitives
(define head car)
(define (tail s) (force (cdr s)))
(define (map-stream proc stream)
(cons (proc (head stream))
(delay (map-stream proc (tail stream)))))
(define (stream-ref stream n)
(if (= n 0)
(head stream)
(stream-ref (tail stream) (- n 1))))
; Printer
(define (pretty-print obj port pos)
(let ((node (pp-prescan obj 0)))
; (if (> (column-of (node-dimensions node)) *line-width*)
; ;; Eventually add a pass to change format of selected combinations
; ;; from big-ell to little-ell.
; (begin (display ";** too wide - ")
; (write (node-dimensions node))
; (newline)))
(print-node node port pos)))
(define make-node list)
(define (node-dimensions node)
((car node)))
(define (node-pass-2 node pos)
((cadr node) pos))
(define (print-node node port pos)
((caddr node) port pos))
(define (pp-prescan obj hang)
(cond ((symbol? obj)
(make-leaf (string-length (symbol->string obj))
obj hang))
((number? obj)
(make-leaf (string-length (number->string obj))
obj hang))
((boolean? obj)
(make-leaf 2 obj hang))
((string? obj)
;;++ Should count number of backslashes and quotes
(make-leaf (+ (string-length obj) 2) obj hang))
((char? obj)
(make-leaf (case obj
((#\space) 7)
((#\newline) 9)
(else 3))
obj hang))
((pair? obj)
(pp-prescan-pair obj hang))
((vector? obj)
(pp-prescan-vector obj hang))
(else
(pp-prescan-random obj hang))))
(define (make-leaf width obj hang)
(let ((width (+ width hang)))
(make-node (lambda () width)
(lambda (pos)
(+ pos width))
(lambda (port pos)
(write obj port)
(do ((i 0 (+ i 1)))
((>= i hang) (+ pos width))
(write-char #\) port))))))
(define (make-prefix-node string node)
(let ((len (string-length string)))
(make-node (lambda ()
(+ (node-dimensions node) len))
(lambda (pos)
(node-pass-2 node (+ pos len)))
(lambda (port pos)
(display string port)
(print-node node port (+ pos len))))))
(define (pp-prescan-vector obj hang)
(if (= (vector-length obj) 0)
(make-leaf 3 obj hang)
(make-prefix-node "#" (pp-prescan-list (vector->list obj) #t hang))))
; Improve later.
(define (pp-prescan-random obj hang)
(let ((l (disclose obj)))
(if (list? l)
(make-prefix-node "#." (pp-prescan-list l #t hang))
(make-leaf 25 obj hang)))) ;Very random number
(define (pp-prescan-pair obj hang)
(cond ((read-macro-inverse obj)
=>
(lambda (inverse)
(make-prefix-node inverse (pp-prescan (cadr obj) hang))))
(else
(pp-prescan-list obj #f hang))))
(define (pp-prescan-list obj random? hang)
(let loop ((l obj) (z '()))
(if (pair? (cdr l))
(loop (cdr l)
(cons (pp-prescan (car l) 0) z))
(make-list-node
(reverse
(if (null? (cdr l))
(cons (pp-prescan (car l) (+ hang 1)) z)
(cons (make-prefix-node ". " (pp-prescan (cdr l) (+ hang 1)))
(cons (pp-prescan (car l) 0) z))))
obj
(or random? (not (null? (cdr l))))))))
; Is it sufficient to tell parent node:
; At a cost of X line breaks, I can make myself narrower by Y columns. ?
; Then how do we decide whether we narrow ourselves or some of our children?
(define (make-list-node node-list obj random?)
(let* ((random? (or random?
;; Heuristic for things like do, cond, let, ...
(not (symbol? (car obj)))
(eq? (car obj) 'else)))
(probe (if (not random?)
(indentation-for (car obj))
#f))
(format horizontal-format)
(dimensions (compute-dimensions node-list format))
(go-non-horizontal
(lambda (col)
(set! format
(cond (random? vertical-format)
(probe (probe obj))
(else big-ell-format)))
(let* ((start-col (+ col 1))
(col (node-pass-2 (car node-list) start-col))
(final-col
(format (cdr node-list)
(lambda (node col target-col)
(node-pass-2 node target-col))
start-col
(+ col 1)
col)))
(set! dimensions (compute-dimensions node-list format))
final-col))))
(if (> dimensions
(if probe
*single-line-special-form-limit*
*line-width*))
(go-non-horizontal 0))
(make-node (lambda () dimensions)
(lambda (col) ;Pass 2: if necessary, go non-horizontal
(let ((defacto (+ col (column-of dimensions))))
(if (> defacto *line-width*)
(go-non-horizontal col)
defacto)))
(lambda (port pos)
(write-char #\( port)
(let* ((pos (+ pos 1))
(start-col (column-of pos))
(pos (print-node (car node-list) port pos)))
(format (cdr node-list)
(lambda (node pos target-col)
(let ((pos (go-to-column target-col
port pos)))
(print-node node port pos)))
start-col
(+ (column-of pos) 1)
pos))))))
(define (compute-dimensions node-list format)
(let* ((start-col 1) ;open paren
(pos (+ (make-position start-col 0)
(node-dimensions (car node-list)))))
(format (cdr node-list)
(lambda (node pos target-col)
(let* ((dims (node-dimensions node))
(lines (+ (line-of pos) (line-of dims)))
(width (+ target-col (column-of dims))))
(if (>= (column-of pos) target-col)
;; Line break required
(make-position
(max (column-of pos) width)
(+ lines 1))
(make-position width lines))))
start-col
(+ (column-of pos) 1) ;first-col
pos)))
; Three positions are significant
; (foo baz ...)
; ^ ^ ^
; | | +--- (column-of pos)
; | +------ first-col
; +---------- start-col
; Separators
(define on-same-line
(lambda (start-col first-col pos)
start-col first-col ;ignored
(+ (column-of pos) 1)))
(define indent-under-first
(lambda (start-col first-col pos)
start-col ;ignored
first-col))
(define indent-for-body
(lambda (start-col first-col pos)
first-col ;ignored
(+ start-col 1)))
(define indent-under-head
(lambda (start-col first-col pos)
first-col ;ignored
start-col))
; Format constructors
(define (once separator format)
(lambda (tail proc start-col first-col pos)
(if (null? tail)
pos
(let ((target-col (separator start-col first-col pos)))
(format (cdr tail)
proc
start-col
first-col
(proc (car tail) pos target-col))))))
(define (indefinitely separator)
(letrec ((self (once separator ;eta
(lambda (tail proc start-col first-col pos)
(self tail proc start-col first-col pos)))))
self))
(define (repeatedly separator count format)
(do ((i 0 (+ i 1))
(format format
(once separator format)))
((>= i count) format)))
; Particular formats
(define vertical-format
(indefinitely indent-under-head))
(define horizontal-format
(indefinitely on-same-line))
(define big-ell-format
(indefinitely indent-under-first))
(define little-ell-format
(indefinitely indent-for-body))
(define format-for-named-let
(repeatedly on-same-line 2 (indefinitely indent-for-body)))
(define hook-formats
(letrec ((stream (cons little-ell-format
(delay (map-stream (lambda (format)
(once indent-under-first format))
stream)))))
stream))
; Hooks for special forms.
; A hook maps an expression to a format.
(define (compute-let-indentation exp)
(if (and (not (null? (cdr exp)))
(symbol? (cadr exp)))
format-for-named-let
(stream-ref hook-formats 1)))
(define hook
(let ((hooks (map-stream (lambda (format)
(lambda (exp) exp ;ignored
format))
hook-formats)))
(lambda (n)
(stream-ref hooks n))))
; Table of indent hooks.
(define indentations (make-table))
(define (indentation-for name)
(table-ref indentations name))
(define (define-indentation name n)
(table-set! indentations
name
(if (integer? n) (hook n) n)))
; Indent hooks for Revised^n Scheme.
(for-each (lambda (name)
(define-indentation name 1))
'(lambda define define-syntax let* letrec let-syntax letrec-syntax
case call-with-values call-with-input-file
call-with-output-file with-input-from-file
with-output-to-file syntax-rules))
(define-indentation 'do 2)
(define-indentation 'call-with-current-continuation 0)
(define-indentation 'let compute-let-indentation)
; Kludge to force vertical printing (do AND and OR as well?)
(define-indentation 'if (lambda (exp) big-ell-format))
(define-indentation 'cond (lambda (exp) big-ell-format))
; Other auxiliaries
(define (go-to-column target-col port pos) ;=> pos
;; Writes at least one space or newline
(let* ((column (column-of pos))
(line (if (>= column target-col)
(+ (line-of pos) 1)
(line-of pos))))
(do ((column (if (>= column target-col)
(begin (newline port) 0)
column)
(+ column 1)))
((>= column target-col)
(make-position column line))
(write-char #\space port))))
(define (make-position column line)
(+ column (* line 1000)))
(define (column-of pos)
(remainder pos 1000))
(define (line-of pos)
(quotient pos 1000))
(define (read-macro-inverse x)
(cond ((and (pair? x)
(pair? (cdr x))
(null? (cddr x)))
(case (car x)
((quote) "'")
((quasiquote) "`")
((unquote) ",")
((unquote-splicing) ",@")
(else #f)))
(else #f)))
; For the command processor:
;(define-command 'p "<exp>" "pretty-print" '(expression)
; (p (eval expression (user-package)) (command-output)))

92
big/queue.scm
View File

@ -1,92 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Queues
; Richard's code with Jonathan's names.
;
; Richard's names: Jonathan's names:
; make-empty-queue make-queue
; add-to-queue! enqueue
; remove-from-queue! dequeue
(define-record-type queue :queue
(really-make-queue uid head tail)
queue?
(uid queue-uid)
(head queue-head set-queue-head!)
(tail queue-tail set-queue-tail!))
(define *queue-uid* 0)
(define (make-queue)
(let ((uid *queue-uid*))
(set! *queue-uid* (+ uid 1)) ;potential synchronization screw
(really-make-queue uid '() '())))
; The procedures for manipulating queues.
(define (queue-empty? q)
(null? (queue-head q)))
(define (enqueue q v)
(let ((p (cons v '())))
(if (null? (queue-head q)) ;(queue-empty? q)
(set-queue-head! q p)
(set-cdr! (queue-tail q) p))
(set-queue-tail! q p)))
(define (queue-front q)
(if (queue-empty? q)
(error "queue is empty" q)
(car (queue-head q))))
(define (dequeue q)
(let ((pair (queue-head q)))
(cond ((null? pair) ;(queue-empty? q)
(error "empty queue" q))
(else
(let ((value (car pair))
(next (cdr pair)))
(set-queue-head! q next)
(if (null? next)
(set-queue-tail! q '())) ; don't retain pointers
value)))))
(define (on-queue? v q)
(memq v (queue-head q)))
; This removes the first occurrence of V from Q.
(define (delete-from-queue! q v)
(delete-from-queue-if! q (lambda (x) (eq? x v))))
(define (delete-from-queue-if! q pred)
(let ((list (queue-head q)))
(cond ((null? list)
#f)
((pred (car list))
(set-queue-head! q (cdr list))
(if (null? (cdr list))
(set-queue-tail! q '())) ; don't retain pointers
#t)
((null? (cdr list))
#f)
(else
(let loop ((list list))
(let ((tail (cdr list)))
(cond ((null? tail)
#f)
((pred (car tail))
(set-cdr! list (cdr tail))
(if (null? (cdr tail))
(set-queue-tail! q list))
#t)
(else
(loop tail)))))))))
(define (queue->list q) ;For debugging
(map (lambda (x) x)
(queue-head q)))
(define (queue-length q)
(length (queue-head q)))

54
big/random.scm
View File

@ -1,54 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Random number generator, extracted from T sources. Original
; probably by Richard Kelsey,
(define half-log 14)
(define full-log (* half-log 2))
(define half-mask (- (arithmetic-shift 1 half-log) 1))
(define full-mask (- (arithmetic-shift 1 full-log) 1))
(define index-log 6)
(define random-1 (bitwise-and 314159265 full-mask))
(define random-2 (bitwise-and 271828189 full-mask))
; (MAKE-RANDOM <seed>) takes an integer seed and returns a procedure of no
; arguments that returns a new pseudo-random number each time it is called.
(define (make-random seed)
(make-random-vector seed
(lambda (vec a b)
(lambda ()
(set! a (randomize a random-1 random-2))
(set! b (randomize b random-2 random-1))
(let* ((index (arithmetic-shift a (- index-log full-log)))
(c (vector-ref vec index)))
(vector-set! vec index b)
c)))))
(define (randomize x mult ad)
(bitwise-and (+ (low-bits-of-product x mult) ad)
full-mask))
(define (make-random-vector seed return)
(let* ((size (arithmetic-shift 1 index-log))
(vec (make-vector size 0)))
(do ((i 0 (+ i 1))
(b seed (randomize b random-2 random-1)))
((>= i size)
(return vec seed b))
(vector-set! vec i b))))
; Compute low bits of product of two fixnums using only fixnum arithmetic.
; [x1 x2] * [y1 y2] = [x1y1 (x1y2+x2y1) x2y2]
(define (low-bits-of-product x y)
(let ((x1 (arithmetic-shift x (- 0 half-log)))
(y1 (arithmetic-shift y (- 0 half-log)))
(x2 (bitwise-and x half-mask))
(y2 (bitwise-and y half-mask)))
(bitwise-and (+ (* x2 y2)
(arithmetic-shift (bitwise-and (+ (* x1 y2) (* x2 y1))
half-mask)
half-log))
full-mask)))

8
big/receive.scm
View File

@ -1,8 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
(define-syntax receive
(syntax-rules ()
((receive ?vars ?producer . ?body)
(call-with-values (lambda () ?producer)
(lambda ?vars . ?body)))))

397
big/search-tree.scm
View File

@ -1,397 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
;Date: Thu, 4 Nov 93 13:30:46 EST
;To: jar@ai.mit.edu
;Subject: binary search trees
;From: kelsey@research.nj.nec.com
;
;
;For no particular reason I implemented balanced binary search
;trees as another random data structure to go in big. The only
;things it uses from BIG-SCHEME are DEFINE-RECORD-TYPE and
;RECEIVE.
;
;(define-interface search-tree-interface
; (export make-search-tree
; search-tree-ref
; search-tree-set!
; search-tree-modify!
; search-tree-max
; search-tree-min
; walk-search-tree))
;
;(define-structure search-tree search-tree-signature
; (open big-scheme scheme)
; (files (big search-tree)))
; Red-Black binary search trees as described in Introduction to Algorithms
; by Cormen, Leiserson, and Rivest.
;
; (make-search-tree key-= key-<) -> tree
;
; (search-tree-ref tree key) -> value
;
; (search-tree-set! tree key value)
;
; (search-tree-modify! tree key proc)
; == (search-tree-set! tree key (proc (search-tree-ref tree key)))
;
; (search-tree-max tree) -> key + value
;
; (search-tree-min tree) -> key + value
;
; (walk-search-tree proc tree)
; applies PROC in order to all key + value pairs with a non-#F value
(define-record-type tree
(lookup
nil) ; node marker for missing leaf nodes (used in REALLY-DELETE!)
((root #f)))
(define (make-search-tree = <)
(let ((nil (make-node #f #f #f)))
(set-node-red?! nil #f)
(tree-maker (make-lookup = <) nil)))
(define-record-type node
((key)
(value)
(parent)) ; #F for the root node
((red? #t)
(left #f)
(right #f)))
(define make-node node-maker)
(define-record-discloser type/node
(lambda (node)
(list 'node (node-key node))))
(define (search-tree-ref tree key)
(receive (node parent left?)
((tree-lookup tree) tree key)
(if node
(node-value node)
#f)))
(define (search-tree-set! tree key value)
(search-tree-modify! tree key (lambda (ignore) value)))
(define (search-tree-modify! tree key proc)
(receive (node parent left?)
((tree-lookup tree) tree key)
(let ((new-value (proc (if node (node-value node) #f))))
(cond ((and node new-value)
(set-node-value! node new-value))
(new-value
(really-insert! tree parent left? (make-node key new-value parent)))
(node
(really-delete! tree node))))))
(define (search-tree-max tree)
(let ((node (tree-root tree)))
(if node
(let loop ((node node))
(cond ((node-right node)
=> loop)
(else
(values (node-key node) (node-value node)))))
(values #f #f))))
(define (search-tree-min tree)
(let ((node (tree-root tree)))
(if node
(let loop ((node node))
(cond ((node-left node)
=> loop)
(else
(values (node-key node) (node-value node)))))
(values #f #f))))
(define (walk-search-tree proc tree)
(let recur ((node (tree-root tree)))
(cond (node
(recur (node-left node))
(proc (node-key node) (node-value node))
(recur (node-right node))))))
(define (make-lookup = <)
(lambda (tree key)
(let loop ((node (tree-root tree))
(parent #f)
(left? #f))
(cond ((not node)
(values #f parent left?))
((= (node-key node) key)
(values node #f #f))
((< key (node-key node))
(loop (node-left node) node #t))
(else
(loop (node-right node) node #f))))))
; Parameterized node access
(define (node-child node left?)
(if left?
(node-left node)
(node-right node)))
(define (set-node-child! node left? child)
(if left?
(set-node-left! node child)
(set-node-right! node child)))
; Empty leaf slots are considered black.
(define (node-black? node)
(not (and node (node-red? node))))
; The next node (used in REALLY-DELETE!)
(define (successor node)
(cond ((node-right node)
=> (lambda (node)
(let loop ((node node))
(cond ((node-left node)
=> loop)
(else node)))))
(else
(let loop ((node node) (parent (node-parent node)))
(if (and parent
(eq? node (node-right parent)))
(loop parent (node-parent parent))
parent)))))
(define (really-insert! tree parent left? node)
(if (not parent)
(set-tree-root! tree node)
(set-node-child! parent left? node))
(fixup-insertion! node tree))
(define (fixup-insertion! node tree)
(let loop ((node node))
(let ((parent (node-parent node)))
(if (and parent (node-red? parent))
(let* ((grand (node-parent parent))
(left? (eq? parent (node-left grand)))
(y (node-child grand (not left?))))
(cond ((node-black? y)
(let* ((node (cond ((eq? node (node-child parent (not left?)))
(rotate! parent left? tree)
parent)
(else node)))
(parent (node-parent node))
(grand (node-parent parent)))
(set-node-red?! parent #f)
(set-node-red?! grand #t)
(rotate! grand (not left?) tree)
(loop node)))
(else
(set-node-red?! parent #f)
(set-node-red?! y #f)
(set-node-red?! grand #t)
(loop grand)))))))
(set-node-red?! (tree-root tree) #f))
; A B
; / \ =(rotate! A #f tree)=> / \
; B k i A
; / \ <=(rotate! B #t tree)= / \
; i j j k
(define (rotate! node left? tree)
(let* ((y (node-child node (not left?)))
(y-left (node-child y left?))
(parent (node-parent node)))
(set-node-child! node (not left?) y-left)
(if y-left
(set-node-parent! y-left node))
(replace! parent y node tree)
(set-node-child! y left? node)
(set-node-parent! node y)))
; Replace CHILD (of PARENT) with NEW-CHILD
(define (replace! parent new-child child tree)
(set-node-parent! new-child parent)
(cond ((eq? child (tree-root tree))
(set-tree-root! tree new-child))
((eq? child (node-left parent))
(set-node-left! parent new-child))
(else
(set-node-right! parent new-child))))
(define (really-delete! tree node)
(let* ((y (cond ((or (not (node-left node))
(not (node-right node)))
node)
(else
(let ((y (successor node)))
(set-node-key! node (node-key y))
(set-node-value! node (node-value y))
y))))
(x (or (node-left y)
(node-right y)
(let ((x (tree-nil tree)))
(set-node-right! y x)
x)))
(parent (node-parent y)))
(replace! parent x y tree)
(if (not (node-red? y))
(fixup-delete! x tree))
(let ((nil (tree-nil tree)))
(cond ((node-parent nil)
=> (lambda (p)
(if (eq? (node-right p) nil)
(set-node-right! p #f)
(set-node-left! p #f))
(set-node-parent! (tree-nil tree) #f)))
((eq? nil (tree-root tree))
(set-tree-root! tree #f))))))
(define (fixup-delete! x tree)
(let loop ((x x))
(if (or (eq? x (tree-root tree))
(node-red? x))
(set-node-red?! x #f)
(let* ((parent (node-parent x))
(left? (eq? x (node-left parent)))
(w (node-child parent (not left?)))
(w (cond ((node-red? w)
(set-node-red?! w #f)
(set-node-red?! parent #t)
(rotate! parent left? tree)
(node-child (node-parent x) (not left?)))
(else
w))))
(cond ((and (node-black? (node-left w))
(node-black? (node-right w)))
(set-node-red?! w #t)
(loop (node-parent x)))
(else
(let ((w (cond ((node-black? (node-child w (not left?)))
(set-node-red?! (node-child w left?) #f)
(set-node-red?! w #t)
(rotate! w (not left?) tree)
(node-child (node-parent x) (not left?)))
(else
w))))
(let ((parent (node-parent x)))
(set-node-red?! w (node-red? parent))
(set-node-red?! parent #f)
(set-node-red?! (node-child w (not left?)) #f)
(rotate! parent left? tree)
(set-node-red?! (tree-root tree) #f)))))))))
; Verify that the coloring is correct
;
;(define (okay-tree? tree)
; (receive (okay? red? count)
; (let recur ((node (tree-root tree)))
; (if (not node)
; (values #t #f 0)
; (receive (l-ok? l-r? l-c)
; (recur (node-left node))
; (receive (r-ok? r-r? r-c)
; (recur (node-right node))
; (values (and l-ok?
; r-ok?
; (not (and (node-red? node)
; (or l-r? r-r?)))
; (= l-c r-c))
; (node-red? node)
; (if (node-red? node)
; l-c
; (+ l-c 1)))))))
; okay?))
;
;
;(define (walk-sequences proc list)
; (let recur ((list list) (r '()))
; (if (null? list)
; (proc (reverse r))
; (let loop ((list list) (done '()))
; (if (not (null? list))
; (let ((next (car list)))
; (recur (append (reverse done) (cdr list)) (cons next r))
; (loop (cdr list) (cons next done))))))))
;
;(define (tree-test n)
; (let ((iota (do ((i n (- i 1))
; (l '() (cons i l)))
; ((<= i 0) l))))
; (walk-sequences (lambda (in)
; (walk-sequences (lambda (out)
; (do-tree-test in out))
; iota))
; iota)
; #t))
;
;(define (do-tree-test in out)
; (let ((tree (make-search-tree = <)))
; (for-each (lambda (i)
; (search-tree-set! tree i (- 0 i)))
; in)
; (if (not (okay-tree? tree))
; (breakpoint "tree ~S is not okay" in))
; (if (not (tree-ordered? tree (length in)))
; (breakpoint "tree ~S is not ordered" in))
; (for-each (lambda (i)
; (if (not (= (search-tree-ref tree i) (- 0 i)))
; (breakpoint "looking up ~S in ~S lost" i in)))
; in)
; (do ((o out (cdr o)))
; ((null? o))
; (search-tree-set! tree (car o) #f)
; (if (not (okay-tree? tree))
; (breakpoint "tree ~S is not okay after deletions ~S" in out)))))
;
;(define (tree-ordered? tree count)
; (let ((l '()))
; (walk-search-tree (lambda (key value)
; (set! l (cons (cons key value) l)))
; tree)
; (let loop ((l l) (n count))
; (cond ((null? l)
; (= n 0))
; ((and (= (caar l) n)
; (= (cdar l) (- 0 n)))
; (loop (cdr l) (- n 1)))
; (else #f)))))
;
;(define (do-tests tester)
; (do ((i 0 (+ i 1)))
; (#f)
; (tester i)
; (format #t " done with ~D~%" i)))
;
;(define (another-test n)
; (let ((iota (do ((i n (- i 1))
; (l '() (cons i l)))
; ((<= i 0) l))))
; (walk-sequences (lambda (in)
; (do ((i 1 (+ i 1)))
; ((> i n))
; (let ((tree (make-search-tree = <)))
; (for-each (lambda (i)
; (search-tree-set! tree i (- 0 i)))
; in)
; (if (not (okay-tree? tree))
; (breakpoint "tree ~S is not okay" in))
; (if (not (tree-ordered? tree (length in)))
; (breakpoint "tree ~S is not ordered" in))
; (for-each (lambda (i)
; (if (not (= (search-tree-ref tree i) (- 0 i)))
; (breakpoint "looking up ~S in ~S lost" i in)))
; in)
; (search-tree-set! tree i #f)
; (if (not (okay-tree? tree))
; (breakpoint "tree ~S is not okay after deletion ~S"
; in i))
; (for-each (lambda (j)
; (let ((ref (search-tree-ref tree j)))
; (if (not (eq? ref (if (= j i) #f (- 0 j))))
; (breakpoint "looking up ~S in ~S lost" i in))))
; in))))
; iota)))

101
big/sleep.scm
View File

@ -1,101 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; New, more efficient SLEEP 1/23/92
; Earlier, simpler (and probably better) version:
;(define (sleep n)
; (let ((until (+ (time) n)))
; (with-interrupts-inhibited
; (lambda ()
; (let loop ()
; (if (>= (time) until)
; #t
; (begin (dispatch)
; (loop))))))))
; NYI: If there are no dozers to awake, and no runnable threads, and
; we're running under time sharing, we really ought to be polite and
; relinquish the processor to other processes by doing an appropriate
; system call (on unix, this means pause, sleep, or select).
(define (sleep n)
(let ((cv (make-condvar)))
(with-lock dozers-lock
(lambda ()
(set! *dozers*
(insert (cons (+ (time) n) cv)
*dozers*
(lambda (frob1 frob2)
(< (car frob1) (car frob2)))))
(if (not *wakeup-service*)
(set! *wakeup-service* (spawn wakeup-service 'wakeup-service)))))
(condvar-ref cv)))
(define dozers-lock (make-lock))
(define *dozers* '()) ;List of (wakeup-time . condvar)
; Wakeup service
(define *wakeup-service* #f)
(define (wakeup-service)
(dynamic-wind
relinquish-timeslice
(lambda ()
(let loop ()
(obtain-lock dozers-lock)
(if (not (null? *dozers*))
(begin (wake-up-some-threads)
(release-lock dozers-lock)
(relinquish-timeslice)
(loop)))))
(lambda ()
;; If wakeup service gets killed, propagate kill to the threads
;; it was going to wake up, so their unwind forms can run.
(for-each (lambda (dozer)
(kill-condvar (cdr dozer)))
*dozers*)
(set! *dozers* '()) ;in case of kill-thread
(set! *wakeup-service* #f)
(if (eq? (lock-owner dozers-lock) (current-thread))
(release-lock dozers-lock)))))
(define (wake-up-some-threads)
(if (null? *dozers*)
#f
(if (< (time) (car (car *dozers*)))
#f
(let ((cv (cdr (car *dozers*))))
(set! *dozers* (cdr *dozers*))
(condvar-set! cv #t)
(wake-up-some-threads)))))
(define (insert x l <)
(cond ((null? l) (list x))
((< x (car l)) (cons x l))
(else (cons (car l) (insert x (cdr l) <)))))
; Real time in seconds since some arbitrary origin.
(define (time)
(primitive-time time-option/real-time #f))
(define primitive-time (structure-ref primitives time))
(define time-option/real-time (enum time-option real-time))
(define (read-char-with-timeout port t)
(with-interrupts-inhibited
(lambda ()
(let ((deadline (+ (time) t)))
(let loop ()
(cond ((char-ready? port)
(read-char port))
((< (time) deadline)
(dispatch)
(loop))
(else 'timeout)))))))

151
big/sort.scm
View File

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

170
big/xport.scm
View File

@ -1,170 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Extensible ports
; Input ports
(define-record-type extensible-input-port
(local-data
methods)
())
(define make-extensible-input-port extensible-input-port-maker)
(define-record-type input-port-methods
(close-port
read-char
peek-char
char-ready?
current-column
current-row
)
())
(define make-input-port-methods input-port-methods-maker)
; Output ports
(define-record-type extensible-output-port
(local-data
methods)
())
(define make-extensible-output-port extensible-output-port-maker)
(define-record-type output-port-methods
(close-port
write-char
write-string
force-output
fresh-line
current-column
current-row
)
())
(define make-output-port-methods output-port-methods-maker)
; Operations
; CLOSE-PORT must work on both types of extensible ports.
(define-exception-handler (enum op close-port)
(lambda (opcode args)
(let ((port (car args)))
(cond ((extensible-input-port? port)
((input-port-methods-close-port
(extensible-input-port-methods port))
(extensible-input-port-local-data port)))
((extensible-output-port? port)
((output-port-methods-close-port
(extensible-output-port-methods port))
(extensible-output-port-local-data port)))
(else
(raise-port-exception opcode args))))))
(define (raise-port-exception opcode args)
(signal-exception opcode args))
; Predicates
; These won't work as the VM does not raise an exception when predicates are
; applied to records.
;(define-exception-handler (enum op input-port?)
; (lambda (opcode args)
; (extensible-input-port? (car args))))
;(define-exception-handler (enum op output-port?)
; (lambda (opcode args)
; (extensible-output-port? (car args))))
; These will work for any code loaded subsequently...
(define (input-port? thing)
(or ((structure-ref ports input-port?) thing)
(extensible-input-port? thing)))
(define (output-port? thing)
(or ((structure-ref ports output-port?) thing)
(extensible-output-port? thing)))
; Other methods
(define (define-input-port-method op method)
(define-exception-handler op
(lambda (opcode args)
(let ((port (car args)))
(if (extensible-input-port? port)
((method (extensible-input-port-methods port))
(extensible-input-port-local-data port))
(raise-port-exception opcode args))))))
(define-input-port-method (enum op read-char) input-port-methods-read-char)
(define-input-port-method (enum op peek-char) input-port-methods-peek-char)
(define-input-port-method (enum op char-ready?) input-port-methods-char-ready?)
(define (define-output-port-method op arg-count method)
(define-exception-handler op
(case arg-count
((0)
(lambda (opcode args)
(let ((port (car args)))
(if (extensible-output-port? port)
((method (extensible-output-port-methods port))
(extensible-output-port-local-data port))
(raise-port-exception opcode args)))))
((1)
(lambda (opcode args)
(let ((port (cadr args)))
(if (extensible-output-port? port)
((method (extensible-output-port-methods port))
(extensible-output-port-local-data port)
(car args))
(raise-port-exception opcode args))))))))
(define-output-port-method (enum op write-char)
1 output-port-methods-write-char)
(define-output-port-method (enum op write-string)
1 output-port-methods-write-string)
(define-output-port-method (enum op force-output)
0 output-port-methods-force-output)
(define (make-new-port-method id input-method output-method default)
(lambda (port)
(cond ((extensible-input-port? port)
((input-method (extensible-input-port-methods port))
(extensible-input-port-local-data port)))
((extensible-output-port? port)
((output-method (extensible-output-port-methods port))
(extensible-output-port-local-data port)))
(else
(default port)))))
(define current-column
(make-new-port-method 'current-column
input-port-methods-current-column
output-port-methods-current-column
(lambda (port) #f)))
(define current-row
(make-new-port-method 'current-row
input-port-methods-current-row
output-port-methods-current-row
(lambda (port) #f)))
(define (make-new-output-port-method id method default)
(lambda (port)
(if (extensible-output-port? port)
((method (extensible-output-port-methods port))
(extensible-output-port-local-data port))
(default port))))
(define fresh-line
(make-new-output-port-method 'fresh-line
output-port-methods-fresh-line
newline))
(define force-output (structure-ref ports force-output))

32
build-usual-image
View File

@ -1,32 +0,0 @@
#!/bin/sh
# Build the usual development environment image.
date=`date`
srcdir=$1
lib=$2
image=$3
vm=$4
initial=$5
./$vm -o ./$vm -i $initial batch <<EOF
,load $srcdir/env/init-defpackage.scm
((*structure-ref filenames 'set-translation!)
"=scheme48/" "$srcdir/")
,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/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

989
cig/cig.scm
View File

@ -1,989 +0,0 @@
;;; This file defines the cig foreign function interface for Scheme 48.
;;; The current version is Cig 3.0.
;;; This file contains the following Scheme 48 modules:
;;; - cig-processor
;;; The code for translating DEFINE-FOREIGN forms into C stubs.
;;; - cig-standalone
;;; The S48 top-level for translating stdin->stdout.
;;; - define-foreign-syntax-support
;;; This package must be opened in the FOR-SYNTAX package,
;;; so that the DEFINE-FOREIGN macro-expander code can use it's procedures.
;;; - define-foreign-syntax
;;; This package must be opened by cig's clients, to access the
;;; DEFINE-FOREIGN and FOREIGN-INCLUDE macros.
;;;
;;; Copyright (c) 1994 by Olin Shivers.
(define-structures ((cig-processor (export process-define-foreign-file
process-define-foreign-stream))
(cig-standalone (export cig-standalone-toplevel))
;; This must be opened in the FOR-SYNTAX package.
(define-foreign-syntax-support
(export define-foreign-expander)))
(open scheme formats structure-refs
destructuring receiving
code-vectors) ; for making alien containers.
(access signals) ; for ERROR
(begin
(define error (structure-ref signals error))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The general syntax of define-foreign is:
;;; (define-foreign scheme-name (c-name arg1 ... argn) [no-declare]
;;; ret1
;;; .
;;; retn)
;;;
;;; This defines a Scheme procedure, <scheme-name>. It takes the arguments
;;; arg1 ... argn, type-checks them, and then passes them to a C stub,
;;; df_<c-name>. If the Scheme procedure is to return multiple values, the C
;;; stub also gets a return vector passed to return the extra values. The C
;;; stub rep-converts the Scheme data as specified by the <arg>i declarations,
;;; and then calls the C procedure <c-name>. The C procedure is expected to
;;; return its first value (<ret1>) as its real value. The other return values
;;; are returned by assigning targets passed by-reference to <c-name> by the
;;; stub. These return parameters are passed after the argument parameters.
;;; When <c-name> returns, the C stub df_<c-name> rep-converts the C data,
;;; stuffs extra return values into the Scheme answer vector if there are any,
;;; and returns to the Scheme routine. The Scheme routine completes the
;;; rep-conversion specified by the <ret>i declarations, and return the
;;; values.
;;;
;;; An ARGi spec has the form:
;;; (rep [var])
;;; where REP gives the representation of the value being passed (see
;;; below), and VAR is the name of the Scheme procedure's parameter (for
;;; documentation purposes, mostly).
;;;
;;; The optional symbol NO-DECLARE means "Do not place an extern declaration
;;; of the C routine in the body of the stub." This is necessary for the
;;; occasional strange ANSI C declaration that cig is incapable of generating
;;; (the only case I know of where the C procedure uses varargs, so the C
;;; declaration needs a ..., e.g.,
;;; extern int open(const char *, int flags, ...);
;;; In this case, just use NO-DECLARE, and insert your own a declaration of open()
;;; outside the stub with a
;;; (foreign-source "extern int open(const char *, int flags, ...);")
;;; Ugly, yes.)
;;;
;;; The rep-conversion specs are pretty hairy and baroque. I kept throwing
;;; in machinery until I was able to handle all the Unix syscalls, so that
;;; is what drove the complexity level. See syscalls.scm for examples.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The fields of a rep record for argument reps:
;;; Scheme-pred:
;;; A Scheme predicate for type-testing args. #f means no check.
;;; C-decl:
;;; A C declaration for the argument in its C representation --
;;; the type of the value actually passed to or returned from the foreign
;;; function. This is a format string; the ~a is where the C variable goes.
;;; (format #f c-decl "") is used to compute a pure type -- e.g., for
;;; casts.
;;; C-cvtr:
;;; The Scheme->C rep-converter; a string. Applied as a C
;;; function/macro in the stub. The empty string means the null
;;; rep-conversion.
;;; Post-C:
;;; Optional post-call processing in the C stub; a string like C-cvtr.
;;; If not #f, this form will be applied in the C stub to the C argument
;;; value *after* the C call returns. It is mostly used to free a
;;; block of storage that was malloc'd by the rep converter on the
;;; way in.
(define (argrep:c-decl i) (vector-ref i 0))
(define (argrep:scheme-pred i) (vector-ref i 1))
(define (argrep:c-cvtr i) (vector-ref i 2))
(define (argrep:post-C i) (vector-ref i 3))
;;; The fields of a rep record for return reps:
;;; C-decl:
;;; As above.
;;; immediate?:
;;; If the return value is to be boxed into a carrier passed in from
;;; Scheme, then this is #f. If this value is a true value, then the
;;; C value is to be rep-converted into an immediate Scheme value.
;;; In this case, the immediate? field is a string, naming the C
;;; function/macro used to do the rep-conversion.
;;; C-boxcvtr:
;;; If immediate? is false, then this value specifies the C code
;;; for rep-converting the return value into the Scheme carrier.
;;; It is a procedure, which is called on two string arguments:
;;; a C variable bound to the carrier, and a C variable bound to
;;; the C return value. The procedure returns a string which is a
;;; C statement for doing the rep-conversion. To pass a raw C value
;;; back, for instance, you would use the following box converter:
;;; (lambda (carrier c-val) (string-append carrier "=" c-val ";"))
;;; make-carrier:
;;; A procedure that when called returns a carrier. This field is only
;;; used if immediate? is #f. This field is a Scheme expression.
;;; S-cvtr
;;; This is a Scheme form that is applied to the rep-converted value passed
;;; back from the C stub. Its value is the actual return value returned to
;;; Scheme. #f means just pass a single value back as-is. This is mostly
;;; used for string hacking. This field is a Scheme expression.
(define (retrep:c-decl i) (vector-ref i 0))
(define (retrep:immediate i) (vector-ref i 1))
(define (retrep:C-boxcvtr i) (vector-ref i 2))
(define (retrep:make-carrier i) (vector-ref i 3))
(define (retrep:s-cvtr i) (vector-ref i 4))
;;; Works for both argrep-info and retrep-info nodes.
(define (rep:c-decl i) (vector-ref i 0))
;;; The Scheme-pred field in this table is a symbol that is syntactically
;;; closed in the macro expander's environment, so the user won't lose
;;; if he should accidentally bind INTEGER? to something unusual, and
;;; then try a DEFINE-FOREIGN.
(define *simple-argrep-alist* '(
(char #("char ~a" char? "EXTRACT_CHAR" #f))
(bool #("int ~a" #f "EXTRACT_BOOLEAN" #f))
(integer #("int ~a" integer? "EXTRACT_FIXNUM" #f))
(short_u #("unsigned short ~a" integer? "EXTRACT_FIXNUM" #f))
(size_t #("size_t ~a" integer? "EXTRACT_FIXNUM" #f))
(mode_t #("mode_t ~a" integer? "EXTRACT_FIXNUM" #f))
(gid_t #("gid_t ~a" integer? "EXTRACT_FIXNUM" #f))
(uid_t #("uid_t ~a" integer? "EXTRACT_FIXNUM" #f))
(off_t #("off_t ~a" integer? "EXTRACT_FIXNUM" #f))
(pid_t #("pid_t ~a" integer? "EXTRACT_FIXNUM" #f))
(uint_t #("unsigned int ~a" integer? "EXTRACT_FIXNUM" #f))
(long #("long ~a" integer? "EXTRACT_FIXNUM" #f))
(fixnum #("int ~a" fixnum? "EXTRACT_FIXNUM" #f))
(desc #("scheme_value ~a" #f "" #f))
(string-desc #("scheme_value ~a" string? "" #f))
(char-desc #("scheme_value ~a" char? "" #f))
(integer-desc #("scheme_value ~a" integer? "" #f))
(vector-desc #("scheme_value ~a" vector? "" #f))
(pair-desc #("scheme_value ~a" pair? "" #f))
(string #("const char *~a" string? "cig_string_body" #f))
(var-string #("char *~a" string? "cig_string_body" #f))
(string-copy #("char *~a" string? "scheme2c_strcpy" #f))))
;;; Emit C code to copy a C string into its carrier.
(define (str-and-len->carrier carrier str)
(format #f
"{AlienVal(CAR(~a)) = (long) ~a; CDR(~a) = strlen_or_false(~a);}"
carrier str carrier str))
;;; Carrier and assignment-generator for alien values:
(define (simple-assign carrier val)
(format #f "AlienVal(~a) = (long) ~a;" carrier val))
;;; Note: When MAKE-CARRIER and S-CVTR fields are taken from this table,
;;; they are symbols that are syntactically closed in the macro expander's
;;; environment by using the expander's rename procedure. This ensures that
;;; even if the user accidentally binds his own MAKE-ALIEN identifier,
;;; he won't clobber the Scheme stub's use of this MAKE-ALIEN procedure.
(define *simple-retrep-alist* `(
;; All the immediate ones (we are sleazing on ints for now).
(char #("char ~a" "ENTER_CHAR" #f #f #f))
(bool #("int ~a" "ENTER_BOOLEAN" #f #f #f))
(integer #("int ~a" "ENTER_FIXNUM" #f #f #f))
(fixnum #("int ~a" "ENTER_FIXNUM" #f #f #f))
(short_u #("unsigned short ~a" "ENTER_FIXNUM" #f #f #f))
(size_t #("size_t ~a" "ENTER_FIXNUM" #f #f #f))
(mode_t #("mode_t ~a" "ENTER_FIXNUM" #f #f #f))
(gid_t #("gid_t ~a" "ENTER_FIXNUM" #f #f #f))
(uid_t #("uid_t ~a" "ENTER_FIXNUM" #f #f #f))
(off_t #("off_t ~a" "ENTER_FIXNUM" #f #f #f))
(pid_t #("pid_t ~a" "ENTER_FIXNUM" #f #f #f))
(uint_t #("unsigned int ~a" "ENTER_FIXNUM" #f #f #f))
(long #("long ~a" "ENTER_FIXNUM" #f #f #f))
(desc #("scheme_value ~a" "" #f #f #f))
(string-desc #("scheme_value ~a" "" #f #f #f))
(char-desc #("scheme_value ~a" "" #f #f #f))
(integer-desc #("scheme_value ~a" "" #f #f #f))
(vector-desc #("scheme_value ~a" "" #f #f #f))
(pair-desc #("scheme_value ~a" "" #f #f #f))
(string #("const char *~a" #f ,str-and-len->carrier make-string-carrier
string-carrier->string))
(var-string #("char *~a" #f ,str-and-len->carrier make-string-carrier
string-carrier->string))
(string-length #("char *~a" "strlen_or_false" #f #f #f))
(static-string #("char *~a" #f ,str-and-len->carrier make-string-carrier
string-carrier->string-no-free))))
;;; String reps:
;;; -----------
;;; - STRING-COPY
;;; Parameter only. The C routine is given a private, malloc'd C string.
;;; The string is not freed when the routine returns.
;;;
;;; - STRING
;;; Parameter: The C routine is given a C string that it should not alter
;;; or retain beyond the end of the routine. Right now, the Scheme string
;;; is copied to a malloc'd C temporary, which is freed after the routine
;;; returns. Later, we'll just pass a pointer into the actual Scheme
;;; string, as soon as Richard fixes the S48 string reps.
;;; Ret value: The C string is from malloc'd storage. Convert it to a
;;; Scheme string and free the C string.
;;;
;;; - STRING-LENGTH
;;; Return-value only. Return the length of the C string, as a fixnum.
;;;
;;; - STATIC-STRING
;;; Return-value only. The C string is not freed after converting it to
;;; to a Scheme string.
;;;
;;; - VAR-STRING
;;; Same as STRING, but C type is declared char* instead of const char*.
;;; Used to keep some broken system call include files happy.
;;; Parameter reps:
;;; - A simple rep is simply the name of a record in the rep table.
;;; e.g., integer, string
;;; - (REP scheme-pred c-decl to-c [free?])
;;; A detailed spec, as outlined above. SCHEME-PRED is a procedure or #f.
;;; C-DECL is a format string (or a symbol). TO-C is a format string
;;; (or a symbol).
;;; - (C type)
;;; The argument is a C value, passed with no type-checking
;;; or rep-conversion. TYPE is a format string (or a symbol).
;;; A return-value rep is:
;;; - A simple rep, as above.
;;; - (MULTI-REP rep1 ... repn)
;;; The single value returned from the C function is rep-converted
;;; n ways, each resulting in a distinct return value from Scheme.
;;; - (TO-SCHEME rep c->scheme)
;;; Identical to REP, but use the single C->SCHEME form for the return
;;; rep-conversion in the C stub. There is no POST-SCHEME processing. This
;;; allows you to use a special rep-converter on the C side, but otherwise
;;; use all the properties of some standard rep. C->SCHEME is a string (or
;;; symbol).
;;; - (C type)
;;; Returns a raw C type. No rep-conversion. TYPE is a C type, represented
;;; as a string (or a symbol).
;;; C Short-hand:
;;; Things that go in the C code are usually specified as strings,
;;; since C is case-sensitive, and Scheme symbols are not. However,
;;; as a convenient short-hand, symbols may also be used -- they
;;; are mapped to strings by lower-casing their print names. This
;;; applies to the TO-C part of (REP ...) and the C->SCHEME part of
;;; TO-SCHEME.
;;;
;;; Furthermore, C declarations (the TYPE part of (C ...) and the C-DECL part
;;; of (REP ...)) can be either a format string (e.g., "char ~a[]"), or a
;;; symbol (double). A symbol is converted to a string by lower-casing it, and
;;; appending " ~a", so the symbol double is just convenient short-hand for
;;; the C declaration "double ~a".
;;;
;;; Examples: (rep integer? int "EXTRACT_FIXNUM")
;;; (C char*)
;;; (C "int ~a[10]")
;;; (to-scheme integer "HackInt")
;;;
;;; These shorthand forms are not permitted in the actual rep tables;
;;; only in DEFINE-FOREIGN forms.
;;; Note: the RENAME procedure is for use by the Scheme-stub macro expander
;;; when taking SCHEME-PRED fields from the simple-rep internal table. This
;;; way, the user's bindings of variables won't interfere with the functioning
;;; of the simple reps. When Cig's C-stub generator calls this procedure, it
;;; should just pass the identity procedure for the RENAME argument.
(define (parameter-rep->info rep rename)
(let* ((hack (lambda (x)
(if (symbol? x) (string-append (symbol->string x) " ~a")
x)))
(do-rep (lambda (scheme-pred C-decl C-cvtr . maybe-post-C)
(vector (hack C-decl) scheme-pred (stringify C-cvtr)
(and (pair? maybe-post-C) (car maybe-post-C)))))
(you-lose (lambda () (error "Unknown parameter rep" rep))))
(cond ((symbol? rep)
(cond ((assq rep *simple-argrep-alist*) =>
(lambda (entry)
(let* ((info (copy-vector (cadr entry)))
(scheme-pred (argrep:scheme-pred info)))
(vector-set! info 1 (and scheme-pred (rename scheme-pred)))
info)))
(else (you-lose))))
((pair? rep)
(case (car rep)
((rep) (apply do-rep (cdr rep)))
((C) (let* ((c-decl (hack (cadr rep)))
(c-type (format #f c-decl "")))
(do-rep (rename 'alien?) c-decl
(format #f "(~a)AlienVal" c-type)
#f)))
(else (you-lose))))
(else (you-lose)))))
(define (copy-vector v)
(let* ((vlen (vector-length v))
(v-new (make-vector vlen)))
(do ((i (- vlen 1) (- i 1)))
((< i 0) v-new)
(vector-set! v-new i (vector-ref v i)))))
(define (stringify x)
(if (symbol? x)
(list->string (map char-downcase (string->list (symbol->string x))))
x))
;;; Fields are as follows:
;;; c-decl: 0, immediate: 1, C-boxcvtr: 2, make-carrier: 3, s-cvtr: 4
;;; Return a list of reps (because of MULTI-REP).
;;; The RENAME arg is for the Scheme-side macro expander, so that
;;; the make-carrier and s-cvtr fields can be syntactically closed
;;; in the expander's environment. The C-stub generator should just
;;; pass an identity procedure for RENAME.
(define (return-rep->info rep rename)
(let* ((hack (lambda (x)
(if (symbol? x)
(string-append (symbol->string x) " ~a")
x)))
(do-rep (lambda (c-decl . to-scheme)
(list (vector (hack c-decl) (list to-scheme) '() #f))))
(you-lose (lambda () (error "Unknown return rep" rep)))
(infos (cond ((symbol? rep)
(cond ((assq rep *simple-retrep-alist*) =>
(lambda (entry)
;; Apply RENAME to make-carrier and s-cvtr.
(let* ((info (copy-vector (cadr entry)))
(make-carrier (retrep:make-carrier info))
(s-cvtr (retrep:s-cvtr info)))
(vector-set! info 3
(and make-carrier
(rename make-carrier)))
(vector-set! info 4
(and s-cvtr (rename s-cvtr)))
(list info))))
(else (you-lose))))
((pair? rep)
(case (car rep)
((rep)
(let ((v (apply vector rep)))
(vector-set! v 0 (hack (vector-ref v 0)))
(list v)))
((to-scheme) ; (to-scheme rep converter)
(let* ((v (car (return-rep->info (cadr rep) rename)))
(v (copy-vector v)))
(vector-set! v 1 (stringify (caddr rep)))
(vector-set! v 2 '#f)
(vector-set! v 3 '#f)
(vector-set! v 4 '#f)
(list v)))
((C) (list (vector (hack (cadr rep)) #f
simple-assign (rename 'make-alien)
#f)))
((multi-rep)
(apply append (map (lambda (rep)
(return-rep->info rep rename))
(cdr rep))))
(else (you-lose))))
(else (you-lose)))))
infos))
;;; Return a type string for IGNORE, or a list of lists of info vectors for
;;; the standard case.
(define (parse-return-reps reps rename)
(cond ((or (not (pair? reps))
(not (list? reps)))
(error "Bad return rep list" reps))
;; (IGNORE c-type) or IGNORE
((and (null? (cdr reps))
(let ((rep (car reps)))
(or (eq? rep 'ignore)
(and (pair? rep)
(eq? (car rep) 'ignore)))))
(let ((rep (car reps)))
(if (pair? rep) (cadr rep) "void ~a")))
(else (map (lambda (rep) (return-rep->info rep rename)) reps))))
(define (insert-commas lis)
(if (pair? lis)
(cdr (let rec ((lis lis))
(if (pair? lis)
(cons ", " (cons (car lis) (rec (cdr lis))))
'())))
'("")))
(define (elts->comma-string lis)
(apply string-append (insert-commas lis)))
(define (info->type i . maybe-outer-type)
(let ((outer-type (if (null? maybe-outer-type) "" (car maybe-outer-type))))
(format #f (rep:c-decl i) outer-type)))
(define (info->var-decl i var)
(format #f "~% ~a;" ; statement-ize decl.
(format #f (rep:c-decl i) var))) ; decl-ize var.
(define (make-gensym prefix i)
(lambda (x)
(set! i (+ i 1))
(string-append prefix (number->string i))))
;;; This returns a list mapping each of the Scheme stub's args to
;;; it's corresponding name in the C stub (e.g., ("arg[2]" "arg[1]" "arg[0]")).
;;; If MV-RETURN? is true, we reserve arg[0] for the mv-return Scheme vec.
(define (make-stub-args nargs mv-return?)
(do ((i (if mv-return? 1 0) (+ i 1))
(nargs nargs (- nargs 1))
(ans '() (cons (format #f "args[~d]" i) ans)))
((zero? nargs) ans)))
(define (filter lis)
(if (pair? lis)
(let* ((head (car lis))
(tail (cdr lis))
(new-tail (filter tail)))
(if head (if (eq? tail new-tail) lis (cons head new-tail))
new-tail))
'()))
(define nl (string #\newline))
(define (separate-line stmt) (string-append " " stmt ";" nl))
;;; Apply a Scheme->C rep-converter to the C expression EXP.
(define (C-ize info exp)
(cond ((argrep:c-cvtr info)
=> (lambda (s)
(if (string=? s "") exp
(string-append s "(" exp ")"))))
(else exp)))
;;; Return a C statement rep-converting the C value VAL into the
;;; carrier CARRIER. Rep-conversion is determined by INFO.
(define (Scheme-ize->carrier info carrier val)
(cond ((retrep:C-boxcvtr info)
=> (lambda (f) (f carrier val)))
(else (error "Rep is not carrier rep:" info))))
;;; Apply a C->Scheme rep-converter in the C stub to C expression EXP.
(define (Scheme-ize-exp converter exp)
(if (string=? converter "") exp
(string-append converter "(" exp ")")))
;;; If an arg needs post-C processing in the C stub,
;;; then we need to assign the arg's C rep to a variable.
;;; Return #f or " char *f3 = scm2c_string(arg[2]);"
(define (free-var-decl info fvar stub-arg)
(and (argrep:post-C info)
(format #f "~% ~a = ~a;"
(format #f (argrep:c-decl info) fvar)
(C-ize info stub-arg))))
;;; Multiple return values happen across three boundaries: C routine -> C stub,
;;; C stub -> Scheme stub, and Scheme stub -> user. M.v. return happens
;;; across these boundaries sometimes for different reasons. If the
;;; C routine returns m.v., then everyone does. But even if the C routine
;;; returns just a single value, the C stub may rep-convert that multiple
;;; ways, and so need to pass multiple values back to the Scheme stub.
;;; Nomenclature: if someone is returning 4 return values, let's call
;;; the first value returned the *major return value*, and the other three
;;; values the *minor return values*.
;;; M.V. return linkages work like this:
;;; The C routine returns m.v.'s to the C stub by (1) returning the major value
;;; as the value of the C routine, and (2) assigning the minor return values
;;; to pointers passed to the C routine from the stub -- these pointer values
;;; are appended to the routine's parameter list after the actual arguments.
;;; That is, if the C routine needs to return an int, it will be passed
;;; an int*, which it assigns to return the int value.
;;; If the Scheme stub is expecting N multiple values, it passes in
;;; a Scheme vector of size N-1 to the C stub. The C stub stashes the
;;; minor return values into this vector; the major value is passed back
;;; as the C stub's actual return value. This vector is always the last
;;; value passed to the C stub from the Scheme stub, so we can get it
;;; in the C stub by accessing arg[0] or just *arg (remember, the args
;;; get their order reversed during the Scheme/C transition when they
;;; are pushed on the Scheme48 stack, so the m.v. vector, being last, comes
;;; out first).
;;;
;;; If the major return value for the call requires a carrier structure,
;;; it is passed in the m.v. Scheme vector, in the first element of the
;;; vector. The carrier itself is returned as the C stub's major return value.
;;; MAKE-MV-ASSIGNS produces the C code that puts the C stub's minor
;;; return values into the vector. For each value and each rep for that value:
;;; - If the value is the major return value:
;;; + if the value is immediate, it is rep-converted, and assigned to
;;; the variable ret1.
;;; + if the value is passed back in a carrier, the carrier is fetched
;;; from the m.v. vector's elt 0, and the value is rep-converted into
;;; this carrier. The carrier itself is assigned to ret1.
;;; - If the value is a minor return value:
;;; + if the value is immediate, it is rep-converts, and assigned to
;;; the appropriate slot in the m.v. vector.
;;; + if the value is passed back in a carrier, the carrier is fetched
;;; from the m.v. vector, and the value is rep-converted into the carrier.
;;; Ugh. Nested looping in Scheme is like nested looping in assembler.
(define (make-mv-assigns c-vars info-lists)
(apply string-append
(let lp1 ((j 0) ; J is location in Scheme vec into which we store.
(c-vars c-vars)
(info-lists info-lists)
(assigns '()))
(if (pair? c-vars)
(let ((v (car c-vars))
(info-list (car info-lists))
(c-vars (cdr c-vars))
(info-lists (cdr info-lists)))
;; Loop over V's info elts in INFO-LIST
(let lp2 ((j j)
(info-list info-list)
(assigns assigns))
(if (pair? info-list)
;; Do rep-conversion INFO.
(let ((info (car info-list))
(info-list (cdr info-list)))
(receive (c-stmt j)
(if (null? assigns)
(make-major-retval-stmt v info)
(make-minor-retval-stmt v info j))
(lp2 j info-list (cons c-stmt assigns))))
(lp1 j c-vars info-lists assigns))))
(reverse assigns)))))
;;; c-decl: 0, immediate: 1, C-boxcvtr: 2, make-carrier: 3, s-cvtr: 4
;;; Major ret value rep conversion. If immediate, just rep-convert & assign
;;; to ret1. If carrier, store into an alien struct and assign that to ret1.
;;; C-VAR should always be "r1".
(define (make-major-retval-stmt c-var info)
(cond ((retrep:immediate info) =>
(lambda (cvtr)
(values (format #f "~% ret1 = ~a;" (Scheme-ize-exp cvtr c-var))
0)))
(else
(values (format #f "~% ret1 = VECTOR_REF(*args,0);~% ~a"
(Scheme-ize->carrier info "ret1" c-var))
1))))
;;; Minor ret value rep-conversion.
;;; Convert and store into minor-value vector at entry j.
(define (make-minor-retval-stmt c-var info j)
(let ((target (format #f "VECTOR_REF(*args,~d)" j)))
(values (cond ((retrep:immediate info) =>
(lambda (cvtr)
(format #f "~% ~a = ~a;"
target (Scheme-ize-exp cvtr c-var))))
(else
(format #f "~% ~a"
(Scheme-ize->carrier info target c-var))))
(+ j 1))))
(define (stmts strings) (apply string-append strings))
(define (make-post-C-var-list infos)
(do ((j 1 (+ j 1))
(infos infos (cdr infos))
(ans '()
(cons (let ((i (car infos)))
(and (argrep:post-C i) (format #f "f~d" j)))
ans)))
((not (pair? infos)) (reverse ans))))
;;; Compute the args part of function prototype.
(define (proto-args arg-decls)
(if (null? arg-decls) "void" ; echh
(elts->comma-string arg-decls)))
(define (define-foreign->C-stub form)
(destructure (( (#f scheme-name (c-name . params) . return-reps) form ))
(let* ((c-name (stringify c-name))
(reps (map car params))
(no-declare? (and (pair? return-reps)
(eq? 'no-declare (car return-reps))))
(return-reps (if no-declare? (cdr return-reps)
return-reps))
(params-info (map (lambda (rep)
(parameter-rep->info rep (lambda (x) x)))
reps))
;; A list of lists, due to MULTI-REP.
(ret-infos1 (parse-return-reps return-reps
(lambda (x) x)))
(ignore? (string? ret-infos1))
(ret-infos2 (if (not ignore?) ; Flatten them out.
(apply append ret-infos1)))
(ret-infos3 (if (not ignore?) ; A canonical representative
(map car ret-infos1))) ; per item.
(primary-retval-info (if (not ignore?) (car ret-infos3)))
(primary-retval-decl-template
(if ignore?
ret-infos1
(retrep:c-decl primary-retval-info)))
;; The type of the value returned by the C routine,
;; stored into the C stub's r1 variable.
(primary-retvar-decl (if ignore? ""
(format #f "~% ~a;"
(format #f primary-retval-decl-template
"r1"))))
(mv-return? (and (not ignore?)
(or (pair? (cdr ret-infos2))
;; Is major ret val non-immediate
(not (retrep:immediate
(caar ret-infos1))))))
(nargs (length reps))
(stub-nargs (if mv-return? (+ nargs 1) nargs))
(other-retvals (if ignore? '() (cdr ret-infos3)))
(ret-vars (map (make-gensym "r" 1) other-retvals))
(ret-var-decls (stmts (map info->var-decl
other-retvals ret-vars)))
;; List of the form ("arg[2]" "arg[1]" "arg[0]").
(stub-args (make-stub-args nargs mv-return?))
(post-C-vars (make-post-C-var-list params-info))
(pc-var-decls (stmts (map (lambda (i v)
(if v (info->var-decl i v) ""))
params-info
post-C-vars)))
(c-proto (proto-args (append (map info->type params-info)
(map (lambda (i)
(info->type i "*"))
other-retvals))))
(c-fun-decl (format #f primary-retval-decl-template
(string-append c-name "(" c-proto ")")))
(c-fun-decl (format #f "extern ~a;" c-fun-decl))
(c-fun-decl (if no-declare? "" c-fun-decl))
(pc-var-assigns (stmts (map (lambda (i fv sv)
(if fv
(format #f "~% ~a = ~a;"
fv (C-ize i sv))
""))
params-info
post-C-vars
stub-args)))
(c-args (elts->comma-string (append (map (lambda (i fv sv)
(or fv (C-ize i sv)))
params-info
post-C-vars
stub-args)
(map (lambda (rv)
(string-append "&" rv))
ret-vars))))
(c-call (string-append c-name "(" c-args ")"))
;; Do the post-C-call processing in the C stub.
(post-C-val-processing
(stmts (map (lambda (v i)
(if v
(format #f "~% %a(~a);"
(argrep:post-C i) v)
""))
post-C-vars reps)))
(mv-assigns (if ignore? ""
(make-mv-assigns (cons "r1" ret-vars)
ret-infos1)))
(return-stmt (format #f "~% return ~a;"
(if ignore? "SCHFALSE" "ret1")))
;; Do the call, release the free-vars, do the mv-return
;; assignments, then return.
(epilog (if ignore?
(string-append c-call ";" post-C-val-processing return-stmt)
(string-append "r1 = " c-call ";"
post-C-val-processing
mv-assigns return-stmt))))
; (breakpoint)
(format #f cfun-boilerplate
c-name
c-fun-decl
(if ignore? "" ret1-decl)
primary-retvar-decl ret-var-decls pc-var-decls
stub-nargs c-name
pc-var-assigns
epilog))))
(define cfun-boilerplate
"scheme_value df_~a(long nargs, scheme_value *args)
{
~a~a~a~a~a
cig_check_nargs(~d, nargs, \"~a\");~a
~a
}
")
(define ret1-decl
"
scheme_value ret1;")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define cfile-header-boilerplate
"/* This is an Scheme48/C interface file,
** automatically generated by cig.
*/
#include <stdio.h>
#include <stdlib.h> /* For malloc. */
#include \"libcig.h\"
")
(define (define-foreign-process-form form oport)
(if (pair? form)
(case (car form)
((begin)
(if (list? (cdr form))
(for-each (lambda (f) (define-foreign-process-form f oport))
(cdr form))))
((define-structure define-structures)
(if (and (pair? (cdr form))
(list? (cddr form)))
(let ((clauses (cddr form)))
(for-each (lambda (clause)
(if (and (pair? clause)
(eq? 'begin (car clause)))
(define-foreign-process-form clause oport)))
clauses))))
((define-foreign)
(display (define-foreign->C-stub form) oport))
((foreign-source)
(let ((forms (cdr form)))
(if (pair? forms)
(begin (display (car forms) oport)
(map (lambda (x)
(newline oport)
(display x oport))
(cdr forms)))))))))
(define (process-define-foreign-stream iport oport)
(display cfile-header-boilerplate oport)
(let lp ()
(let ((form (read iport)))
(cond ((not (eof-object? form))
(define-foreign-process-form form oport)
(lp))))))
(define (process-define-foreign-file fname)
(call-with-input-file (string-append fname ".scm")
(lambda (iport)
(call-with-output-file (string-append fname ".c")
(lambda (oport)
(process-define-foreign-stream iport oport))))))
(define (cig-standalone-toplevel . args) ; ignore your args.
(process-define-foreign-stream (current-input-port)
(current-output-port))
0)
;;; This section defines the Scheme-side macro processor.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (define-syntax define-foreign define-foreign-expander)
(define (define-foreign-expander form rename compare)
(destructure (( (#f scheme-name (c-name . params) . return-reps) form ))
(let* ((c-name (string-append "df_" (stringify c-name)))
(reps (map car params))
(params-info (map (lambda (rep) (parameter-rep->info rep rename))
reps))
(return-reps (if (and (pair? return-reps)
(eq? 'no-declare (car return-reps)))
(cdr return-reps)
return-reps))
(ret-infos1 (parse-return-reps return-reps rename))
(ignore? (string? ret-infos1))
(ret-infos2 (if (not ignore?)
(apply append ret-infos1)))
(major-rep (and (not ignore?) (car ret-infos2)))
;; Does the Scheme stub return m.v.'s to the user?
(scheme-mv-return? (and (not ignore?)
(pair? (cdr ret-infos2))))
(carrier-vec? (or scheme-mv-return?
(and major-rep
(not (retrep:immediate major-rep)))))
(carrier-veclen (if carrier-vec?
(- (length ret-infos2)
(if (retrep:immediate major-rep) 1 0))))
(%define (rename 'define))
(%let (rename 'let))
(%lambda (rename 'lambda))
(%external-call (rename 'external-call))
(%get-external (rename 'get-external))
(gensym (let ((gs (make-gensym "g" -1)))
(lambda () (string->symbol (gs #f)))))
(args (map (lambda (p)
(let ((tail (cdr p)))
(if (pair? tail) (car tail)
(gensym))))
params))
(%string? (rename 'string?))
(%char? (rename 'char?))
(%integer? (rename 'integer?))
(%vector? (rename 'vector?))
(%pair? (rename 'pair?))
(%check-arg (rename 'check-arg))
(rep-checker (lambda (i arg)
(cond ((argrep:scheme-pred i) =>
(lambda (pred) `(,%check-arg ,pred ,arg
,scheme-name)))
(else arg))))
(c-args (map rep-checker params-info args))
(%f (rename 'f)))
(if (not carrier-vec?)
(let* ((xcall `(,%external-call ,%f ,@c-args))
(xcall (cond ((and (not ignore?)
(retrep:s-cvtr (car ret-infos2)))
=> (lambda (proc) `(,proc ,xcall))) ; not hygenic
(else xcall))))
`(,%define ,scheme-name
(,%let ((,%f (,%get-external ,c-name)))
(,%lambda ,args ,xcall))))
(let ((retarg1 (rename 'r1))
(retarg2 (rename 'r2))
(%make-vector (rename 'make-vector)))
`(,%define ,scheme-name
(,%let ((,%f (,%get-external ,c-name)))
(,%lambda ,args
(,%let ((,retarg2 (,%make-vector ,carrier-veclen)))
,@(install-carriers retarg2 ret-infos2
(rename 'vector-set!))
(,%let ((,retarg1 (,%external-call ,%f ,@c-args ,retarg2)))
(values ,@(make-values-args retarg1 retarg2
ret-infos2
rename))))))))))))
(define (install-carriers carrier-vec ret-infos2 %vector-set!)
;; Skip the major ret value if it doesn't require a carrier.
(let* ((major-rep (and (pair? ret-infos2) (car ret-infos2)))
(infos (if (and major-rep (retrep:immediate major-rep))
(cdr ret-infos2)
ret-infos2)))
(let lp ((ans '()) (infos infos) (i 0))
(if (null? infos) ans
(let ((info (car infos))
(infos (cdr infos)))
(if (retrep:immediate info)
(lp ans infos (+ i 1))
(lp (cons `(,%vector-set! ,carrier-vec ,i
(,(retrep:make-carrier info)))
ans)
infos
(+ i 1))))))))
(define (c-arg i retarg1 retarg2 %vector-ref)
(if (zero? i)
retarg1
`(,%vector-ref ,retarg2 ,(- i 1))))
(define (make-values-args arg1 carrier-vec infos rename)
(let ((%vector-ref (rename 'vector-ref))
(do-arg (lambda (arg info)
(cond ((retrep:s-cvtr info) =>
(lambda (cvtr) `(,cvtr ,arg)))
(else arg)))))
(if (null? infos) '()
(let lp ((ans (list (do-arg arg1 (car infos))))
(i (if (retrep:immediate (car infos)) 0 1))
(infos (cdr infos)))
(if (pair? infos)
(let* ((info (car infos))
(arg `(,%vector-ref ,carrier-vec ,i)))
(lp (cons (do-arg arg info) ans)
(+ i 1)
(cdr infos)))
(reverse ans))))))
)) ; egakcap
(define-structure define-foreign-syntax (export (define-foreign :syntax)
(foreign-source :syntax))
(open scheme externals structure-refs cig-aux)
(access signals) ; for ERROR
(for-syntax (open scheme define-foreign-syntax-support))
(begin
(define error (structure-ref signals error))
(define-syntax define-foreign define-foreign-expander)
;; Ignore FOREIGN-SOURCE forms.
(define-syntax foreign-source
(syntax-rules ()
((foreign-source stuff ...) #f)))
(define (check-arg pred obj proc)
(if (not (pred obj))
(error "check-arg" pred obj proc)
obj))
)) ; egakcap
;;; Todo: "info" terminology is gone. Clean up.

45
cig/doc/boxedminipage.sty
View File

@ -1,45 +0,0 @@
% boxedminipage.sty
%
% adds the boxedminipage environment---just like minipage, but has a
% box round it!
%
% The thickneess of the rules around the box is controlled by
% \fboxrule, and the distance between the rules and the edges of the
% inner box is governed by \fboxsep.
%
% This code is based on Lamport's minipage code.
\def\boxedminipage{\@ifnextchar [{\@iboxedminipage}{\@iboxedminipage[c]}}
\def\@iboxedminipage[#1]#2{\leavevmode \@pboxswfalse
\if #1b\vbox
\else \if #1t\vtop
\else \ifmmode \vcenter
\else \@pboxswtrue $\vcenter
\fi
\fi
\fi\bgroup % start of outermost vbox/vtop/vcenter
\hsize #2
\hrule\@height\fboxrule
\hbox\bgroup % inner hbox
\vrule\@width\fboxrule \hskip\fboxsep \vbox\bgroup % innermost vbox
\advance\hsize -2\fboxrule \advance\hsize-2\fboxsep
\textwidth\hsize \columnwidth\hsize
\@parboxrestore
\def\@mpfn{mpfootnote}\def\thempfn{\thempfootnote}\c@mpfootnote\z@
\let\@footnotetext\@mpfootnotetext
\let\@listdepth\@mplistdepth \@mplistdepth\z@
\@minipagerestore\@minipagetrue
\everypar{\global\@minipagefalse\everypar{}}}
\def\endboxedminipage{%
\par\vskip-\lastskip
\ifvoid\@mpfootins\else
\vskip\skip\@mpfootins\footnoterule\unvbox\@mpfootins\fi
\egroup % ends the innermost \vbox
\hskip\fboxsep \vrule\@width\fboxrule
\egroup % ends the \hbox
\hrule\@height\fboxrule
\egroup% ends the vbox/vtop/vcenter
\if@pboxsw $\fi}

76
cig/doc/draftfooters.sty
View File

@ -1,76 +0,0 @@
% Document style option "draftfooter"
% -- usage: \documentstyle[...,draftfooter,...]{...}
% -- puts "DRAFT" with date and time in page footer
%
% Olin Shivers 1/17/94
% - Hacked from code I used in my dissertation and from code in a
% drafthead.sty package written by Stephen Page sdpage@uk.ac.oxford.prg.
%----------------------------------------------------------------------------
%
% compute the time in hours and minutes; make new variables \timehh and \timemm
%
\newcount\timehh\newcount\timemm
\timehh=\time
\divide\timehh by 60 \timemm=\time
\count255=\timehh\multiply\count255 by -60 \advance\timemm by \count255
%
\def\draftbox{{\protect\small\bf \fbox{DRAFT}}}
\def\drafttime{%
{\protect\small\sl\today\ -- \ifnum\timehh<10 0\fi%
\number\timehh\,:\,\ifnum\timemm<10 0\fi\number\timemm}}
\def\drafttimer{\protect\makebox[0pt][r]{\drafttime}}
\def\drafttimel{\protect\makebox[0pt][l]{\drafttime}}
\def\thepagel{\protect\makebox[0pt][l]{\rm\thepage}}
\def\thepager{\protect\makebox[0pt][r]{\rm\thepage}}
% Header is empty.
% Footer is "date DRAFT pageno"
\def\ps@plain{
\let\@mkboth\@gobbletwo
\let\@oddhead\@empty \let\@evenhead\@empty
\def\@oddfoot{\reset@font\rm\drafttimel\hfil\draftbox\hfil\thepager}
\if@twoside
\def\@evenfoot{\reset@font\rm\thepagel\hfil\draftbox\hfil\drafttimer}
\else \let\@evenfoot\@oddfoot
\fi
}
% Aux macro -- sets footer to be "date DRAFT".
\def\@draftfooters{
\def\@oddfoot{\reset@font\rm\drafttimel\hfil\draftbox}
\if@twoside
\def\@evenfoot{\reset@font\rm\draftbox\hfil\drafttimer}
\else \let\@evenfoot\@oddfoot
\fi
}
% Header is empty.
% Footer is "date DRAFT".
\def\ps@empty{
\let\@mkboth\@gobbletwo
\let\@oddhead\@empty \let\@evenhead\@empty
\@draftfooters
}
% Header is defined by the document style (article, book, etc.).
% Footer is "date DRAFT".
\let\@draftoldhead\ps@headings
\def\ps@headings{
\@draftoldhead % Do the default \pagestyle{headings} stuff.
\@draftfooters % Then define the draft footers:
}
% Header is defined by the document style (article, book, etc.),
% and filled in by user's \markboth and \markright commands.
% Footer is "date DRAFT".
\let\@draftoldmyhead\ps@myheadings
\def\ps@myheadings{
\@draftoldmyhead % Do the default \pagestyle{myheadings} stuff.
\@draftfooters % Then define the draft footers:
}
\ps@plain

16
cig/doc/headings.tex
View File

@ -1,16 +0,0 @@
% headings.tex -*- latex -*-
% Quieter headings that the ones used in article.sty.
% This is not a style option. Don't say [headings].
% Instead, say \input{headings} after the \documentstyle.
% -Olin 7/91
\makeatletter
\def\section{\@startsection {section}{1}{\z@}{-3.5ex plus -1ex minus
-.2ex}{2.3ex plus .2ex}{\large\bf}}
\def\subsection{\@startsection{subsection}{2}{\z@}{-3.25ex plus -1ex minus
-.2ex}{1.5ex plus .2ex}{\normalsize\bf}}
\def\subsubsection{\@startsection{subsubsection}{3}{\z@}{-3.25ex plus
-1ex minus -.2ex}{1.5ex plus .2ex}{\normalsize\bf}}
\makeatother

160
comp-packages.scm
View File

@ -1,160 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Package definitions for byte-code compiler and initial image.
; Two basic structures needed to support the compiler.
(define-structure tables general-tables-interface
(open scheme-level-1
bummed-define-record-types
signals
features) ; string-hash, make-immutable!
(files (big general-table))
(optimize auto-integrate))
(define-structure filenames filenames-interface
(open scheme-level-1 signals)
(files (big filename)))
; Type system
(define-structure meta-types meta-types-interface
(open scheme-level-2
bummed-define-record-types tables bitwise
features ;make-immutable!
util signals)
(files (bcomp mtype))
(optimize auto-integrate))
(define-structure interfaces interfaces-interface
(open scheme-level-2 syntactic meta-types
signals bummed-define-record-types tables
weak)
(files (bcomp interface))
(optimize auto-integrate))
; Transforms and operators
(define-structure syntactic
(compound-interface syntactic-interface
nodes-interface)
(open scheme-level-2 meta-types
signals bummed-define-record-types tables fluids
features ;make-immutable!
;; locations ;location?
)
(files (bcomp syntax)
(bcomp schemify))
(optimize auto-integrate))
(define-structure usual-macros usual-macros-interface
(open scheme-level-2
syntactic ;name?, $source-file-name
fluids ;used in definition of %file-name%
tables signals)
(files (bcomp usual)
(bcomp rules)))
(define-structure reconstruction (export node-type reconstruct-type)
(open scheme-level-2
syntactic meta-types
util ; last
signals)
(files (bcomp recon)))
; Package system
(define-structures ((packages packages-interface)
(packages-internal packages-internal-interface))
(open scheme-level-2 syntactic meta-types interfaces
signals bummed-define-record-types tables fluids
util features locations weak)
(files (bcomp package))
(optimize auto-integrate))
(define-structure scan scan-interface
(open scheme-level-2
packages syntactic
usual-macros ; for dealing with (usual-transforms ...)
meta-types
packages-internal
signals fluids tables util
features ;force-output
filenames) ;translate
(files (bcomp scan)
(bcomp undefined))
(optimize auto-integrate))
; Compiler back end
(define-structures ((segments segments-interface)
(debug-data debug-data-interface))
(open scheme-level-2 code-vectors templates
syntactic
architecture
bummed-define-record-types
features ;make-immutable!
records util tables fluids signals)
(files (bcomp segment)
(bcomp state)
(bcomp ddata))
(optimize auto-integrate))
; Byte-code compiler
(define-structure compiler compiler-interface
(open scheme-level-2 syntactic scan meta-types
architecture
packages
packages-internal ;only for structure-package ?
interfaces ;interface-ref
locations ;make-undefined-location
reconstruction
segments
signals
tables
enumerated ;enumerand->name
util ;reduce
fluids
features) ;force-output
(files (bcomp comp)
(bcomp cprim)
(bcomp ctop))
(optimize auto-integrate))
; DEFINE-STRUCTURE and friends
(define-structure defpackage defpackage-interface
(open scheme-level-2
packages syntactic usual-macros types
interfaces
source-file-names ;%file-name%
signals ;error
tables)
(for-syntax (open scheme-level-2 signals)) ;syntax-error
(files (bcomp module-language)
(bcomp config)))
(define-structure types types-interface ;Typing language
(open scheme-level-2 meta-types syntactic loopholes)
(files (bcomp type))
;; (optimize auto-integrate) - doesn't work
)
(define-structure module-system (compound-interface defpackage-interface
types-interface)
(open defpackage types))
; Static linker
(define-structure inline inline-interface
(open scheme-level-2
syntactic
packages
signals)
(files (opt inline)))

134
debug-packages.scm
View File

@ -1,134 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Handy things for debugging the run-time system, byte code compiler,
; and linker.
; Alternative command processor. Handy for debugging the bigger one.
(define (make-mini-command scheme)
(define-structure mini-command (export command-processor)
(open scheme
signals conditions handle
display-conditions)
(files (debug mini-command)))
mini-command)
; Miniature EVAL, for debugging runtime system sans package system.
(define-structures ((mini-eval evaluation-interface)
(mini-environments
(export interaction-environment
scheme-report-environment
set-interaction-environment!
set-scheme-report-environment!)))
(open scheme-level-2
signals) ;error
(files (debug mini-eval)))
(define (make-scheme environments evaluation) ;cf. initial-packages.scm
(define-structure scheme scheme-interface
(open scheme-level-2
environments
evaluation))
scheme)
; Stand-alone system that doesn't contain a byte-code compiler.
; This is useful for various testing purposes.
(define mini-scheme (make-scheme mini-environments mini-eval))
(define mini-command (make-mini-command mini-scheme))
(define-structure little-system (export start)
(open scheme-level-1
mini-command
scheme-level-2-internal)
(begin (define start
(usual-resumer
(lambda (args) (command-processor #f args))))))
(define (link-little-system)
(link-simple-system '(debug little)
'start
little-system))
; --------------------
; Hack: smallest possible reified system.
(define-structures ((mini-for-reification for-reification-interface)
(mini-packages (export make-simple-package)))
(open scheme-level-2
;; tables
features ;contents
locations
signals) ;error
(files (debug mini-package)))
(define-structure mini-system (export start)
(open mini-scheme
mini-command
mini-for-reification
mini-packages
mini-environments ;set-interaction-environment!
scheme-level-2-internal ;usual-resumer
conditions handle ;error? with-handler
signals) ;error
(files (debug mini-start)))
(define (link-mini-system)
(link-reified-system (list (cons 'scheme mini-scheme)
(cons 'write-images write-images)
(cons 'primitives primitives) ;just for fun
(cons 'scheme-level-2-internal
scheme-level-2-internal)
(cons 'command mini-command))
'(debug mini)
'start
mini-system mini-for-reification))
; --------------------
; S-expression interpreter
(define-structure run evaluation-interface
(open scheme-level-2 syntactic packages scan meta-types
environments
signals
locations
features ;force-output
tables
fluids)
(files (debug run)))
; Hack: an interpreter-based system.
(define (link-medium-system) ;cf. initial.scm
(def medium-scheme (make-scheme environments run))
(let ()
(def command (make-mini-command medium-scheme))
(let ()
(def medium-system
;; Cf. initial-packages.scm
(make-initial-system medium-scheme command))
(let ((structs (list (cons 'scheme medium-scheme)
(cons 'primitives primitives) ;just for fun
(cons 'scheme-level-2-internal
scheme-level-2-internal)
(cons 'command command))))
(link-reified-system structs
'(debug medium)
`(start ',(map car structs))
medium-system for-reification)))))

76
debug/byte-code-test.scm
View File

@ -1,76 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Test various of the byte-codes
;(let ((system (make-system '("~/s48/x48/boot/byte-code-test.scm") 'resume #f)))
; (write-system system "~/s48/x48/boot/byte-code-test.image"))
(define *tests* '())
(define *output-port* #f)
(define (make-test . args)
(set! *tests* (cons args *tests*)))
(define (run-test string compare result proc)
(write-string string *output-port*)
(write-string "..." *output-port*)
(force-output *output-port*)
(write-string (if (compare (proc) result) "OK" "failed") *output-port*)
(write-char #\newline *output-port*))
(make-test "testing test mechanism" (lambda (x y) (eq? x y)) 0 (lambda () 0))
(make-test "primitive catch and throw" (lambda (x y) (eq? x y)) 10
(lambda ()
(* 10 (primitive-catch (lambda (k)
(my-primitive-throw k 1)
(message "after throw???")
2)))))
(define (my-primitive-throw cont value)
(with-continuation cont (lambda () value)))
(define (message string)
(write-string string *output-port*)
(write-char #\newline *output-port*))
(define (resume arg in out)
(set! *output-port* out)
(do ((tests (do ((tests *tests* (cdr tests))
(r '() (cons (car tests) r)))
((eq? '() tests) r))
(cdr tests)))
((eq? '() tests))
(apply run-test (car tests)))
(write-string "done" *output-port*)
(write-char #\newline *output-port*)
(halt 0))
(define *initial-bindings* '())
(define (initial-env name)
(let ((probe (assq name *initial-bindings*)))
(if probe (cdr probe) (error "unbound" name))))
(define (define-initial name val)
(let* ((probe (assq name *initial-bindings*))
(loc (if probe
(cdr probe)
(let ((loc (make-undefined-location name)))
(set! *initial-bindings*
(cons (cons name loc) *initial-bindings*))
loc))))
;; (set-location-defined?! loc #t) - obsolescent?
(set-contents! loc val)))
(for-each (lambda (name val)
(define-initial name val))
'( cons car cdr + - * < = > list map append reverse)
(list cons car cdr + - * < = > list map append reverse))
(make-test "little env-lookup test" eq? car
(lambda ()
(contents (initial-env 'car))))
(define (error string . stuff) (message string))

104
debug/check.scm
View File

@ -1,104 +0,0 @@
; The barest skeleton of a test suite.
; Mostly it makes sure that many of the external packages load without
; error.
; ,exec ,load debug/check.scm
; (done)
(load-package 'testing)
(config '(run
(define-structure bar (export)
(open scheme testing))))
(in 'bar '(bench off))
(in 'bar '(run (define (foo) (cadr '(a b)))))
(in 'bar '(run (define cadr list)))
(in 'bar '(run (test "non-bench" equal? '((a b)) (foo))))
(in 'bar '(bench on))
(in 'bar '(run (define (foo) (car '(a b)))))
(in 'bar '(run (define car list)))
(in 'bar '(run (test "bench" equal? 'a (foo))))
(config '(run
(define-structure foo (export)
(open scheme testing
assembler
queues
random
sort
big-scheme
arrays
dump/restore
search-trees
threads
sicp)
(begin
(test "* 1" = 6 (* 1 2 3))
(test "* 2" = (* 214760876 10) 2147608760)
(test "* 3" = (* 47123 46039) 2169495797)
(test "apply" equal? '(1 2 3 4) (apply list 1 2 '(3 4)))
(test "char<->integer" eq? #\a (integer->char (char->integer #\a)))
(test "lap" equal? #f ((lap #f (false) (return))))
(let ((q (make-queue)))
(enqueue q 'a)
(test "q" eq? 'a (dequeue q)))
(test "random" <= 0 ((make-random 7)))
(test "sort" equal? '(1 2 3 3) (sort-list '(2 3 1 3) <))
(test "bigbit" = (expt 2 100) (arithmetic-shift 1 100))
(test "format" string=? "x(1 2)" (format #f "x~s" '(1 2)))
(test "destructure" eq? 'a (destructure (((x (y) z) '(b (a) c))) y))
(test "array" eq? 'a
(let ((a (make-array 'b 3 4)))
(array-set! a 'a 1 2)
(array-ref a 1 2)))
(test "receive" eq? 'a (receive (x y) (values 'b 'a) y))
(let ((z '(a "b" 3 #t)))
(test "dump" equal? z
(let ((q (make-queue)))
(dump z (lambda (c) (enqueue q c)) -1)
(restore (lambda () (dequeue q))))))
(with-multitasking
(lambda ()
(let* ((cv (make-condvar))
(th (spawn (lambda ()
(relinquish-timeslice)
(condvar-set! cv 'foo))
'test)))
(test "threads" eq? 'foo (condvar-ref cv)))))
(test "explode" equal? 'ab3 (implode (explode 'ab3)))
(test "get/put" equal? 'a (begin (put 'foo 'prop 'a)
(get 'foo 'prop)))
(test "search-trees" eq? 'a
(let ((t (make-search-tree = <)))
(search-tree-set! t 3 'b)
(search-tree-set! t 4 'a)
(search-tree-set! t 5 'c)
(search-tree-ref t 4)))
))))
(load-package 'foo)
(load-package 'floatnums)
(in 'foo '(run (let* ((one (exact->inexact 1))
(three (exact->inexact 3))
(third (/ one three))
(xthird (inexact->exact third)))
(test "float" eq? #f (= 1/3 xthird))
(test "exact<->inexact" = third (exact->inexact xthird)))))
; All done.
(if (in 'testing '(run (lost?)))
(display "Some tests failed.")
(display "All tests succeeded."))
(newline)
(define (done)
(exit (if (in 'testing '(run (lost?))) 1 0)))

41
debug/describe.scm
View File

@ -1,41 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
(define (describe x)
(if (and (stob? x)
(< (stob-type x) least-b-vector-type))
(let ((tag (string-append (number->string x) ": "))
(len (bytes->cells (stob-length-in-bytes x))))
(do ((i -1 (+ i 1)))
((= i len))
(describe-1 (stob-ref x i) tag)))
(describe-1 x "")))
(define (describe-1 x addr)
(cond ((fixnum? x) (display " fixnum ") (write (extract-fixnum x)))
((header? x)
(display addr)
(if (immutable-header? x)
(display " immutable"))
(display " header ")
(let ((type (header-type x)))
(if (< type stob-count)
(write (vector-ref stob type))
(write type)))
(display " ")
(write (header-length-in-bytes x)))
((immediate? x)
(cond (else
(display " immediate ")
(let ((type (immediate-type x)))
(if (< type imm-count)
(write (vector-ref imm type))
(write type)))
(display " ")
(write (immediate-info x)))))
((stob? x)
(display " stob ") (write x))
(else (display " ? ") (write x)))
(newline))

8
debug/fact.scm
View File

@ -1,8 +0,0 @@
; don't copyright this, silly shell script
(define (fact n)
(if (= n 0)
1
(* n (fact (- n 1)))))

72
debug/fix-low.scm
View File

@ -1,72 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
(define-structure low-structures low-structures-interface
;; Flatloaded
(open ))
(define ascii (structure-ref built-in-structures ascii))
(define signals (structure-ref built-in-structures signals))
(define loopholes (structure-ref built-in-structures loopholes))
(define escapes (structure-ref built-in-structures escapes))
(define vm-exposure (structure-ref built-in-structures vm-exposure))
; (define-structure locations locations-interface
; (open scheme-level-2 ...))
(define locations (structure-ref built-in-structures locations))
(define closures (structure-ref built-in-structures closures))
(define bitwise (structure-ref built-in-structures bitwise))
;; For initial system
(define write-images (structure-ref built-in-structures write-images))
(define structure-refs (structure-ref built-in-structures structure-refs))
(define low-level (structure-ref built-in-structures low-level))
;; For compiler
(define features (structure-ref built-in-structures features))
(define code-vectors (structure-ref built-in-structures code-vectors))
(define source-file-names
(structure-ref built-in-structures source-file-names))
(define true-scheme (structure-ref built-in-structures scheme))
(define-structure scheme-level-0 scheme-level-0-interface
(open true-scheme
primitives ; only for extended-number?
structure-refs)
(access true-scheme)
(files level-0))
(define-structure silly (export reverse-list->string)
(open true-scheme)
(begin (define (reverse-list->string l n)
(list->string (reverse l)))))
(define-structure cont-primitives
(export make-continuation
continuation-length
continuation-ref
continuation-set!
continuation?)
(open (structure-ref built-in-structures primitives)))
(define-structures ((primitives primitives-interface)
(primitives-internal (export maybe-handle-interrupt
raise-exception
get-exception-handler
?start)))
(open true-scheme
cont-primitives
(structure-ref built-in-structures bitwise)
(structure-ref built-in-structures records)
(structure-ref built-in-structures signals)
(structure-ref built-in-structures features)
(structure-ref built-in-structures templates)
)
(files ("../alt" primitives)
("../alt" weak)))
; How about signals?

59
debug/for-debugging.scm
View File

@ -1,59 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; --------------------
; Fake interrupt and exception system.
; This needs to be reconciled with alt/primitives.scm.
(define (with-exceptions thunk)
(with-handler
(lambda (c punt)
(cond ((and (exception? c)
(procedure? (get-exception-handler)))
(handle-exception-carefully c))
((interrupt? c)
(if (not (deal-with-interrupt c))
(punt)))
;; ((vm-return? c)
;; (vm-return (cadr c)))
(else
(punt))))
thunk))
(define (handle-exception-carefully c)
(display "(Exception: ") (write c) (display ")") (newline)
(noting-exceptional-context c
(lambda ()
(raise-exception (exception-opcode c)
(exception-arguments c)))))
(define (noting-exceptional-context c thunk)
(call-with-current-continuation
(lambda (k)
;; Save for future inspection, just in case.
(set! *exceptional-context* (cons c k))
(thunk))))
(define *exceptional-context* #f)
(define (deal-with-interrupt c)
(noting-exceptional-context c
(lambda ()
(maybe-handle-interrupt
(if (and (pair? (cdr c)) (integer? (cadr c)))
(cadr c)
(enum interrupt keyboard))))))
; (define (poll-for-interrupts) ...)
; Get the whole thing started
(define (?start-with-exceptions entry-point arg)
(with-exceptions
(lambda ()
(?start entry-point arg))))
(define (in struct form)
(eval form (structure-package struct)))

30
debug/level-0.scm
View File

@ -1,30 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Redefinitions of some usual Scheme things so as to make the new
; exception system kick in when it needs to.
(define (number? n)
(or ((structure-ref true-scheme number?) n)
(extended-number? n)))
;(define (integer? n)
; (if ((structure-ref true-scheme number?) n)
; ((structure-ref true-scheme integer?) n)
; (and (extended-number? n)
; ... raise exception ...)))
(define (+ x y) ((structure-ref true-scheme +) x y))
(define (* x y) ((structure-ref true-scheme *) x y))
(define (- x y) ((structure-ref true-scheme -) x y))
(define (/ x y) ((structure-ref true-scheme /) x y))
(define (= x y) ((structure-ref true-scheme =) x y))
(define (< x y) ((structure-ref true-scheme <) x y))
(define (make-vector x y) ((structure-ref true-scheme make-vector) x y))
(define (make-string x y) ((structure-ref true-scheme make-string) x y))
(define (apply x y) ((structure-ref true-scheme apply) x y))
(define (read-char x) ((structure-ref true-scheme read-char) x))
(define (peek-char x) ((structure-ref true-scheme peek-char) x))
(define (char-ready? x) ((structure-ref true-scheme char-ready?) x))
(define (write-char x y) ((structure-ref true-scheme write-char) x y))

36
debug/link-debug.scm
View File

@ -1,36 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Stuff for debugging new images:
(define (ev form package)
(invoke-template (compile-form form package)
(package-uid package)))
; If desired, this definition of invoke-template can be replaced by
; something that starts up a different virtual machine.
(define (invoke-template template env . args)
(apply (make-closure template env)
args))
; Utility for tracking down uses of variables
(define (who-uses name proc)
(let recur ((tem (closure-template proc))
(path '()))
(let loop ((i 0))
(if (< i (template-length tem))
(let ((thing (template-ref tem i))
(down (lambda (tem)
(recur tem (cons (or (template-ref tem 1) i) path)))))
(cond ((template? thing)
(down thing))
((location? thing)
(if (eq? (location-name thing) name)
(begin (write path) (newline))))
((closure? thing)
(down (closure-template thing))))
(loop (+ i 1)))))))

34
debug/linker.scm
View File

@ -1,34 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
(define (link-simple-system filename resumer-exp . structs)
(link-system structs (lambda () resumer-exp) filename))
(define (link-reified-system some filename make-resumer-exp . structs)
(link-system (append structs (map cdr some))
(lambda ()
(display "Reifying") (newline)
`(,make-resumer-exp
(lambda ()
,(reify-structures some
(lambda (loc) loc)
`(lambda (loc) loc)))))
filename))
(define (link-system structs make-resumer filename)
(for-each ensure-loaded structs)
(let* ((p (make-simple-package structs eval #f))
(r (eval (make-resumer) p)))
;; (check-package p)
r))
;(define (check-package p)
; (let ((names (undefined-variables p)))
; (if (not (null? names))
; (begin (display "Undefined: ")
; (write names) (newline)))))
(define-syntax struct-list
(syntax-rules ()
((struct-list name ...) (list (cons 'name name) ...))))

65
debug/mini-command.scm
View File

@ -1,65 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Miniature command processor.
(define (command-processor ignore args)
(let ((in (current-input-port))
(out (current-output-port))
(batch? (member "batch" args)))
(let loop ()
((call-with-current-continuation
(lambda (go)
(with-handler
(lambda (c punt)
(cond ((or (error? c) (interrupt? c))
(display-condition c out)
(go (if batch?
(lambda () 1)
loop)))
((warning? c)
(display-condition c out))
(else (punt))))
(lambda ()
(if (not batch?) (display "- " out))
(let ((form (read in)))
(cond ((eof-object? form)
(newline out)
(go (lambda () 0)))
((and (pair? form) (eq? (car form) 'unquote))
(case (cadr form)
((load)
(mini-load in)
(go loop))
((go)
(let ((form (read in)))
(go (lambda ()
(eval form (interaction-environment))))))
(else (error "unknown command" (cadr form)))))
(else
(call-with-values
(lambda () (eval form (interaction-environment)))
(lambda results
(for-each (lambda (result)
(write result out)
(newline out))
results)
(go loop))))))))))))))
(define (mini-load in)
(let ((c (peek-char in)))
(cond ((char=? c #\newline) (read-char in) #t)
((char-whitespace? c) (read-char in) (mini-load in))
(else
(let ((filename (read-string in char-whitespace?)))
(load filename)
(mini-load in))))))
(define (read-string port delimiter?)
(let loop ((l '()) (n 0))
(let ((c (peek-char port)))
(cond ((or (eof-object? c)
(delimiter? c))
(list->string (reverse l)))
(else
(loop (cons (read-char port) l) (+ n 1)))))))

74
debug/mini-package.scm
View File

@ -1,74 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Miniature package system. This links mini-eval up to the output of
; the package reifier.
(define (package names locs get-location uid) ;Reified package
(lambda (name)
(let loop ((i (- (vector-length names) 1)))
(if (< i 0)
(error "unbound" name)
(if (eq? name (vector-ref names i))
(contents (get-location (vector-ref locs i)))
(loop (- i 1)))))))
(define (make-simple-package opens foo1 foo2 name)
(define bindings
(list (cons '%%define%%
(lambda (name val)
(set! bindings (cons (cons name val) bindings))))))
(lambda (name)
(let ((probe (assq name bindings)))
(if probe
(cdr probe)
(let loop ((opens opens))
(if (null? opens)
(error "unbound" name)
(if (memq name (structure-interface (car opens)))
((structure-package (car opens)) name)
(loop (cdr opens)))))))))
; Structures
(define (make-structure package interface . name-option)
(cons package (vector->list interface)))
(define structure-interface cdr)
(define structure-package car)
; Things used by reification forms
(define (operator name type-exp)
`(operator ,name ,type-exp))
(define (simple-interface names type) names)
; Etc.
(define (transform . rest) (cons 'transform rest))
(define (usual-transform . rest)
(cons 'usual-transform rest))
(define (transform-for-structure-ref . rest)
(cons 'transform-for-structure-ref rest))
(define (inline-transform . rest)
(cons 'inline-transform rest))
(define (package-define! p name op) 'lose)
; --------------------
; ???
; (define (integrate-all-primitives! . rest) 'lose)
;(define (package-lookup p name)
; ((p '%%lookup-operator%%) name))
;(define (package-ensure-defined! p name)
; (package-define! p name (make-location 'defined name)))

19
debug/mini-start.scm
View File

@ -1,19 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Start up a system that has reified packages.
; COMMAND-PROCESSOR might be either the miniature one or the real one.
(define (start structs-thunk)
(usual-resumer
(lambda (arg)
(initialize-interaction-environment! (structs-thunk))
(command-processor #f arg))))
(define (initialize-interaction-environment! structs)
(let ((scheme (cdr (assq 'scheme structs))))
(let ((tower (delay (cons eval (scheme-report-environment 5)))))
(set-interaction-environment!
(make-simple-package (map cdr structs) #t tower 'interaction))
(set-scheme-report-environment!
5
(make-simple-package (list scheme) #t tower 'r5rs)))))

73
debug/mumble-packages.scm
View File

@ -1,73 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; This is for version 0.28
; We define these two because they aren't reified:
; scheme-level-0
; silly
; We redefine these two so as not to compromise the security of the
; built-in exception and interrupt systems:
; primitives
; signals
; Suppose you have just done "make image" to build the scheme48 heap image.
; Suppose that the linker produces an initial.image, but that when that
; image is resumed you get the error
; exception handler is not a closure
; This is not informative. To find out what really happened, you have
; two choices:
; (1) Run the image under the VM running in Scheme.
; (2) Run the image using the following handy dandy tool.
; For choice (2), you would do something like the following:
;
; ,translate =scheme48/ ./
; ,config ,load debug/mumble-packages.scm
; ,in link-config
; y
; ;; Cf. Makefile rule for initial.image
; ,load interfaces.scm packages.scm debug/fix-low.scm
; (flatload initial-structures)
; ,load initial.scm
; (define test (link-initial-system))
; primitives-internal
; ,open ##
; Replacement for the structure defined in link-packages.scm
(define-structure linker (export link-simple-system
link-reified-system
(struct-list :syntax))
(open scheme
packages ;make-simple-package
reification
ensures-loaded
) ; (enum interrupt keyboard)
(files linker))
; Copied from link-packages.scm
(define-structure loadc (export load-configuration
(structure-ref :syntax))
(open scheme
environments ; *structure-ref
fluids)
(files ((".." link) loadc)))
; Replacement for the structure defined in link-packages.scm
(define-structure link-config (export ) ;dummy structure...
(open scheme
linker
;; low-structures
;; start-debugging
defpackage
types
analysis
structure-refs ;the real one
loadc ;defines structure-ref, but not the one we want
flatloading
ensures-loaded
interfaces)
(access built-in-structures)
(begin 0))

130
debug/mutation.scm
View File

@ -1,130 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Package mutation tests
"
,translate =scheme48/ ./
,open packages compiler built-in-structures handle condition
,open interfaces table defpackage package-mutation
"
(define (try exp env . should-return-option)
(let ((val (ignore-errors (lambda () (eval exp env)))))
(if (if (null? should-return-option)
(error? val)
(not (if (eq? (car should-return-option) 'error)
(error? val)
(eq? val (car should-return-option)))))
(begin (write `(lost: ,exp => ,val))
(newline)))))
(define p1 (make-simple-package (list scheme) eval #f 'p1))
(try 'a p1 'error)
(try '(define a 'aa) p1)
(try 'a p1 'aa)
(try '(define (foo) b) p1)
(try '(foo) p1 'error)
(try '(define b 'bb) p1)
(try 'b p1 'bb)
(try '(foo) p1 'bb)
(define s1-sig (make-simple-interface 's1-sig '(((a b c d e f) value))))
(define s1 (make-structure p1 (lambda () s1-sig) 's1))
(define p2 (make-simple-package (list s1 scheme) eval #f 'p2))
(try 'b p2 'bb)
(try 'c p2 'error)
(try 'z p2 'error)
(try '(define (bar) c) p2)
(try '(bar) p2 'error)
(try '(define c 'cc) p1)
(try 'c p2 'cc)
(try '(bar) p2 'cc)
(try '(define (baz1) d) p1)
(try '(define (baz2) d) p2)
(try '(baz1) p1 'error)
(try '(baz2) p2 'error)
(try '(define d 'dd) p1)
(try '(baz1) p1 'dd)
(try '(baz2) p2 'dd)
; Shadow
(try '(define d 'shadowed) p2)
(try '(baz1) p1 'dd)
(try '(baz2) p2 'shadowed)
; Shadow undefined
(try '(define (moo1) f) p1)
(try '(define (moo2) f) p2)
(try '(define f 'ff) p2)
(try '(moo1) p1 'error)
(try '(moo2) p2 'ff)
(try '(define (quux1) e) p1)
(try '(define (quux2) e) p2)
(try '(define (quux3 x) (set! e x)) p1)
(try '(define (quux4 x) (set! e x)) p2)
;
(try '(quux1) p1 'error)
(try '(quux2) p2 'error)
(try '(quux3 'q3) p1 'error)
(try '(quux4 'q4) p2 'error)
;
(try '(define e 'ee) p1)
(try '(quux1) p1 'ee)
(try '(quux2) p2 'ee)
(try '(quux3 'q3) p1)
(try '(quux1) p1 'q3)
(try '(quux2) p2 'q3)
(try '(quux4 'q4) p2 'error)
;
(try '(define e 'ee2) p2)
(try '(quux1) p1 'q3)
(try '(quux2) p2 'ee2)
(try '(quux3 'qq3) p1)
(try '(quux4 'qq4) p2)
(try '(quux1) p1 'qq3)
(try '(quux2) p2 'qq4)
; (set-verify-later! really-verify-later!)
(define-interface s3-sig (export a b x y z))
(define s3
(make-structure p1 (lambda () s3-sig) 's3))
(define p4 (make-simple-package (list s3 scheme) eval #f 'p4))
(try '(define (fuu1) a) p4)
(try '(define (fuu2) d) p4)
(try '(fuu1) p4 'aa)
(try '(fuu2) p4 'error)
; Remove a, add d
(define-interface s3-sig (export b d x y z))
;(package-system-sentinel)
(try 'a p4 'error)
(try 'd p4 'dd)
(try '(fuu2) p4 'dd)
(try '(fuu1) p4 'error) ; Foo.
(define (table->alist t)
(let ((l '()))
(table-walk (lambda (key val) (set! l (cons (cons key val) l))) t)
l))

107
debug/profile.scm
View File

@ -1,107 +0,0 @@
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; This was a fun hack, but I didn't get much useful information out of
; it -- a profiler that only samples at points allowed by the VM's
; interrupt mechanism doesn't tell you what you want to know. The
; only information available at that point is the continuation; what
; we really want to know is where the PC has been. In particular, the
; only procedures that show up in the table at all are those that call
; other procedures. JAR 12/92
'
(define-structure profiler (export profile one-second)
(open scheme-level-2 handle exception ;interrupts
architecture continuation signals condition template
table structure-refs debug-data sort
primitives) ;schedule-interrupt
(files (misc profile)))
(define (profile thunk frequency)
(let ((table (make-table template-uid))
(dt (round (/ one-second frequency))))
(primitive-catch
(lambda (k0)
(let ((foo (continuation-template k0)))
(with-handler
(lambda (c punt)
(if (and (interrupt? c)
(eq? (interrupt-type c) interrupt/alarm))
(primitive-catch
(lambda (k)
(record-profile-information! k foo table)
(schedule-interrupt dt)))
(punt)))
(lambda ()
(dynamic-wind (lambda () (schedule-interrupt dt))
thunk
(lambda () (schedule-interrupt 0))))))))
table))
(define (record-profile-information! k k0-template table)
(let ((k1 (continuation-cont (continuation-cont k))))
(let ((z (get-counts table k1)))
(set-car! z (+ (car z) 1))
(set-cdr! z (+ (cdr z) 1)))
(do ((k (continuation-parent k1) (continuation-parent k)))
((or (not (continuation? k))
(eq? (continuation-template k) k0-template)))
(let ((z (get-counts table k)))
(set-cdr! z (+ (cdr z) 1))))))
(define (get-counts table k)
(let ((info (template-info (continuation-template k))))
(or (table-ref table info)
(let ((z (cons 0 0)))
(table-set! table info z)
z))))
(define (template-uid info)
(cond ((integer? info)
info)
((debug-data? info)
(debug-data-uid info))
(else 0))) ;??
(define interrupt-type cadr)
(define interrupt/alarm (enum interrupt alarm))
(define (dump t)
(let ((l '()))
(table-walk (lambda (key count)
(let ((dd (if (integer? key)
(table-ref debug-data-table key)
key)))
(set! l (cons (cons count
(if (debug-data? dd)
(debug-data-names dd)
`(? ,key)))
l))))
t)
(do ((l (sort-list l more-interesting?)
(cdr l))
(i 0 (+ i 1)))
((or (null? l) (> i *prefix*)))
(let* ((counts+names (car l))
(leaf-count (caar counts+names))
(total-count (cdar counts+names))
(names (cdr counts+names)))
(display (pad-left total-count 6)) (display #\space)
(display (pad-left leaf-count 6)) (display #\space)
(write names)
(newline)))))
(define (more-interesting? x y)
(let ((c1 (cdar x))
(c2 (cdar y)))
(or (> c1 c2)
(and (= c1 c2)
(> (caar x) (caar y))))))
(define *prefix* 60)
(define (pad-left s n)
(let ((s (cond ((number? s) (number->string s))
((symbol? s) (symbol->string s))
(else s))))
(string-append (make-string (- n (string-length s)) #\space)
s)))

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