Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Kali Scheme from the kali-0.52.2.tar.gz release tarball

  • Loading branch information...
commit 79bf76b4964729b63fce99c4d2149b32cb067ac0 0 parents
@tonyg authored
Showing with 47,882 additions and 0 deletions.
  1. +60 −0 COPYING
  2. +120 −0 INSTALL
  3. +11 −0 KALI.README
  4. +478 −0 Makefile.in
  5. +88 −0 README
  6. +32 −0 acconfig.h
  7. +36 −0 build/build-usual-image
  8. +7 −0 build/filenames.make
  9. +49 −0 build/filenames.scm
  10. +4,371 −0 build/initial.debug
  11. BIN  build/initial.image
  12. +60 −0 build/initial.scm
  13. +88 −0 build/load-linker.exec
  14. +82 −0 build/lucid-script.lisp
  15. +1 −0  build/minor-version-number
  16. +19 −0 c/event.h
  17. +715 −0 c/extension.c
  18. +15 −0 c/fake/sigact.h
  19. +22 −0 c/fake/strerror.c
  20. +8 −0 c/fake/strerror.h
  21. +9 −0 c/fake/sys-select.h
  22. +16 −0 c/fd-io.h
  23. +12 −0 c/io.h
  24. +129 −0 c/kali.h
  25. +174 −0 c/main.c
  26. +59 −0 c/prescheme.h
  27. +109 −0 c/scheme48.h
  28. +1,832 −0 c/scheme48heap.c
  29. +19 −0 c/scheme48heap.h
  30. +12,166 −0 c/scheme48vm.c
  31. +40 −0 c/scheme48vm.h
  32. +13 −0 c/socket.h
  33. +99 −0 c/sysdep.h.in
  34. +236 −0 c/unix/dynamo.c
  35. +575 −0 c/unix/event.c
  36. +175 −0 c/unix/fd-io.c
  37. +294 −0 c/unix/io.c
  38. +126 −0 c/unix/misc.c
  39. +178 −0 c/unix/socket.c
  40. +1,925 −0 configure
  41. +127 −0 configure.in
  42. +309 −0 doc/big-scheme.txt
  43. +87 −0 doc/call-back.txt
  44. +92 −0 doc/external.txt
  45. +290 −0 doc/hacking.txt
  46. +159 −0 doc/install.txt
  47. +201 −0 doc/io.txt
  48. +254 −0 doc/kali.html
  49. BIN  doc/kali.ps
  50. BIN  doc/meeting.ps
  51. BIN  doc/module.ps
  52. +681 −0 doc/news.txt
  53. +175 −0 doc/no-leaf-env.txt
  54. +81 −0 doc/package.txt
  55. +81 −0 doc/scheme48.man
  56. +94 −0 doc/src/code.tex
  57. +253 −0 doc/src/hyperlatex.sty
  58. +358 −0 doc/src/kali.tex
  59. +45 −0 doc/src/latex-stuff.tex
  60. +439 −0 doc/src/meeting.tex
  61. +728 −0 doc/src/module.tex
  62. +83 −0 doc/src/summary.tex
  63. +89 −0 doc/threads.txt
  64. +243 −0 doc/todo.txt
  65. +240 −0 doc/type.txt
  66. +709 −0 doc/user-guide.txt
  67. +47 −0 emacs/README
  68. +693 −0 emacs/cmulisp.el
  69. +433 −0 emacs/cmuscheme.el
  70. +99 −0 emacs/cmuscheme48.el
  71. +594 −0 emacs/cmushell.el
  72. +1,372 −0 emacs/comint.el
  73. +91 −0 emacs/jar-hacks.el
  74. +98 −0 gdbinit
  75. +238 −0 install-sh
  76. +16 −0 ps-compiler/compile-gc.scm
  77. +25 −0 ps-compiler/compile-vm-no-gc.scm
  78. +27 −0 ps-compiler/compile-vm.scm
  79. +340 −0 ps-compiler/doc/node.txt
  80. +15 −0 ps-compiler/doc/todo.txt
  81. +125 −0 ps-compiler/front/cps.scm
  82. +320 −0 ps-compiler/front/jump.scm
  83. +225 −0 ps-compiler/front/special.scm
  84. +92 −0 ps-compiler/front/top.scm
  85. +261 −0 ps-compiler/interfaces.scm
  86. +43 −0 ps-compiler/load-ps-compiler.scm
  87. +12 −0 ps-compiler/load-scheme.scm
  88. +1 −0  ps-compiler/minor-version-number
  89. +41 −0 ps-compiler/node/arch.scm
  90. +28 −0 ps-compiler/node/leftovers.scm
  91. +281 −0 ps-compiler/node/let-nodes.scm
  92. +78 −0 ps-compiler/node/node-equal.scm
  93. +715 −0 ps-compiler/node/node-util.scm
  94. +544 −0 ps-compiler/node/node.scm
  95. +356 −0 ps-compiler/node/pp-cps.scm
  96. +128 −0 ps-compiler/node/primop.scm
  97. +213 −0 ps-compiler/node/vector.scm
  98. +237 −0 ps-compiler/package-defs.scm
  99. +43 −0 ps-compiler/param.scm
  100. +353 −0 ps-compiler/prescheme/c-call.scm
  101. +385 −0 ps-compiler/prescheme/c-decl.scm
  102. +131 −0 ps-compiler/prescheme/c-stuff
  103. +464 −0 ps-compiler/prescheme/c.scm
  104. +225 −0 ps-compiler/prescheme/display.scm
  105. +214 −0 ps-compiler/prescheme/eval.scm
  106. +78 −0 ps-compiler/prescheme/expand.scm
  107. +394 −0 ps-compiler/prescheme/flatten.scm
  108. +667 −0 ps-compiler/prescheme/form.scm
  109. +134 −0 ps-compiler/prescheme/front-end.scm
  110. +162 −0 ps-compiler/prescheme/hoist.scm
  111. +341 −0 ps-compiler/prescheme/infer-early.scm
  112. +94 −0 ps-compiler/prescheme/inference.scm
  113. +215 −0 ps-compiler/prescheme/interfaces.scm
  114. +236 −0 ps-compiler/prescheme/linking.scm
  115. +295 −0 ps-compiler/prescheme/merge.scm
  116. +79 −0 ps-compiler/prescheme/node-type.scm
  117. +310 −0 ps-compiler/prescheme/package-defs.scm
  118. +46 −0 ps-compiler/prescheme/primitive.scm
  119. +250 −0 ps-compiler/prescheme/primop/arith.scm
  120. +157 −0 ps-compiler/prescheme/primop/base.scm
  121. +93 −0 ps-compiler/prescheme/primop/c-arith.scm
  122. +343 −0 ps-compiler/prescheme/primop/c-base.scm
  123. +169 −0 ps-compiler/prescheme/primop/c-io.scm
  124. +29 −0 ps-compiler/prescheme/primop/c-primop.scm
  125. +43 −0 ps-compiler/prescheme/primop/c-record.scm
  126. +242 −0 ps-compiler/prescheme/primop/c-vector.scm
  127. +38 −0 ps-compiler/prescheme/primop/io.scm
  128. +163 −0 ps-compiler/prescheme/primop/primop.scm
  129. +188 −0 ps-compiler/prescheme/primop/scm-arith.scm
  130. +123 −0 ps-compiler/prescheme/primop/scm-memory.scm
  131. +47 −0 ps-compiler/prescheme/primop/scm-record.scm
  132. +404 −0 ps-compiler/prescheme/primop/scm-scheme.scm
  133. +82 −0 ps-compiler/prescheme/primop/vector.scm
  134. +117 −0 ps-compiler/prescheme/ps-syntax.scm
  135. +123 −0 ps-compiler/prescheme/record.scm
  136. +101 −0 ps-compiler/prescheme/spec.scm
  137. +325 −0 ps-compiler/prescheme/substitute.scm
  138. +23 −0 ps-compiler/prescheme/test/boolean.scm
  139. +70 −0 ps-compiler/prescheme/test/buffer.scm
  140. +9 −0 ps-compiler/prescheme/test/bvector.scm
  141. +16 −0 ps-compiler/prescheme/test/cell.scm
  142. +27 −0 ps-compiler/prescheme/test/coerce.scm
  143. +62 −0 ps-compiler/prescheme/test/dispatch.scm
  144. +55 −0 ps-compiler/prescheme/test/dispatch2.scm
  145. +16 −0 ps-compiler/prescheme/test/eval.scm
  146. +10 −0 ps-compiler/prescheme/test/eval2.scm
  147. +36 −0 ps-compiler/prescheme/test/eval3.scm
  148. +8 −0 ps-compiler/prescheme/test/external.scm
  149. +27 −0 ps-compiler/prescheme/test/fact.cps
  150. +12 −0 ps-compiler/prescheme/test/fact.scm
  151. +83 −0 ps-compiler/prescheme/test/fact2.scm
  152. +18 −0 ps-compiler/prescheme/test/goto.scm
  153. +13 −0 ps-compiler/prescheme/test/hoist.scm
  154. +9 −0 ps-compiler/prescheme/test/integers.scm
  155. +42 −0 ps-compiler/prescheme/test/letrec.scm
  156. +234 −0 ps-compiler/prescheme/test/list.scm
  157. +52 −0 ps-compiler/prescheme/test/loop.scm
  158. +6 −0 ps-compiler/prescheme/test/memory.scm
  159. +65 −0 ps-compiler/prescheme/test/package-defs.scm
  160. +9 −0 ps-compiler/prescheme/test/poly.scm
  161. +70 −0 ps-compiler/prescheme/test/prescheme.h
  162. +27 −0 ps-compiler/prescheme/test/record.scm
  163. +67 −0 ps-compiler/prescheme/test/select.scm
  164. +17 −0 ps-compiler/prescheme/test/simp.scm
  165. +52 −0 ps-compiler/prescheme/test/string.scm
  166. +70 −0 ps-compiler/prescheme/test/test.scm
  167. +9 −0 ps-compiler/prescheme/test/values.scm
  168. +30 −0 ps-compiler/prescheme/test/vector.scm
  169. +32 −0 ps-compiler/prescheme/test/vector2.scm
  170. +17 −0 ps-compiler/prescheme/test/write.scm
  171. +632 −0 ps-compiler/prescheme/to-cps.scm
Sorry, we could not display the entire diff because too many files (491) changed.
60 COPYING
@@ -0,0 +1,60 @@
+Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees.
+Copyright (c) 1996 by NEC Research Institute, Inc.
+
+Use of this software for non-commercial academic purposes is
+permitted provided that the above copyright notice appears
+in the software itself and in the accompanying documentation
+and this permission notice appears in the documentation.
+
+Use of this software for commerical purposes is also
+permitted, but only if, in addition to the conditions
+required for non-commerical users, written notification of
+such use is provided by the commerical user to NEC Research
+Institute, Inc. (NECI) prior to the fabrication and
+distribution of the software.
+
+This software is experimental. NECI does not make any
+representations regarding the suitability of the software
+for any purpose and NECI will not support the software. The
+software is provided "AS IS". NECI does not make any
+warranties either express or implied with regard to the
+software.
+
+NECI also disclaims any warranty that the software is free
+of infringement of any intellectual property rights of
+others. No other license express or implied is hereby
+provided. Users of this software for commercial purposes
+agree to indemnify and hold harmless NECI from any claims
+whatsoever arising from the commercial use or distribution
+of the software, including claims and/or actions arising
+from infringement of intellectual property rights.
+
+NECI shall not be liable for any damages, including general,
+special, incidental or consequential, arising out of the use
+or inability to use the software.
+
+The name of NEC Research Institute, Inc. shall not be used in
+advertising or publicity related to the distribution of the
+software, without the prior written consent of NECI.
+
+
+Distributing Autoconf Output
+****************************
+
+[excerpt from autoconf documentation]
+
+ The configuration scripts that Autoconf produces are covered by the
+GNU General Public License. This is because they consist almost
+entirely of parts of Autoconf itself, rearranged somewhat, and Autoconf
+is distributed under the terms of the GPL. As applied to Autoconf, the
+GPL just means that you need to distribute `configure.in' along with
+`configure'.
+
+ Programs that use Autoconf scripts to configure themselves do not
+automatically come under the GPL. Distributing an Autoconf
+configuration script as part of a program is considered to be *mere
+aggregation* of that work with the Autoconf script. Such programs are
+not derivative works based on Autoconf; only their configuration scripts
+are. We still encourage software authors to distribute their work under
+terms like those of the GPL, but doing so is not required to use
+Autoconf.
120 INSTALL
@@ -0,0 +1,120 @@
+ This is a generic INSTALL file for utilities distributions.
+If this package does not come with, e.g., installable documentation or
+data files, please ignore the references to them below.
+
+ [For information specific to Scheme 48, see doc/install.txt.]
+
+ The `configure' shell script attempts to guess correct values for
+various system-dependent variables used during compilation, and
+creates the Makefile(s) (one in each subdirectory of the source
+directory). In some packages it creates a C header file containing
+system-dependent definitions. It also creates a file `config.status'
+that you can run in the future to recreate the current configuration.
+
+To compile this package:
+
+1. Configure the package for your system.
+
+ Normally, you just `cd' to the directory containing the package's
+source code and type `./configure'. If you're using `csh' on an old
+version of System V, you might need to type `sh configure' instead to
+prevent `csh' from trying to execute `configure' itself.
+
+ Running `configure' takes a minute or two. While it is running, it
+prints some messages that tell what it is doing. If you don't want to
+see the messages, run `configure' with its standard output redirected
+to `/dev/null'; for example, `./configure >/dev/null'.
+
+ To compile the package in a different directory from the one
+containing the source code, you must use a version of `make' that
+supports the `VPATH' variable, such as GNU `make'. `cd' to the
+directory where you want the object files and executables to go and run
+the `configure' script. `configure' automatically checks for the
+source code in the directory that `configure' is in and in `..'. If
+for some reason `configure' is not in the source code directory that
+you are configuring, then it will report that it can't find the source
+code. In that case, run `configure' with the option `--srcdir=DIR',
+where DIR is the directory that contains the source code.
+
+ By default, `make install' will install the package's files in
+`/usr/local/bin', `/usr/local/man', etc. You can specify an
+installation prefix other than `/usr/local' by giving `configure' the
+option `--prefix=PATH'. Alternately, you can do so by consistently
+giving a value for the `prefix' variable when you run `make', e.g.,
+ make prefix=/usr/gnu
+ make prefix=/usr/gnu install
+
+ You can specify separate installation prefixes for
+architecture-specific files and architecture-independent files. If you
+give `configure' the option `--exec-prefix=PATH' or set the `make'
+variable `exec_prefix' to PATH, the package will use PATH as the prefix
+for installing programs and libraries. Data files and documentation
+will still use the regular prefix. Normally, all files are installed
+using the same prefix.
+
+ Some packages pay attention to `--with-PACKAGE' options to
+`configure', where PACKAGE is something like `gnu-as' or `x' (for the X
+Window System). The README should mention any `--with-' options that
+the package recognizes.
+
+ `configure' ignores any other arguments that you give it.
+
+ On systems that require unusual options for compilation or linking
+that the package's `configure' script does not know about, you can give
+`configure' initial values for variables by setting them in the
+environment. In Bourne-compatible shells, you can do that on the
+command line like this:
+
+ CC='gcc -traditional' LIBS=-lposix ./configure
+
+ Here are the `make' variables that you might want to override with
+environment variables when running `configure'.
+
+ For these variables, any value given in the environment overrides the
+value that `configure' would choose:
+
+ - Variable: CC
+ C compiler program. The default is `cc'.
+
+ - Variable: INSTALL
+ Program to use to install files. The default is `install' if you
+ have it, `cp' otherwise.
+
+ For these variables, any value given in the environment is added to
+the value that `configure' chooses:
+
+ - Variable: DEFS
+ Configuration options, in the form `-Dfoo -Dbar...'. Do not use
+ this variable in packages that create a configuration header file.
+
+ - Variable: LIBS
+ Libraries to link with, in the form `-lfoo -lbar...'.
+
+ If you need to do unusual things to compile the package, we encourage
+you to figure out how `configure' could check whether to do them, and
+mail diffs or instructions to the address given in the README so we
+can include them in the next release.
+
+2. Type `make' to compile the package. If you want, you can override
+the `make' variables CFLAGS and LDFLAGS like this:
+
+ make CFLAGS=-O2 LDFLAGS=-s
+
+3. If the package comes with self-tests and you want to run them,
+type `make check'. If you're not sure whether there are any, try it;
+if `make' responds with something like
+ make: *** No way to make target `check'. Stop.
+then the package does not come with self-tests.
+
+4. Type `make install' to install programs, data files, and
+documentation.
+
+5. You can remove the program binaries and object files from the
+source directory by typing `make clean'. To also remove the
+Makefile(s), the header file containing system-dependent definitions
+(if the package uses one), and `config.status' (all the files that
+`configure' created), type `make distclean'.
+
+ The file `configure.in' is used to create `configure' by a program
+called `autoconf'. You only need it if you want to regenerate
+`configure' using a newer version of `autoconf'.
11 KALI.README
@@ -0,0 +1,11 @@
+To make kali, follow the instructions in INSTALL. It has to be
+installed some where in your PATH. (Before you do a
+ make install
+you can try it out by running the `go' file in the source directory.)
+
+Documentation on using Kali can be found in doc/kali.{ps|html}.
+
+If you have problems building or using Kali, please send mail to
+ kali-request@research.nj.nec.com
+and we'll see if we can be of any help.
+
478 Makefile.in
@@ -0,0 +1,478 @@
+# Kali Makefile
+# Documentation in files INSTALL and doc/install.txt
+
+SHELL = /bin/sh
+srcdir = @srcdir@
+VPATH = @srcdir@
+CC = @CC@
+DEFS = @DEFS@
+LIBS = @LIBS@
+CFLAGS = @CFLAGS@
+INSTALL = @INSTALL@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_DATA = @INSTALL_DATA@
+
+LDFLAGS = @LDFLAGS@
+LIBOBJS = @LIBOBJS@
+
+prefix = @prefix@
+exec_prefix = @exec_prefix@
+bindir = $(exec_prefix)/bin
+libdir = $(exec_prefix)/lib
+incdir = $(exec_prefix)/include
+manext = 1
+mandir = $(prefix)/man/man$(manext)
+
+# HP 9000 series, if you don't have gcc
+# CC = cc
+# CFLAGS = -Aa -O +Obb1800
+# DEFS = -D_HPUX_SOURCE -Dhpux
+
+# Ultrix
+# LDFLAGS = -N
+
+.c.o:
+ $(CC) -c $(CPPFLAGS) $(DEFS) -I$(srcdir)/c $(CFLAGS) -o $@ $<
+
+# You might want to change RUNNABLE to "s48"
+RUNNABLE = kali
+MANPAGE = $(RUNNABLE).$(manext)
+LIB = $(libdir)/$(RUNNABLE)
+
+distdir = /tmp
+
+# If make barfs on this include line, just comment it out. It's only
+# really needed if you want to build the linker or rebuild initial.image.
+include $(srcdir)/build/filenames.make
+#
+#NetBSD make wants to see this instead:
+#.include "$(srcdir)/build/filenames.make"
+
+
+# Static linker:
+#
+# You only need the linker if you're going to make changes to the
+# things that go into the initial.image, which in general means the
+# files in rts/. If you decide you need to use the linker, then you
+# gots your choice; it can run in just about any version of Scheme 48
+# or Pseudoscheme. (It has also been made to run in Scheme->C.) It
+# doesn't matter a whole lot which Scheme you use as long as it's not
+# broken or unavailable. The two best choices are:
+# 1. As below: build the linker on the scheme48vm and kali.image
+# that are in the current directory.
+# 2. LINKER_VM = $(RUNNABLE) $(BIG_HEAP)
+# LINKER_RUNNABLE = $(RUNNABLE)
+# These settings requires you to already have a $(RUNNABLE)
+# command. This is desirable if you are making changes to the
+# system that might break scheme48vm and/or kali.image. But it
+# requires you to have squirreled away a previous working version
+# of kali.
+
+BIG_HEAP = -h 6000000
+LINKER_VM = ./$(VM) $(BIG_HEAP)
+LINKER_RUNNABLE = $(LINKER_VM) -i $(IMAGE)
+LINKER_IMAGE = build/linker.image
+LINKER = $(LINKER_VM) -i $(LINKER_IMAGE)
+START_LINKER = echo ',batch' && echo ',bench on'
+
+
+# --------------------
+# You shouldn't have to change anything below this point.
+
+# Targets:
+
+IMAGE = kali.image
+INITIAL = build/initial.image
+VM = scheme48vm
+UNIX_OBJS = c/unix/misc.o c/unix/io.o c/unix/fd-io.o c/unix/event.o \
+ c/unix/socket.o c/unix/dynamo.o
+OBJS = c/scheme48vm.o c/scheme48heap.o c/extension.o
+FAKEHS = c/fake/sigact.h c/fake/strerror.h c/fake/sys-select.h
+
+# Sources:
+
+CONFIG_FILES = scheme/interfaces.scm scheme/low-packages.scm \
+ scheme/rts-packages.scm scheme/comp-packages.scm
+
+# Rules:
+
+# The following is the first rule and therefore the "make" command's
+# default target.
+enough: $(VM) $(IMAGE) go .notify
+
+# The developers are curious to know. Don't be concerned if this fails.
+.notify: build/minor-version-number
+ touch .notify
+ -echo Another 0.`cat $(srcdir)/build/minor-version-number` \
+ installation. \
+ | mail scheme-48-notifications@martigny.ai.mit.edu
+
+$(VM): c/main.o $(OBJS) $(UNIX_OBJS) $(LIBOBJS)
+ $(CC) $(LDFLAGS) $(CFLAGS) -o $@ c/main.o $(OBJS) $(UNIX_OBJS) \
+ $(LIBOBJS) $(LIBS)
+
+c/main.o: c/main.c
+ $(CC) -c $(CFLAGS) -o $@ \
+ -DDEFAULT_IMAGE_NAME=\"$(LIB)/$(IMAGE)\" \
+ $(CPPFLAGS) $(DEFS) c/main.c
+
+c/scheme48vm.o: c/prescheme.h c/scheme48vm.h c/scheme48heap.h c/event.h \
+ c/io.h c/fd-io.h
+c/scheme48heap.o: c/prescheme.h c/scheme48vm.h c/scheme48heap.h c/event.h \
+ c/io.h c/fd-io.h
+c/extension.o: c/sysdep.h $(FAKEHS) c/kali.h c/socket.h
+c/unix/event.o: c/sysdep.h $(FAKEHS) c/kali.h c/scheme48heap.h \
+ c/event.h c/fd-io.h
+c/unix/fd-io.o: c/sysdep.h $(FAKEHS) c/scheme48vm.h c/scheme48heap.h \
+ c/event.h c/fd-io.h
+c/unix/dynamo.o: c/sysdep.h $(FAKEHS) c/kali.h
+c/unix/socket.o: c/sysdep.h $(FAKEHS) c/scheme48vm.h c/scheme48heap.h \
+ c/event.h c/fd-io.h c/socket.h
+c/unix/misc.o: c/sysdep.h $(FAKEHS)
+c/unix/io.o: c/io.h
+c/fake/strerror.o: c/fake/strerror.h
+
+# --------------------
+# Make kali.image from initial.image and library .scm files.
+#
+# For bootstrap reasons, initial.image is *not* listed as a source,
+# even though it really is.
+
+$(IMAGE): $(VM) scheme/env/init-defpackage.scm scheme/more-interfaces.scm \
+ scheme/link-packages.scm scheme/more-packages.scm \
+ $(usual-files) build/initial.debug build/build-usual-image \
+ Makefile
+ build/build-usual-image . "`pwd`/scheme" '$(IMAGE)' './$(VM)' \
+ '$(INITIAL)'
+
+### Fake targets: all clean install man dist
+
+install: enough dirs inst-script inst-vm inst-misc inst-man inst-inc inst-image
+
+inst-vm:
+ $(INSTALL_PROGRAM) $(VM) $(LIB)
+
+inst-image:
+ rm -f '/tmp/$(IMAGE)' && \
+ build/build-usual-image . '$(LIB)' '/tmp/$(IMAGE)' './$(VM)' \
+ '$(INITIAL)' && \
+ $(INSTALL_DATA) /tmp/$(IMAGE) $(LIB) && \
+ rm /tmp/$(IMAGE)
+
+inst-man:
+ if [ -d $(mandir) -a -w $(mandir) ]; then \
+ sed 's=LBIN=$(bindir)=g' doc/scheme48.man | \
+ sed 's=LLIB=$(LIB)=g' | \
+ sed 's=LS48=$(RUNNABLE)=g' >$(MANPAGE) && \
+ $(INSTALL_DATA) $(MANPAGE) $(mandir) && \
+ rm $(MANPAGE); \
+ else \
+ echo "$(mandir) not writable dir, not installing man page" \
+ >&2; \
+ fi
+
+inst-inc:
+ $(INSTALL_DATA) c/kali.h $(incdir)
+
+inst-misc:
+ for stub in env big opt misc link; do \
+ for f in scheme/$$stub/*.scm; do \
+ $(INSTALL_DATA) $$f $(LIB)/$$stub || exit 1; \
+ done; \
+ done && \
+ for f in scheme/rts/*num.scm scheme/rts/jar-defrecord.scm; do \
+ $(INSTALL_DATA) $$f $(LIB)/rts || exit 1; \
+ done &&
+
+inst-script:
+ script=$(bindir)/$(RUNNABLE) && \
+ echo '#!/bin/sh' >$$script && \
+ echo >>$$script && \
+ echo 'lib=$(LIB)' >>$$script && \
+ echo 'exec $$lib/$(VM) -o $$lib/$(VM) -i $$lib/$(IMAGE) "$$@"' \
+ >>$$script && \
+ chmod +x $$script
+
+# Script to run kali in this directory.
+go:
+ echo '#!/bin/sh' >$@ && \
+ echo >>$@ && \
+ echo "lib=`pwd`" >>$@ && \
+ echo 'exec $$lib/$(VM) -o $$lib/$(VM) -i $$lib/$(IMAGE) "$$@"' \
+ >>$@ && \
+ chmod +x $@
+
+dirs:
+ for dir in $(libdir) $(bindir) $(incdir); do \
+ [ -d $$dir -a -w $$dir ] || { \
+ echo "$$dir not a writable directory" >&2; \
+ exit 1; \
+ }; \
+ done
+ { mkdir -p $(LIB) && [ -w $(LIB) ]; } || { \
+ echo "$(LIB) not a writable directory" >&2; \
+ exit 1; \
+ }
+ for dir in rts env big opt misc link; do \
+ { mkdir -p $(LIB)/$$dir && [ -w $(LIB)/$$dir ]; } || { \
+ echo "$(LIB)/$$dir not a writable directory" >&2; \
+ exit 1; \
+ }; \
+ done
+
+configure: configure.in
+ autoheader && autoconf
+
+clean:
+ -rm -f $(VM) *.o c/unix/*.o c/*.o c/fake/*.o TAGS $(IMAGE) \
+ build/*.tmp $(MANPAGE) build/linker.image \
+ scheme/debug/*.image scheme/debug/*.debug config.cache \
+ scheme/vm/scheme48vm.c scheme48heap.c \
+ config.log config.status c/sysdep.h go $(distname)
+
+distclean: clean
+ rm -f Makefile
+
+check: $(VM) $(IMAGE) scheme/debug/check.scm
+ ( \
+ echo ',batch'; \
+ echo ',translate =scheme48 scheme'; \
+ echo ',config ,load scheme/debug/test.scm'; \
+ echo ',exec ,load scheme/debug/check.scm'; \
+ echo ',exec (done)' \
+ ) | ./$(VM) -i $(IMAGE)
+
+# --------------------
+# Rules from here on down are not essential for the basic installation
+# procedure, and are not expected to work when srcdir is not the
+# distribution directory.
+
+all: vm linker
+ $(MAKE) image
+vm: $(VM)
+linker: $(LINKER_IMAGE)
+image: $(INITIAL)
+ $(MAKE) $(IMAGE)
+
+tags:
+ etags scheme/vm/arch.scm scheme/rts/*.scm scheme/bcomp/*.scm \
+ scheme/*.scm scheme/env/*.scm scheme/big/*.scm scheme/link/*.scm \
+ scheme/opt/*.scm scheme/debug/*.scm scheme/misc/*.scm
+
+# --------------------
+# Distribution...
+
+# DISTFILES should include all sources.
+DISTFILES = README KALI.README COPYING INSTALL configure \
+ acconfig.h configure.in Makefile.in install-sh \
+ doc/*.ps doc/*.txt doc/*.html doc/scheme48.man \
+ doc/src/*.tex doc/src/*.sty \
+ emacs/README build/*-version-number build/*.exec \
+ build/*.lisp build/build-usual-image build/filenames.make \
+ build/filenames.scm build/initial.debug \
+ build/initial.image build/initial.scm \
+ c/*.[ch] c/*/*.[ch] \
+ emacs/*.el gdbinit \
+ scheme/*.scm scheme/*/*.scm \
+ ps-compiler \
+ c/sysdep.h.in
+
+distname = $(RUNNABLE)-0.`cat build/minor-version-number`
+
+dist: build/initial.image
+ distname=$(distname) && \
+ distfile=$(distdir)/$$distname.tgz && \
+ if [ -d $(distdir) ] && \
+ [ -w $$distfile -o -w $(distdir) ]; then \
+ rm -f $$distname && \
+ ln -s . $$distname && \
+ files='' && \
+ for i in $(DISTFILES); do \
+ if [ "$$i" != "c/sysdep.h" ]; then \
+ files="$$files $$distname/$$i"; \
+ fi \
+ done && \
+ tar -cf - $$files | \
+ gzip --best >$$distfile && \
+ rm $$distname; \
+ else \
+ echo "Can't write $$distfile" >&2; \
+ exit 1; \
+ fi
+
+# Increment the minor version number
+inc:
+ f=build/minor-version-number && \
+ expr `cat $$f` + 1 >$$f.tmp && \
+ mv $$f.tmp $$f && \
+ echo '(define version-info "0.'`cat $$f`'")' \
+ >scheme/env/version-info.scm
+
+
+# --------------------
+# Generate build/filenames.make from *packages.scm
+#
+# This hack traces the module dependencies described in the
+# various configuration files and converts them into dependency lists
+# that "make" can use for its purposes.
+#
+# Since the distribution comes with a filenames.make, this rule
+# shouldn't be invoked for simple installations. But it will be used
+# if you change any of the *-packages.scm files.
+#
+# You can actually run the forms in filenames.scm in any Scheme
+# implementation that has syntax-rules and explicit-renaming low-level
+# macros (e.g., most versions of Scheme 48 and Pseudoscheme).
+# If there are errors running this script, and you need to debug,
+# don't use the initial.image, use something that has a reasonable
+# environment.
+#
+# If this fails and you don't feel like debugging or fixing the problem,
+# try "touch filenames.make" and hope for the best.
+
+PACKAGES=scheme/packages.scm scheme/rts-packages.scm scheme/alt-packages.scm \
+ scheme/comp-packages.scm scheme/initial-packages.scm \
+ scheme/link-packages.scm scheme/more-packages.scm \
+ build/filenames.scm
+
+build/filenames.make: $(PACKAGES)
+ $(MAKE) $(VM) PACKAGES=
+ ./$(VM) -i $(srcdir)/$(INITIAL) -a batch <build/filenames.scm
+# or: $(RUNNABLE) -a batch <build/filenames.scm
+
+# --------------------
+# Static linker
+#
+# The linker is capable of rebuilding an image from sources, even
+# across an incompatible change in VM data representations.
+
+build/linker.image: $(linker-files) scheme/alt/init-defpackage.scm
+ (echo ',batch'; \
+ echo ',bench on'; \
+ echo ',open signals handle features'; \
+ echo ',open bitwise ascii code-vectors record'; \
+ echo ',load $(linker-files)'; \
+ echo ',load scheme/alt/init-defpackage.scm'; \
+ echo ',dump build/linker.image' \
+ ) | $(LINKER_RUNNABLE)
+
+# Or, to bootstrap from Lucid Common Lisp: (last tested with
+# Pseudoscheme 2.9 and Scheme 48 version 0.19)
+
+PSEUDODIR = ../pseudo
+
+link/linker-in-lucid: build/lucid-script.lisp $(linker-files) \
+ scheme/alt/pseudoscheme-features.scm \
+ scheme/alt/pseudoscheme-record.scm
+ (echo \(defvar pseudoscheme-directory \"$(PSEUDODIR)/\"\); \
+ cat build/lucid-script.lisp; \
+ echo \(dump-linker\) \(lcl:quit\)) \
+ | lisp
+
+# --------------------
+# Initial image
+#
+# The initial.image is built by the static linker. The image contains
+# Scheme, the byte-code compiler, and a minimal command processor, but
+# no debugging environment to speak of.
+
+$(INITIAL): $(LINKER_IMAGE) $(CONFIG_FILES) build/initial.scm $(initial-files)
+ ($(START_LINKER); \
+ echo '(load-configuration "scheme/interfaces.scm")'; \
+ echo '(load-configuration "scheme/packages.scm")'; \
+ echo '(flatload initial-structures)'; \
+ echo '(load "build/initial.scm")'; \
+ echo '(link-initial-system)' \
+ ) | $(LINKER)
+
+# --------------------
+# Various small images for debugging low-level changes
+
+LOAD_DEBUG = \
+ $(START_LINKER); \
+ echo \(load-configuration \"scheme/interfaces.scm\"\); \
+ echo \(load-configuration \"scheme/packages.scm\"\); \
+ echo \(flatload debug-structures\)
+
+scheme/debug/tiny.image: $(LINKER_IMAGE) scheme/debug/tiny-packages.scm \
+ scheme/debug/tiny.scm
+ ($(START_LINKER); \
+ echo \(load-configuration \"scheme/debug/tiny-packages.scm\"\); \
+ echo \(link-simple-system \'\(scheme/debug tiny\) \'start tiny-system\)) \
+ | $(LINKER)
+
+scheme/debug/low-test.image: $(LINKER_IMAGE) scheme/debug/low-test-packages.scm \
+ scheme/debug/low-test.scm
+ ($(START_LINKER); \
+ echo \(load-configuration \"scheme/debug/low-test-packages.scm\"\); \
+ echo \(link-simple-system \'\(scheme/debug low-test\) \'start low-test-system\)) \
+ | $(LINKER)
+
+scheme/debug/little.image: $(LINKER_IMAGE) $(CONFIG_FILES) scheme/debug-packages.scm
+ ($(LOAD_DEBUG); echo \(link-little-system\)) \
+ | time $(LINKER)
+
+scheme/debug/mini.image: $(LINKER_IMAGE) $(CONFIG_FILES)
+ ($(LOAD_DEBUG); echo \(link-mini-system\)) \
+ | $(LINKER)
+
+scheme/debug/medium.image: $(LINKER_IMAGE) $(CONFIG_FILES)
+ ($(LOAD_DEBUG); echo \(flatload compiler-structures\); \
+ echo \(link-medium-system\)) \
+ | $(LINKER)
+
+# The following have not been updated for the new directory organization
+
+c/smain.o: c/main.c
+ $(CC) -c $(CPPFLAGS) $(DEFS) $(CFLAGS) -DSTATIC_AREAS -o $@ c/main.c
+
+mini: mini-heap.o smain.o
+ $(CC) $(LDFLAGS) $(CFLAGS) -o $@ c/smain.o mini-heap.o $(OBJS) $(LIBS)
+
+mini-heap.o: mini-heap.c
+ $(CC) -c $(CPPFLAGS) $(DEFS) $(CFLAGS) -o $@ $(srcdir)/mini-heap.c
+
+mini-heap.c: scheme/debug/mini1.image
+ (echo ,exec ,load misc/load-static.scm; \
+ echo \(do-it 150000 \"$(srcdir)/scheme/debug/mini1.image\" \"$@\"\)) \
+ | $(RUNNABLE) -h 3000000 -a batch
+
+scheme/debug/mini1.image: $(VM) scheme/debug/mini.image
+ echo "(write-image \"scheme/debug/mini1.image\" \
+ (usual-resumer (lambda (args) \
+ (command-processor #f args))) \
+ \"foo\")" \
+ | ./$(VM) -i scheme/debug/mini.image -a batch
+
+
+# --------------------
+# Generate scheme48.h from VM sources
+
+c/kali.h: scheme/vm/arch.scm scheme/vm/data.scm \
+ scheme/link/generate-c-header.scm
+ (echo ',bench'; \
+ echo ',batch'; \
+ echo ',load-package big-scheme'; \
+ echo ',open big-scheme'; \
+ echo ',load scheme/link/generate-c-header.scm'; \
+ echo "(make-c-header-file \"$@\" \
+ \"$(srcdir)/scheme/vm/arch.scm\" \
+ \"$(srcdir)/scheme/vm/data.scm\")" \
+ ) | $(RUNNABLE)
+
+
+# Generate vm (scheme48vm.c and scheme48heap.c) from VM sources.
+# Never called automatically. Do not use unless you are sure you
+# know what you are doing.
+# Afterwards, you should probably make c/kali.h.
+i-know-what-i-am-doing:
+ cd ps-compiler && \
+ (echo ',batch'; \
+ echo ',config ,load ../scheme/prescheme/interface.scm'; \
+ echo ',config ,load ../scheme/prescheme/package-defs.scm'; \
+ echo ',exec ,load load-ps-compiler.scm'; \
+ echo ',exec ,load compile-vm-no-gc.scm'; \
+ echo ',exec ,load compile-gc.scm'; \
+ echo ',exit' \
+ ) | $(RUNNABLE) -h 8000000 && \
+ mv ../scheme/vm/scheme48vm.c ../scheme/vm/scheme48heap.c ../c
88 README
@@ -0,0 +1,88 @@
+Copyright (c) 1993, 1994, 1995 Richard Kelsey and Jonathan Rees.
+Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING.
+
+Please report bugs to scheme-48-bugs@martigny.ai.mit.edu, and include
+the version number in your message.
+
+Installation instructions in file INSTALL.
+
+A user's guide is in file doc/user-guide.txt.
+
+Recent changes are listed in file doc/news.txt.
+
+Known bugs and things to do in the future are listed in doc/todo.txt.
+
+Send mail to scheme-48-request@martigny.ai.mit.edu to be put on a
+mailing list for announcements, discussion, bug reports, and bug
+fixes.
+
+-----
+
+When running "make", don't worry if the ".notify" target fails. Its
+only purpose is to send an email message to
+scheme-48-notifications@martigny.ai.mit.edu, so that we can get a
+rough idea of how much Scheme 48 is being used and by whom. We
+promise not to use your name or email address for any commercial
+purpose. If you don't want us to know, just do "make -t .notify"
+first (after running "configure").
+
+-----
+
+The Scheme 48 root directory is organized as follows (not all files are
+listed here):
+
+ README this file
+ INSTALL installation instructions
+ COPYING copyright notice
+ configure configuration script
+ Makefile.in input to configure
+ doc/ some documentation
+ scheme48.man a Unix-style manual page
+ user-guide.txt general guide to using Scheme 48
+ todo.txt list of improvements we hope to make someday
+ news.txt list of improvements we have already made
+ module.ps description of Scheme 48's module system
+ big-scheme.txt extensions to Scheme
+ threads.txt multiprocessing
+ io.txt how the I/O system works
+ scheme/ scheme source files
+ packages.scm meta-module definitions
+ interfaces.scm system interface definitions
+ more-interfaces.scm system interface definitions
+ *-packages.scm module definitions
+ bcomp/ the byte-code compiler
+ vm/ virtual machine sources (written in Pre-Scheme)
+ rts/ run-time system sources
+ link/ static linker
+ env/ development environment modules (debugger, etc.)
+ big/ useful Scheme libraries and extensions ("Big Scheme")
+ alt/ portable implementations of some Scheme 48 features
+ opt/ optional code optimizer for the byte-code compiler
+ prescheme/ code for running the VM using Scheme 48
+ debug/ debugging utilities, tests, etc.
+ misc/ very miscellaneous things (e.g. AMB operator)
+ kali/ address spaces and communication protocol (Kali code)
+ ps-compiler/ Pre-Scheme -> C compiler
+ c/ c source files
+ sysdep.h.in input to configure
+ scheme48vm.c most of the VM (generated by Pre-Scheme compiler)
+ scheme48vm.h extern declarations for scheme48vm.c
+ scheme48heap.c storage management (generated by Pre-Scheme compiler)
+ scheme48heap.h extern declarations for scheme48heap.c
+ main.c entry point for the VM
+ prescheme.h part of the VM
+ extension.c default definition of vm_extension()
+ scheme48.h C declarations and macros for Scheme 48 data structures
+ event.h header file for OS interface
+ fd-io.h ditto
+ socket.h ditto
+ unix/ Unix-specific source files
+ fake/ C files for insufficiently Posix compliant systems
+ build/ code for building the system
+ filenames.make included by Makefile, generated automatically
+ filenames.scm code for generating filenames.make
+ initial.image an image file containing a minimal Scheme system
+ initial.debug debugging database for same
+ initial.scm script for creating initial.image
+ build-usual-image script for creating scheme48.image
+ emacs/ gnu emacs support
32 acconfig.h
@@ -0,0 +1,32 @@
+/*
+ * HAVE_SIGACTION is defined iff sigaction() is available.
+ */
+#undef HAVE_SIGACTION
+
+/*
+ * HAVE_STRERROR is defined iff the standard libraries provide strerror().
+ */
+#undef HAVE_STRERROR
+
+/*
+ * NLIST_HAS_N_NAME is defined iff a struct nlist has an n_name member.
+ * If it doesn't then we assume it has an n_un member which, in turn,
+ * has an n_name member.
+ */
+#undef NLIST_HAS_N_NAME
+
+/*
+ * HAVE_SYS_SELECT_H is defined iff we have the include file sys/select.h.
+ */
+#undef HAVE_SYS_SELECT_H
+
+/*
+ * USCORE is defined iff C externals are prepended with an underscore.
+ */
+#undef USCORE
+
+@BOTTOM@
+
+#include "fake/sigact.h"
+#include "fake/strerror.h"
+#include "fake/sys-select.h"
36 build/build-usual-image
@@ -0,0 +1,36 @@
+#!/bin/sh
+# Build the usual development environment image.
+
+date=`date`
+srcdir=$1
+lib=$2
+image=$3
+vm=$4
+initial=$5
+USER=${USER-`logname 2>/dev/null || echo '*GOK*'`}
+
+$vm -i $initial -a batch <<EOF
+,load $srcdir/scheme/env/init-defpackage.scm
+((*structure-ref filenames 'set-translation!)
+ "=scheme48/" "$srcdir/scheme/")
+,load =scheme48/more-interfaces.scm =scheme48/link-packages.scm
+,load =scheme48/more-packages.scm
+,load =scheme48/kali/package-defs.scm
+(ensure-loaded command-processor)
+(ensure-loaded kali)
+(ensure-loaded usual-commands)
+,go ((*structure-ref command 'command-processor)
+ (structure-package usual-commands)
+ (list "batch"))
+(ensure-loaded usual-features)
+,in address-spaces (initialize-shared-address-space!)
+,structure more-structures more-structures-interface
+,in debuginfo (read-debug-info "$srcdir/build/initial.debug")
+,keep maps source files
+,translate =scheme48/ $lib/
+,build ((*structure-ref package-commands-internal
+ 'new-command-processor)
+ "(made by $USER on $date)"
+ usual-commands
+ built-in-structures more-structures) $image
+EOF
7 build/filenames.make
@@ -0,0 +1,7 @@
+#### This file was generated automatically. ####
+
+initial-files = scheme/rts/low.scm scheme/rts/signal.scm scheme/rts/base.scm scheme/rts/util.scm scheme/rts/number.scm scheme/rts/lize.scm scheme/rts/record.scm scheme/rts/jar-defrecord.scm scheme/rts/method.scm scheme/rts/numio.scm scheme/rts/fluid.scm scheme/rts/defenum.scm scheme/vm/arch.scm scheme/big/queue.scm scheme/rts/condition.scm scheme/rts/session.scm scheme/rts/interrupt.scm scheme/rts/wind.scm scheme/rts/template.scm scheme/rts/continuation.scm scheme/rts/exception.scm scheme/rts/thread.scm scheme/rts/sleep.scm scheme/rts/lock.scm scheme/rts/port.scm scheme/rts/current-port.scm scheme/rts/write.scm scheme/rts/read.scm scheme/rts/channel-port.scm scheme/rts/channel.scm scheme/big/general-table.scm scheme/rts/population.scm scheme/bcomp/mtype.scm scheme/bcomp/interface.scm scheme/bcomp/binding.scm scheme/bcomp/name.scm scheme/bcomp/transform.scm scheme/bcomp/cenv.scm scheme/bcomp/thingie.scm scheme/bcomp/package.scm scheme/bcomp/package-undef.scm scheme/rts/env.scm scheme/big/filename.scm scheme/bcomp/read-form.scm scheme/bcomp/node.scm scheme/bcomp/schemify.scm scheme/bcomp/var-util.scm scheme/bcomp/syntax.scm scheme/bcomp/primop.scm scheme/bcomp/ddata.scm scheme/bcomp/stack-check.scm scheme/bcomp/state.scm scheme/bcomp/segment.scm scheme/bcomp/optimize.scm scheme/opt/flatten.scm scheme/bcomp/recon.scm scheme/bcomp/comp-exp.scm scheme/bcomp/comp-prim.scm scheme/bcomp/comp.scm scheme/rts/eval.scm scheme/env/dispcond.scm scheme/debug/mini-command.scm scheme/rts/scheduler.scm scheme/rts/root-scheduler.scm scheme/rts/init.scm scheme/env/start.scm scheme/bcomp/usual.scm scheme/bcomp/rules.scm scheme/bcomp/type.scm scheme/bcomp/module-language.scm scheme/bcomp/config.scm scheme/bcomp/scan-package.scm scheme/bcomp/comp-package.scm scheme/env/load-package.scm scheme/big/strong.scm scheme/opt/usage.scm scheme/opt/sort.scm scheme/opt/inline.scm scheme/bcomp/for-reify.scm
+
+usual-files = scheme/opt/analyze.scm scheme/env/disclosers.scm scheme/env/command-level.scm scheme/env/version-info.scm scheme/env/command.scm scheme/env/read-command.scm scheme/env/debuginfo.scm scheme/rts/xnum.scm scheme/rts/bignum.scm scheme/rts/ratnum.scm scheme/rts/recnum.scm scheme/rts/innum.scm scheme/env/basic-command.scm scheme/env/build.scm scheme/env/shadow.scm scheme/env/pedit.scm scheme/env/pacman.scm scheme/rts/time.scm scheme/env/debug.scm scheme/env/inspect.scm scheme/env/disasm.scm
+
+linker-files = scheme/rts/util.scm scheme/alt/fluid.scm scheme/rts/defenum.scm scheme/vm/arch.scm scheme/alt/jar-defrecord.scm scheme/big/general-table.scm scheme/bcomp/mtype.scm scheme/alt/locations.scm scheme/bcomp/binding.scm scheme/bcomp/name.scm scheme/bcomp/transform.scm scheme/bcomp/node.scm scheme/bcomp/schemify.scm scheme/bcomp/var-util.scm scheme/bcomp/primop.scm scheme/alt/template.scm scheme/rts/template.scm scheme/bcomp/ddata.scm scheme/bcomp/thingie.scm scheme/bcomp/stack-check.scm scheme/bcomp/state.scm scheme/bcomp/segment.scm scheme/bcomp/optimize.scm scheme/opt/flatten.scm scheme/bcomp/recon.scm scheme/bcomp/comp-exp.scm scheme/bcomp/comp-prim.scm scheme/bcomp/comp.scm scheme/alt/closure.scm scheme/link/data.scm scheme/link/transport.scm scheme/link/write-image.scm scheme/alt/weak.scm scheme/rts/population.scm scheme/bcomp/interface.scm scheme/bcomp/cenv.scm scheme/bcomp/package.scm scheme/bcomp/package-undef.scm scheme/bcomp/syntax.scm scheme/env/debuginfo.scm scheme/big/filename.scm scheme/bcomp/read-form.scm scheme/bcomp/scan-package.scm scheme/bcomp/usual.scm scheme/bcomp/rules.scm scheme/bcomp/comp-package.scm scheme/big/strong.scm scheme/opt/usage.scm scheme/opt/sort.scm scheme/opt/inline.scm scheme/link/reify.scm scheme/link/link.scm scheme/alt/loophole.scm scheme/bcomp/type.scm scheme/alt/low.scm scheme/bcomp/module-language.scm scheme/bcomp/config.scm scheme/opt/analyze.scm scheme/alt/environments.scm scheme/link/loadc.scm scheme/env/flatload.scm
49 build/filenames.scm
@@ -0,0 +1,49 @@
+; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees.
+; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING.
+
+
+; Generate filenames.make from *-packages.scm.
+
+
+; Define DEFINE-STRUCTURE and friends
+(for-each load
+ '("scheme/bcomp/module-language.scm"
+ "scheme/alt/config.scm"
+ "scheme/env/flatload.scm"))
+
+(load-configuration "scheme/packages.scm")
+
+; The following defines are unnecessary; they only serve to suppress
+; annoying "undefined" warnings for some forward references.
+(define methods 0)
+(define tables 0)
+
+(flatload linker-structures)
+
+(define q-f (all-file-names link-config))
+
+; (display "Initial structures") (newline)
+(flatload initial-structures)
+
+(define scheme (make-scheme environments evaluation))
+
+(define initial-system
+ (structure (export)
+ (open ;; Cf. initial.scm
+ (make-initial-system scheme (make-mini-command scheme))
+ module-system
+ ensures-loaded
+ for-reification))) ;foo...
+
+(define i-f (all-file-names initial-system))
+
+; (display "Usual structures") (newline)
+(flatload usual-structures)
+
+(define u-f (all-file-names usual-features initial-system))
+
+(write-file-names "build/filenames.make"
+ 'initial-files i-f
+ 'usual-files u-f
+ 'linker-files q-f)
+
4,371 build/initial.debug
4,371 additions, 0 deletions not shown
BIN  build/initial.image
Binary file not shown
60 build/initial.scm
@@ -0,0 +1,60 @@
+; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees.
+; Copyright (c) 1996 by NEC Research Institute, Inc. See file COPYING.
+
+
+; Link script.
+
+(define (link-initial-system)
+ (let ((structures-to-open ;Structures to open for the initial
+ (struct-list scheme ;system's read-eval-print loop.
+ environments
+ module-system
+ ensures-loaded
+ packages
+ packages-internal))) ; package-for-syntax
+ (link-reified-system (append (desirable-structures)
+ structures-to-open)
+ '(build initial)
+ ;; The expression that evaluates to the
+ ;; procedure that maps the reified-structure alist
+ ;; to the startup procedure:
+ `(start ',(map car structures-to-open))
+ ;; Structures to open for evaluating that
+ ;; expression and the expression that
+ ;; evaluates to the reified-structure alist:
+ initial-system
+ for-reification
+ ;; scheme-level-1
+ )))
+
+(define (desirable-structures)
+ (let ((env (interaction-environment))
+ (l '()))
+ (for-each (lambda (int)
+ (for-each-declaration
+ (lambda (name type)
+ (if (not (assq name l))
+ (let ((s (eval name env)))
+ (if (structure? s)
+ (set! l (cons (cons name s) l))))))
+ int))
+ (list low-structures-interface
+ run-time-structures-interface
+ features-structures-interface
+ run-time-internals-structures-interface
+ compiler-structures-interface
+ initial-structures-interface))
+ (reverse l)))
+
+
+; Your choice of evaluators:
+
+(define scheme (make-scheme environments evaluation))
+; (define scheme (make-scheme mini-environments mini-eval))
+; (define scheme (make-scheme environments run))
+; etc.
+
+; Your choice of command processors.
+
+(define initial-system
+ (make-initial-system scheme (make-mini-command scheme)))
88 build/load-linker.exec
@@ -0,0 +1,88 @@
+; Load the linker. -*- Mode: Scheme; -*-
+
+; Run this script with ,exec ,load l.exec.
+; After the script is loaded, you can, in principle, do whatever
+; you might do in the usual linker image. For example, you might do
+; (this is from the Makefile)
+;
+; ,in link-config
+; (load-configuration "interfaces.scm")
+; (load-configuration "packages.scm")
+; (flatload initial-structures)
+; (load "initial.scm")
+; (link-initial-system)
+;
+; This is intended to be used to debug new versions of the compiler or
+; static linker.
+
+(config '(run (define :arguments :values))) ;temporary hack
+
+(translate "=scheme48/" "./")
+
+(load-package 'flatloading)
+(open 'flatloading)
+
+(define (r x) (config `(run ,x)))
+
+(r '(define-structure source-file-names (export (%file-name% :syntax))
+ (open scheme-level-1
+ syntactic
+ fluids)
+ (begin (define-syntax %file-name%
+ (syntax-rules ()
+ ((%file-name%) (fluid $source-file-name)))))))
+
+(r '(define-structure enumerated enumerated-interface
+ (open scheme-level-1 signals)
+ (files (rts defenum scm))))
+
+(r '(define-structure architecture architecture-interface
+ (open scheme-level-1 signals enumerated)
+ (files (rts arch))))
+
+(config '(structure reflective-tower-maker
+ (export-reflective-tower-maker)))
+
+; Make the new linker obtain its table, record, etc. structures from
+; the currently running Scheme.
+
+(config '(load "packages.scm"))
+(config '(structure %run-time-structures run-time-structures-interface))
+(config '(structure %features-structures features-structures-interface))
+
+(r
+ '(define-structure %linker-structures
+ (make-linker-structures %run-time-structures
+ %features-structures
+ (make-compiler-structures %run-time-structures
+ %features-structures))))
+
+; Load the linker's interface and structure definitions.
+(config '(load "interfaces.scm" "more-interfaces.scm"))
+(let ((z (config '(run %linker-structures)))
+ (env (config interaction-environment)))
+ (config (lambda () (flatload z env))))
+
+; Load the linker.
+(load-package 'link-config)
+
+; Initialize
+(in 'link-config
+ '(open scheme packages packages-internal
+ reflective-tower-maker))
+
+(in 'linker '(run (set! *debug-linker?* #t)))
+(in 'link-config '(open flatloading)) ; A different one.
+
+; ,open debuginfo packages-internal compiler scan syntactic meta-types
+
+; (in 'link-config '(dump "l.image"))
+
+; ,exec (usual-stuff)
+
+(define (usual-stuff)
+ (in 'link-config)
+ (run '(begin (load-configuration "interfaces.scm")
+ (load-configuration "packages.scm")
+ (flatload initial-structures)))
+ (load "initial.scm"))
82 build/lucid-script.lisp
@@ -0,0 +1,82 @@
+
+; Script to load the Scheme 48 linker into Common Lisp.
+; Requires Pseudoscheme 2.11.
+
+(defvar pseudoscheme-directory "../pseudo/")
+(load (concatenate 'string pseudoscheme-directory "loadit.lisp"))
+; or perhaps (load (merge-pathnames "loadit.lisp" pseudoscheme-directory))
+(load-pseudoscheme pseudoscheme-directory)
+
+(progn (revised^4-scheme::define-sharp-macro #\.
+ #'(lambda (c port)
+ (read-char port)
+ (eval (let ((*readtable* ps::scheme-readtable))
+ (read port)))))
+ (values))
+
+(ps:scheme)
+;--------------------
+; Scheme forms
+
+(benchmark-mode)
+
+(define config-env ; (interaction-environment) would also work here.
+ (#.'scheme-translator:make-program-env
+ '%config
+ (list #.'scheme-translator:revised^4-scheme-structure)))
+
+(load "bcomp/module-language" config-env)
+(load "alt/config" config-env)
+(load "env/flatload" config-env)
+(eval '(set! *load-file-type* #f) config-env)
+
+(define load-config
+ (let ((load-config (eval 'load-configuration config-env)))
+ (lambda (filename)
+ (load-config filename config-env))))
+
+(load-config "packages")
+
+(define flatload-package (eval 'flatload config-env))
+
+(flatload-package (eval 'linker-structures config-env) config-env)
+
+(let ((#.'clever-load:*compile-if-necessary-p* #t))
+ (let ((#.'ps:*scheme-read* #.'#'ps::scheme-read-using-commonlisp-reader))
+ (load "alt/pseudoscheme-record")
+ (load "alt/pseudoscheme-features")))
+
+(let ((#.'clever-load:*compile-if-necessary-p* #t))
+ (flatload-package (eval 'link-config config-env)))
+
+(load "alt/init-defpackage.scm")
+
+(define-syntax struct-list ;not in link.sbin
+ (syntax-rules ()
+ ((struct-list ?name ...) (list (cons '?name ?name) ...))))
+
+;--------------------
+(quit)
+
+#+Lucid
+(defun disksave-restart-function ()
+ (format t "~&Scheme 48 linker.~2%")
+ ;; (hax:init-interrupt-delivery) - for threads
+ (ps:scheme)
+ (terpri))
+#+Lucid
+(defun dump-linker ()
+ (lcl:disksave "link/linker-in-lucid" :gc t :full-gc t :verbose t
+ :restart-function #'disksave-restart-function))
+;(dump-linker)
+;(lcl:quit)
+
+
+; Debugging hacks
+;(defun enable-lisp-packages ()
+; (setq *readtable* ps:scheme-readtable)
+; (values))
+;(defun disable-lisp-packages ()
+; (setq *readtable* ps::roadblock-readtable)
+; (values))
+
1  build/minor-version-number
@@ -0,0 +1 @@
+52.2
19 c/event.h
@@ -0,0 +1,19 @@
+enum event_enum { KEYBOARD_INTERRUPT_EVENT, IO_COMPLETION_EVENT, ALARM_EVENT,
+ ERROR_EVENT, NO_EVENT };
+extern int get_next_event(long *ready_fd, long *status);
+
+extern bool add_pending_fd(int fd, bool is_input);
+extern bool remove_fd(int fd);
+extern long schedule_alarm_interrupt(long delta);
+extern long run_time(long *mseconds);
+extern long real_time(long *mseconds);
+extern int wait_for_event(long max_wait, bool is_minutes);
+
+
+/* these are here only for the CHEAP_TIME() macro */
+#define TICKS_PER_SECOND 1000 /* clock resolution */
+#define POLLS_PER_SECOND 20 /* how often we poll */
+#define TICKS_PER_POLL (TICKS_PER_SECOND / POLLS_PER_SECOND)
+
+extern long current_time;
+#define CHEAP_TIME() (current_time * TICKS_PER_POLL)
715 c/extension.c
@@ -0,0 +1,715 @@
+/*Copyright 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.*/
+
+
+/* Implementation of the vm-extension opcode. This is completely
+ optional; nothing in the standard system uses these features.
+ If you have ANSI C but not POSIX support, try compiling with -DPOSIX=0.
+
+ fdopen: POSIX.1
+ getenv: POSIX.1, ANSI C
+ setuid, setgid: POSIX.1
+ popen: POSIX.2
+ floating point: POSIX.1, ANSI C (should we be linking with -lM or -lm?)
+ sprintf: POSIX.1, ANSI C
+ atof: POSIX.1, ANSI C
+ chroot: not standard
+
+ */
+
+#ifndef POSIX
+# define POSIX 2
+#endif
+
+#include <stdio.h>
+#include "sysdep.h"
+#include "kali.h" /* Kali change */
+#include "socket.h"
+
+#include <string.h>
+#include <stdlib.h>
+#include <math.h>
+#include <signal.h>
+#include <unistd.h> /* setuid & setgid */
+#include <errno.h>
+#include <netdb.h> /* gethostbyname */ /* Kali code */
+#include <time.h> /* ctime */ /* Kali code */
+
+#include <sys/types.h>
+#include <sys/wait.h>
+
+#if 1 /* Kali hack for non-blocking output (HCC) */
+#include <fcntl.h>
+#endif /* Kali hack for non-blocking output (HCC) */
+
+
+#define GREATEST_FIXNUM_VALUE ((1 << 29) - 1)
+#define LEAST_FIXNUM_VALUE (-1 << 29)
+#define CHANNEL_INDEX(x) EXTRACT_FIXNUM(STOB_REF(x, 1))
+#define FOR_INPUT 1
+#define FOR_OUTPUT 2
+
+typedef struct {
+ char b[sizeof(double)];
+} unaligned_double;
+
+typedef union {
+ double f;
+ unaligned_double b;
+} float_or_bytes;
+
+extern long Sextension_valueS; /* how values are returned */
+
+/* return status values */
+#define EXT_ST_OKAY 0
+#define EXT_ST_EXCEPTION 1
+
+#define EXT_RETURN(value) {Sextension_valueS = (value); return EXT_ST_OKAY; }
+#define EXT_EXCEPTION return EXT_ST_EXCEPTION
+
+/******************************************/
+
+scheme_value
+extended_vm (long key, scheme_value value)
+{
+ double x, y;
+
+ switch (key) {
+
+ /* Cases 0 through 19 are reserved for the mobot system. */
+
+ case 0: /* read jumpers on 68000 board */
+ EXT_RETURN(ENTER_FIXNUM(0));
+
+#if defined(HAVE_SOCKET)
+ case 20:
+ { extern int internet_stream_socket();
+ int s = internet_stream_socket();
+ if (s < 0)
+ EXT_EXCEPTION;
+ else
+ EXT_RETURN(ENTER_FIXNUM(s));
+ }
+
+ case 21:
+ { extern int socket_bind(int, int);
+ int sock, port;
+
+ if (!PAIRP(value) || !FIXNUMP(CAR(value)) || !FIXNUMP(CDR(value)))
+ EXT_EXCEPTION;
+ sock = EXTRACT_FIXNUM(CAR(value));
+ port = EXTRACT_FIXNUM(CDR(value));
+ port = socket_bind(sock, port);
+ if (port < 0)
+ EXT_EXCEPTION;
+ else
+ EXT_RETURN(ENTER_FIXNUM(port));
+ }
+
+ case 22:
+ { extern int socket_accept(int);
+ int sock, fd;
+
+ if (!FIXNUMP(value))
+ EXT_EXCEPTION;
+
+ sock = EXTRACT_FIXNUM(value);
+
+ if (sock < 0)
+ EXT_EXCEPTION;
+ fd = socket_accept(sock);
+ if (fd >= 0)
+ EXT_RETURN(ENTER_FIXNUM(fd))
+ else if (fd == -2)
+ EXT_RETURN(ENTER_FIXNUM(-1))
+ else
+ EXT_EXCEPTION;
+ }
+
+ case 23: {
+ int sock;
+ char *mach;
+ int port,
+ res;
+
+ if (! (PAIRP(value) && FIXNUMP(CAR(value))
+ && PAIRP(CDR(value)) && STRINGP(CAR(CDR(value)))
+ && FIXNUMP(CDR(CDR(value)))))
+ EXT_EXCEPTION;
+ sock = EXTRACT_FIXNUM(CAR(value));
+ mach = &STRING_REF(CAR(CDR(value)), 0);
+ port = EXTRACT_FIXNUM(CDR(CDR(value)));
+ res = socket_connect(sock, mach, port);
+ if (res >= 0)
+ EXT_RETURN(ENTER_FIXNUM(res))
+ else if (res == -2)
+ EXT_RETURN(ENTER_FIXNUM(-1))
+ else
+ EXT_EXCEPTION;
+ }
+
+#endif
+
+ /* getenv() */
+ case 26: {
+ scheme_value env_var, result_buffer;
+ char *result;
+ size_t result_len;
+
+ if (!PAIRP(value)) EXT_EXCEPTION;
+ env_var = CAR(value);
+ result_buffer = CDR(value);
+ if (!STRINGP(env_var) || !STRINGP(result_buffer)) EXT_EXCEPTION;
+ result = getenv(&STRING_REF(env_var, 0));
+ if (result == NULL)
+ EXT_RETURN(SCHFALSE);
+ result_len = strlen(result);
+ if (result_len > STRING_LENGTH(result_buffer))
+ EXT_EXCEPTION;
+ strncpy(&STRING_REF(result_buffer, 0), result, result_len);
+ EXT_RETURN(ENTER_FIXNUM(result_len));
+ }
+
+#if POSIX
+ case 27: {
+ /* This is intended for use by HTTP scripts... */
+ if (!PAIRP(value) || !FIXNUMP(CAR(value)) || !FIXNUMP(CDR(value)))
+ EXT_EXCEPTION;
+ if (setgid(EXTRACT_FIXNUM(CDR(value))) != 0) {
+ perror("setgid");
+ EXT_RETURN(SCHFALSE); }
+ if (setuid(EXTRACT_FIXNUM(CAR(value))) != 0) {
+ perror("setuid");
+ EXT_RETURN(SCHFALSE); }
+ else
+ EXT_RETURN(SCHTRUE);
+ }
+#endif
+
+#if defined(HAVE_CHROOT)
+ case 28: {
+ if (!STRINGP(value))
+ EXT_EXCEPTION;
+ else if (chroot(&STRING_REF(value, 0)) != 0) {
+ perror("chroot");
+ EXT_RETURN(SCHFALSE); }
+ else
+ EXT_RETURN(SCHTRUE);
+ }
+#endif
+
+ /* dup() support */
+ case 29:
+ { long fd = dup(EXTRACT_FIXNUM(value));
+ if (fd < 0)
+ EXT_EXCEPTION;
+ else
+ EXT_RETURN(ENTER_FIXNUM(fd));
+ }
+
+ /* extract file descriptor from channel */
+ case 30:
+ { int fd;
+
+ if (!FIXNUMP(value))
+ EXT_EXCEPTION;
+
+ fd = EXTRACT_FIXNUM(value);
+
+ if (fd < 0)
+ EXT_EXCEPTION;
+ else
+ EXT_RETURN(ENTER_FIXNUM(fd));
+ }
+
+ /* Begin Kali code */
+ case 31:
+ {
+ int status;
+
+ if (!STRINGP(value))
+ EXT_EXCEPTION;
+
+ status = gethostname(&STRING_REF(value, 0), STRING_LENGTH(value));
+
+ if (status != 0)
+ EXT_EXCEPTION;
+ else
+ EXT_RETURN(ENTER_FIXNUM(strlen(&STRING_REF(value, 0))));
+ }
+
+ case 32:
+ {
+ int i;
+ struct hostent *hostdata;
+
+ if (!STRINGP(value))
+ EXT_EXCEPTION;
+
+ hostdata = gethostbyname(&STRING_REF(value, 0));
+ if (hostdata == NULL) {
+ fprintf(stderr, "gethostbyname() failed on %s: ", &STRING_REF(value, 0));
+ herror("");
+ fprintf(stderr, "\n");
+ EXT_EXCEPTION; };
+
+ if (hostdata->h_length > STRING_LENGTH(value)) {
+ fprintf(stderr, "buffer for gethostbyname() is too small\n");
+ EXT_EXCEPTION; };
+
+ for(i = 0; i < hostdata->h_length; i++)
+ STRING_REF(value, i) = hostdata->h_addr_list[0][i];
+
+ EXT_RETURN(ENTER_FIXNUM(hostdata->h_length));
+ }
+
+ case 33:
+ {
+ int i, len, status;
+ time_t the_time;
+ char *time_string;
+
+ if (!STRINGP(value))
+ EXT_EXCEPTION;
+
+ status = time(&the_time);
+
+ if (status == -1) {
+ fprintf(stderr, "time() failed");
+ herror("");
+ fprintf(stderr, "\n");
+ EXT_EXCEPTION; };
+
+ time_string = ctime(&the_time);
+
+ len = strlen(time_string) - 1; /* drop the newline */
+
+ if (len > STRING_LENGTH(value))
+ len = STRING_LENGTH(value);
+
+ for (i = 0; i < len; i++)
+ STRING_REF(value, i) = time_string[i];
+
+ EXT_RETURN(ENTER_FIXNUM(len));
+ }
+
+ /* End Kali code */
+
+ /* system() is supposedly POSIX.2 and ANSI C */
+
+#if POSIX >= 2
+ case 96: {
+ int status;
+ if (!STRINGP(value))
+ EXT_EXCEPTION;
+ status = system(&STRING_REF(value, 0));
+ if (status == -1) {
+ perror("chroot");
+ EXT_EXCEPTION; }
+ else
+ EXT_RETURN(ENTER_FIXNUM(status)); /* cf. waitpid() */
+ }
+#endif /* POSIX.2 */
+
+
+ /* Floating point */
+
+#define FLOP 100
+#define FLOP2(i) case FLOP+(i): \
+ if (!STOBP(value) || STOB_LLENGTH(value) != 2) \
+ EXT_EXCEPTION;
+#define FLOP3(i) case FLOP+(i): \
+ if (!STOBP(value) || STOB_LLENGTH(value) != 3) \
+ EXT_EXCEPTION;
+
+#define get_arg(args,i) STOB_REF(args,(i))
+#define get_string_arg(args,i) (&STRING_REF(get_arg(args,i), 0))
+
+#define get_float_arg(args, i, var) EXTRACT_FLOAT(get_arg(args, i), var)
+#define set_float_arg(args, i, val) SET_FLOAT(get_arg(args, i), val)
+
+#define EXTRACT_FLOAT(stob, var) \
+ { scheme_value temp_ = (stob); \
+ float_or_bytes loser_; \
+ if (!STOBP(temp_)) EXT_EXCEPTION; \
+ loser_.b = *(unaligned_double*)(&STOB_REF(temp_, 0)); \
+ (var) = loser_.f; }
+
+#define SET_FLOAT(stob, val) \
+ { scheme_value temp_ = (stob); \
+ float_or_bytes loser_; \
+ if (!STOBP(temp_)) EXT_EXCEPTION; \
+ loser_.f = (double)(val); \
+ *(unaligned_double*)(&STOB_REF(temp_, 0)) = loser_.b; }
+
+ FLOP3(0) {
+ get_float_arg(value, 0, x);
+ get_float_arg(value, 1, y);
+ set_float_arg(value, 2, x + y);
+ EXT_RETURN(UNSPECIFIC);}
+ FLOP3(1) {
+ get_float_arg(value, 0, x);
+ get_float_arg(value, 1, y);
+ set_float_arg(value, 2, x - y);
+ EXT_RETURN(UNSPECIFIC);}
+ FLOP3(2) {
+ get_float_arg(value, 0, x);
+ get_float_arg(value, 1, y);
+ set_float_arg(value, 2, x * y);
+ EXT_RETURN(UNSPECIFIC);}
+ FLOP3(3) {
+ get_float_arg(value, 0, x);
+ get_float_arg(value, 1, y);
+ if (y == 0.0) EXT_EXCEPTION;
+ set_float_arg(value, 2, x / y);
+ EXT_RETURN(UNSPECIFIC);}
+ FLOP2(4) {
+ get_float_arg(value, 0, x);
+ get_float_arg(value, 1, y);
+ EXT_RETURN(ENTER_BOOLEAN(x == y));}
+ FLOP2(5) {
+ get_float_arg(value, 0, x);
+ get_float_arg(value, 1, y);
+ EXT_RETURN(ENTER_BOOLEAN(x < y));}
+ FLOP2(6) { /* fixnum->float */
+ scheme_value arg = get_arg(value, 0);
+ if (!FIXNUMP(arg)) EXT_RETURN(SCHFALSE);
+ set_float_arg(value, 1, EXTRACT_FIXNUM(arg));
+ EXT_RETURN(SCHTRUE);}
+ FLOP2(7) { /* string->float */
+ char *str = get_string_arg(value, 0);
+ set_float_arg(value, 1, atof(str));
+ EXT_RETURN(UNSPECIFIC);}
+ FLOP2(8) { /* float->string */
+ size_t len;
+ char *str = get_string_arg(value,1);
+ get_float_arg(value, 0, x);
+ sprintf(str, "%g", x);
+ len = strlen(str);
+ if (len > STRING_LENGTH(get_arg(value,1)))
+ /* unlikely but catastrophic */
+ fprintf(stderr, "printing float: output too long: %s\n",
+ str);
+ EXT_RETURN(ENTER_FIXNUM(len));}
+
+ /* exp log sin cos tan asin acos atan sqrt */
+
+ FLOP2(9) {
+ get_float_arg(value, 0, x);
+ set_float_arg(value, 1, exp(x));
+ EXT_RETURN(UNSPECIFIC);}
+ FLOP2(10) {
+ get_float_arg(value, 0, x);
+ set_float_arg(value, 1, log(x));
+ EXT_RETURN(UNSPECIFIC);}
+ FLOP2(11) {
+ get_float_arg(value, 0, x);
+ set_float_arg(value, 1, sin(x));
+ EXT_RETURN(UNSPECIFIC);}
+ FLOP2(12) {
+ get_float_arg(value, 0, x);
+ set_float_arg(value, 1, cos(x));
+ EXT_RETURN(UNSPECIFIC);}
+ FLOP2(13) {
+ get_float_arg(value, 0, x);
+ set_float_arg(value, 1, tan(x));
+ EXT_RETURN(UNSPECIFIC);}
+ FLOP2(14) {
+ get_float_arg(value, 0, x);
+ set_float_arg(value, 1, asin(x));
+ EXT_RETURN(UNSPECIFIC);}
+ FLOP2(15) {
+ get_float_arg(value, 0, x);
+ set_float_arg(value, 1, acos(x));
+ EXT_RETURN(UNSPECIFIC);}
+ FLOP3(16) { /* atan */
+ get_float_arg(value, 0, y);
+ get_float_arg(value, 1, x);
+ set_float_arg(value, 2, atan2(y, x));
+ EXT_RETURN(UNSPECIFIC);}
+ FLOP2(17) {
+ get_float_arg(value, 0, x);
+ set_float_arg(value, 1, sqrt(x));
+ EXT_RETURN(UNSPECIFIC);}
+
+ FLOP2(18) { /* floor */
+ get_float_arg(value, 0, x);
+ set_float_arg(value, 1, floor(x));
+ EXT_RETURN(UNSPECIFIC);}
+ case FLOP+19: { /* integer? */
+ EXTRACT_FLOAT(value, x);
+ EXT_RETURN(ENTER_BOOLEAN(fmod(x, 1.0) == 0.0)); }
+ case FLOP+20: { /* float->fixnum */
+ EXTRACT_FLOAT(value, x);
+ if (x <= (double)GREATEST_FIXNUM_VALUE
+ && x >= (double)LEAST_FIXNUM_VALUE)
+ {
+ EXT_RETURN(ENTER_FIXNUM((long)x)); }
+ else
+ EXT_RETURN(SCHFALSE);}
+ FLOP3(21) { /* quotient */
+ double z;
+ get_float_arg(value, 0, x);
+ get_float_arg(value, 1, y);
+ if (fmod(x, 1.0) != 0.0 || fmod(y, 1.0) != 0.0) EXT_EXCEPTION;
+ if (y == 0.0) EXT_EXCEPTION;
+ z = x / y;
+ set_float_arg(value, 2, z < 0.0 ? ceil(z) : floor(z));
+ EXT_RETURN(UNSPECIFIC);}
+ FLOP3(22) { /* remainder */
+ get_float_arg(value, 0, x);
+ get_float_arg(value, 1, y);
+ if (fmod(x, 1.0) != 0.0 || fmod(y, 1.0) != 0.0) EXT_EXCEPTION;
+ if (y == 0.0) EXT_EXCEPTION;
+
+ /* "fmod(double x, double y) returns the floating-point remainder
+ (f) of the division of x by y, where f has the same sign as x,
+ such that x=iy+f for some integer i, and |f| < |y|." */
+
+ set_float_arg(value, 2, fmod(x, y));
+ EXT_RETURN(UNSPECIFIC);}
+
+#if 1 /* Kali hack for non-blocking output (HCC) */
+ case 214: /* make file descriptor non-blocking */
+ {
+ int fd;
+
+ if (! FIXNUMP(value))
+ EXT_EXCEPTION;
+ fd = EXTRACT_FIXNUM(value);
+ if (fd < 0)
+ EXT_EXCEPTION;
+ if (fcntl(fd, F_SETFL, O_NONBLOCK) < 0)
+ EXT_EXCEPTION;
+ EXT_RETURN(UNSPECIFIC);
+ }
+#endif /* Kali hack for non-blocking output (HCC) */
+
+#if 1 /* Kali hack for TCP_NODELAY extension on sockets (HCC) */
+
+ /*
+ * Given a file descriptor (which must be associated to a TCP/IP
+ * socket) and a flag, set the TCP_NODELAY attribute to the flag
+ * (i.e., nodelay unless the flag is #F).
+ */
+ case 300:
+ {
+ int fd,
+ nodelay;
+
+ if ((! PAIRP(value))
+ || (! FIXNUMP(CAR(value))))
+ EXT_EXCEPTION;
+ fd = EXTRACT_FIXNUM(CAR(value));
+ nodelay = EXTRACT_BOOLEAN(CDR(value));
+ if (! socket_nodelay(fd, nodelay))
+ EXT_EXCEPTION;
+ EXT_RETURN (UNSPECIFIC);
+ }
+
+#endif /* Kali hack for TCP_NODELAY extension on sockets (HCC) */
+
+ default:
+ EXT_EXCEPTION;
+ }
+}
+
+
+/* --------------------------------------------------
+ Entry points intended for use with (external-call ...).
+ The actual arguments are argv[n-1], argv[n-2], ..., argv[0].
+ For Unix system calls, a return value of #f means success, #t means
+ invalid argument, and integer means Unixoid error.
+
+ Missing, among others:
+ chdir chmod mkdir rmdir stat fstat link unlink seek tell getpid getppid
+ environ
+ */
+
+/* (let ((results (cons 0 0)))
+ (let ((errno (external-call s48-pipe results)))
+ (if errno
+ (error ... errno)
+ (values (car results) (cdr results))))) */
+
+scheme_value s48_pipe(long argc, scheme_value *argv)
+{
+ int fd[2];
+ scheme_value result;
+
+ if (argc != 1) return SCHTRUE;
+ result = argv[0];
+ if (!PAIRP(result)) return SCHTRUE;
+
+ if (pipe(&fd[0]) == -1) return ENTER_FIXNUM(errno);
+
+ CAR(result) = ENTER_FIXNUM(fd[0]);
+ CDR(result) = ENTER_FIXNUM(fd[1]);
+ return SCHFALSE;
+}
+
+/* (let* ((results (cons 0 0))
+ (errno (external-call s48-waitpid results pid options)))
+ (if errno
+ (interpret-syscall-error errno)
+ (values (car results) (cdr results)))) */
+
+scheme_value s48_waitpid(long argc, scheme_value *argv)
+{
+ int pid, status;
+ scheme_value result, pidf, optf;
+
+ if (argc != 3) return SCHTRUE;
+ result = argv[2];
+ pidf = argv[1];
+ optf = argv[0];
+ if (!PAIRP(result) || !FIXNUMP(pidf) || !FIXNUMP(optf))
+ return SCHTRUE;
+
+ if ((pid = waitpid(EXTRACT_FIXNUM(pidf),
+ &status,
+ EXTRACT_FIXNUM(optf)))
+ == -1)
+ return ENTER_FIXNUM(errno);
+
+ CAR(result) = ENTER_FIXNUM(pid);
+ CDR(result) = ENTER_FIXNUM(status);
+ return SCHFALSE;
+}
+
+/* (let ((results (cons 0 0)))
+ (let ((errno (external-call s48-fork results)))
+ (if errno
+ (decode-syscall-error errno)
+ (car results)))) ;child pid or zero */
+
+scheme_value s48_fork(long argc, scheme_value *argv)
+{
+ int pid;
+ scheme_value result;
+
+ if (argc != 1) return SCHTRUE;
+ result = argv[0];
+ if (!PAIRP(result)) return SCHTRUE;
+
+ if ((pid = fork()) == -1)
+ return ENTER_FIXNUM(errno);
+
+ CAR(result) = ENTER_FIXNUM(pid);
+ return SCHFALSE;
+}
+
+/* exit(status) */
+scheme_value s48_exit(long argc, scheme_value *argv)
+{
+ exit(EXTRACT_FIXNUM(argv[0]));
+}
+
+/* close(fd) */
+scheme_value s48_close(long argc, scheme_value *argv)
+{
+ scheme_value fd;
+
+ if (argc != 1) return SCHTRUE;
+ fd = argv[0];
+ if (!FIXNUMP(fd)) return SCHTRUE;
+
+ if (close(EXTRACT_FIXNUM(fd)) == -1)
+ return ENTER_FIXNUM(errno);
+
+ return SCHFALSE;
+}
+
+/* dup(fd) -> result */
+scheme_value s48_dup(long argc, scheme_value *argv)
+{
+ scheme_value result, fd;
+ int new;
+
+ if (argc != 2) return SCHTRUE;
+ result = argv[1];
+ fd = argv[0];
+ if (!FIXNUMP(fd) || !PAIRP(result)) return SCHTRUE;
+
+ if ((new = dup(EXTRACT_FIXNUM(fd))) == -1)
+ return ENTER_FIXNUM(errno);
+
+ CAR(result) = ENTER_FIXNUM(new);
+ return SCHFALSE;
+}
+
+/* kill(pid, sig) */
+scheme_value s48_kill(long argc, scheme_value *argv)
+{
+ scheme_value pid, sig;
+
+ if (argc != 2) return SCHTRUE;
+ pid = argv[1];
+ sig = argv[0];
+ if (!FIXNUMP(pid) || !FIXNUMP(sig)) return SCHTRUE;
+
+ if (kill(EXTRACT_FIXNUM(pid), EXTRACT_FIXNUM(sig)) == -1)
+ return ENTER_FIXNUM(errno);
+
+ return SCHFALSE;
+}
+
+
+/* dup(fd) */
+
+/* execv(path, argv) */
+scheme_value s48_execv(long argc, scheme_value *argv)
+{
+ scheme_value prog, arg_vec, result;
+ int unix_argc;
+ char **unix_argv;
+
+ if (argc != 2) return SCHTRUE;
+ prog = argv[1];
+ arg_vec = argv[0];
+ if (!STRINGP(prog) || !VECTORP(arg_vec)) return SCHTRUE;
+ unix_argc = VECTOR_LENGTH(arg_vec);
+
+ unix_argv = malloc((argc+1) * sizeof(char *));
+
+ { int i;
+ for(i = 0; i < unix_argc; i++) {
+ scheme_value arg = VECTOR_REF(arg_vec, i);
+ if (!STRINGP(arg)) return SCHFALSE;
+ unix_argv[i] = &STRING_REF(arg, 0);
+ }
+ unix_argv[i] = (char *)0;
+ }
+
+ if (execv(&STRING_REF(prog, 0), unix_argv) == -1)
+ result = ENTER_FIXNUM(errno);
+ result = SCHFALSE;
+ free(unix_argv);
+ return result;
+}
+
+
+
+/* (let ((s (make-string 100)))
+ (substring s 0 (or (external-call s48_strerror s errno)
+ (error "?"))))
+ */
+
+scheme_value s48_strerror(long argc, scheme_value *argv)
+{
+ scheme_value result, err;
+ int result_len;
+ char *err_string;
+
+ if (argc != 2) return SCHFALSE;
+ result = argv[1];
+ err = argv[0];
+ if (!STRINGP(result) || !FIXNUMP(err)) return SCHFALSE;
+
+ err_string = strerror(EXTRACT_FIXNUM(err));
+ result_len = strlen(err_string);
+ if (result_len > STRING_LENGTH(result))
+ return SCHFALSE;
+ strncpy(&STRING_REF(result, 0), err_string, result_len);
+
+ return ENTER_FIXNUM(result_len);
+}
15 c/fake/sigact.h
@@ -0,0 +1,15 @@
+/*
+ * If we don't have sigaction, we fake it using signal.
+ */
+#if ! defined(HAVE_SIGACTION)
+
+struct sigaction {
+ void (*sa_handler)();
+ int sa_mask;
+ int sa_flags;
+};
+
+#define sigaction(sig, act, oact) signal((sig), (act)->sa_handler)
+#define sigemptyset(ign) 0
+
+#endif
22 c/fake/strerror.c
@@ -0,0 +1,22 @@
+/*
+ * If the system doesn't have a strerror procedure, we provide our own.
+ * Note, this depends on sys_nerr and sys_errlist being provided.
+ * If your system doesn't provide that either, you can replace this
+ * procedure with one that always returns "Unknown error".
+ */
+#include "sysdep.h"
+
+
+extern int sys_nerr;
+extern char *sys_errlist[];
+
+
+char *
+strerror(int errnum)
+{
+ if ((0 <= errnum)
+ && (errnum < sys_nerr))
+ return (sys_errlist[errnum]);
+ else
+ return ("Unknown error");
+}
8 c/fake/strerror.h
@@ -0,0 +1,8 @@
+/*
+ * If we don't have strerror(), we fake it using sys_nerr and sys_errlist.
+ */
+#if ! defined(HAVE_STRERROR)
+
+extern char *strerror(int errnum);
+
+#endif
9 c/fake/sys-select.h
@@ -0,0 +1,9 @@
+/*
+ * If we have a sys/select.h, then include it.
+ */
+#if defined(HAVE_SYS_SELECT_H)
+
+#include <sys/types.h>
+#include <sys/select.h>
+
+#endif
16 c/fd-io.h
@@ -0,0 +1,16 @@
+
+#define STDIN_FD() 0
+#define STDOUT_FD() 1
+#define STDERR_FD() 2
+
+extern int ps_open_fd(char *in_filename, bool is_input, long *status);
+
+extern int ps_close_fd(long fd_as_long);
+
+extern long ps_read_fd(long fd_as_long, char *buf_as_long, long max, bool waitp,
+ bool *eofp, bool *pending, long *status);
+
+extern long ps_write_fd(long fd_as_long, char *buf_as_long, long max,
+ bool *pending, long *status);
+
+extern long ps_abort_fd_op(long fd_as_long);
12 c/io.h
@@ -0,0 +1,12 @@
+extern FILE *ps_open_input_file(char *, long *);
+extern FILE *ps_open_output_file(char *, long *);
+extern long ps_close(FILE *);
+extern char ps_read_char(FILE *, char *, long *, char);
+extern long ps_read_integer(FILE *, char *, long *);
+extern long ps_write_char(char, FILE *);
+extern long ps_write_integer(long, FILE *);
+extern long ps_write_string(char *, FILE *);
+extern long ps_read_block(FILE *, char *, long, char *, long *);
+extern long ps_write_block(FILE *, char *, long);
+extern char *ps_error_string(long);
+extern void ps_error(char *, long count, ...);
129 c/kali.h
@@ -0,0 +1,129 @@
+typedef long scheme_value;
+
+#define FIXNUM_TAG 0
+#define FIXNUMP(x) (((long)(x) & 3L) == FIXNUM_TAG)
+#define IMMEDIATE_TAG 1
+#define IMMEDIATEP(x) (((long)(x) & 3L) == IMMEDIATE_TAG)
+#define HEADER_TAG 2
+#define HEADERP(x) (((long)(x) & 3L) == HEADER_TAG)
+#define STOB_TAG 3
+#define STOBP(x) (((long)(x) & 3L) == STOB_TAG)
+
+#define ENTER_FIXNUM(n) ((scheme_value)((n) << 2))
+#define EXTRACT_FIXNUM(x) ((long)(x) >> 2)
+
+#define MISC_IMMEDIATE(n) (scheme_value)(IMMEDIATE_TAG | ((n) << 2))
+#define SCHFALSE MISC_IMMEDIATE(0)
+#define SCHTRUE MISC_IMMEDIATE(1)
+#define SCHCHAR MISC_IMMEDIATE(2)
+#define SCHUNSPECIFIC MISC_IMMEDIATE(3)
+#define SCHUNDEFINED MISC_IMMEDIATE(4)
+#define SCHEOF MISC_IMMEDIATE(5)
+#define SCHNULL MISC_IMMEDIATE(6)
+#define UNDEFINED SCHUNDEFINED
+#define UNSPECIFIC SCHUNSPECIFIC
+
+#define ENTER_BOOLEAN(n) ((n) ? SCHTRUE : SCHFALSE)
+#define EXTRACT_BOOLEAN(x) ((x) != SCHFALSE)
+
+#define ENTER_CHAR(c) (SCHCHAR | ((c) << 8))
+#define EXTRACT_CHAR(x) ((x) >> 8)
+#define CHARP(x) ((((long) (x)) & 0xff) == SCHCHAR)
+
+#define ADDRESS_AFTER_HEADER(x, type) ((type *)((x) - STOB_TAG))
+#define STOB_REF(x, i) ((ADDRESS_AFTER_HEADER(x, long))[i])
+#define STOB_TYPE(x) ((STOB_HEADER(x)>>2)&31)
+#define STOB_HEADER(x) (STOB_REF((x),-1))
+#define STOB_BLENGTH(x) (STOB_HEADER(x) >> 8)
+#define STOB_LLENGTH(x) (STOB_HEADER(x) >> 10)
+
+#define STOBTYPE_PAIR 0
+#define PAIRP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_PAIR))
+#define STOBTYPE_SYMBOL 1
+#define SYMBOLP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_SYMBOL))
+#define STOBTYPE_VECTOR 2
+#define VECTORP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_VECTOR))
+#define STOBTYPE_CLOSURE 3
+#define CLOSUREP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_CLOSURE))
+#define STOBTYPE_LOCATION 4
+#define LOCATIONP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_LOCATION))
+#define STOBTYPE_CHANNEL 5
+#define CHANNELP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_CHANNEL))
+#define STOBTYPE_PORT 6
+#define PORTP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_PORT))
+#define STOBTYPE_RATNUM 7
+#define RATNUMP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_RATNUM))
+#define STOBTYPE_RECORD 8
+#define RECORDP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_RECORD))
+#define STOBTYPE_CONTINUATION 9
+#define CONTINUATIONP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_CONTINUATION))
+#define STOBTYPE_EXTENDED_NUMBER 10
+#define EXTENDED_NUMBERP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_EXTENDED_NUMBER))
+#define STOBTYPE_TEMPLATE 11
+#define TEMPLATEP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_TEMPLATE))
+#define STOBTYPE_WEAK_POINTER 12
+#define WEAK_POINTERP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_WEAK_POINTER))
+#define STOBTYPE_EXTERNAL 13
+#define EXTERNALP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_EXTERNAL))
+#define STOBTYPE_PROXY 14
+#define PROXYP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_PROXY))
+#define STOBTYPE_PROXY_DATA 15
+#define PROXY_DATAP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_PROXY_DATA))
+#define STOBTYPE_ADDRESS_SPACE 16
+#define ADDRESS_SPACEP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_ADDRESS_SPACE))
+#define STOBTYPE_UNUSED_D_HEADER1 17
+#define UNUSED_D_HEADER1P(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_UNUSED_D_HEADER1))
+#define STOBTYPE_UNUSED_D_HEADER2 18
+#define UNUSED_D_HEADER2P(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_UNUSED_D_HEADER2))
+#define STOBTYPE_STRING 19
+#define STRINGP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_STRING))
+#define STOBTYPE_CODE_VECTOR 20
+#define CODE_VECTORP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_CODE_VECTOR))
+#define STOBTYPE_DOUBLE 21
+#define DOUBLEP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_DOUBLE))
+#define STOBTYPE_BIGNUM 22
+#define BIGNUMP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_BIGNUM))
+
+#define CAR(x) STOB_REF(x, 0)
+#define CDR(x) STOB_REF(x, 1)
+#define SYMBOL_UID(x) STOB_REF(x, 0)
+#define SYMBOL_TO_STRING(x) STOB_REF(x, 1)
+#define LOCATION_UID(x) STOB_REF(x, 0)
+#define LOCATION_ID(x) STOB_REF(x, 1)
+#define CONTENTS(x) STOB_REF(x, 2)
+#define CLOSURE_TEMPLATE(x) STOB_REF(x, 0)
+#define CLOSURE_ENV(x) STOB_REF(x, 1)
+#define WEAK_POINTER_REF(x) STOB_REF(x, 0)
+#define EXTERNAL_NAME(x) STOB_REF(x, 0)
+#define EXTERNAL_VALUE(x) STOB_REF(x, 1)
+#define EXTERNAL_UID(x) STOB_REF(x, 2)
+#define PORT_HANDLER(x) STOB_REF(x, 0)
+#define PORT_STATUS(x) STOB_REF(x, 1)
+#define PORT_LOCK(x) STOB_REF(x, 2)
+#define PORT_LOCKEDP(x) STOB_REF(x, 3)
+#define PORT_DATA(x) STOB_REF(x, 4)
+#define PORT_BUFFER(x) STOB_REF(x, 5)
+#define PORT_INDEX(x) STOB_REF(x, 6)
+#define PORT_LIMIT(x) STOB_REF(x, 7)
+#define PORT_PENDING_EOFP(x) STOB_REF(x, 8)
+#define CHANNEL_STATUS(x) STOB_REF(x, 0)
+#define CHANNEL_ID(x) STOB_REF(x, 1)
+#define CHANNEL_OS_INDEX(x) STOB_REF(x, 2)
+#define PROXY_DATA(x) STOB_REF(x, 0)
+#define PROXY_DATA_UID(x) STOB_REF(x, 0)
+#define PROXY_DATA_OWNER(x) STOB_REF(x, 1)
+#define PROXY_DATA_VALUE(x) STOB_REF(x, 2)
+#define PROXY_DATA_REFERENCE_COUNT(x) STOB_REF(x, 3)
+#define PROXY_DATA_SELF(x) STOB_REF(x, 4)
+#define PROXY_DATA_WAITERS(x) STOB_REF(x, 5)
+#define ADDRESS_SPACE_UID(x) STOB_REF(x, 0)
+#define ADDRESS_SPACE_DECODE_VECTOR(x) STOB_REF(x, 1)
+#define ADDRESS_SPACE_PROXY_VECTOR(x) STOB_REF(x, 2)
+#define ADDRESS_SPACE_DATA(x) STOB_REF(x, 3)
+
+#define VECTOR_LENGTH(x) STOB_LLENGTH(x)
+#define VECTOR_REF(x, i) STOB_REF(x, i)
+#define CODE_VECTOR_LENGTH(x) STOB_BLENGTH(x)
+#define CODE_VECTOR_REF(x, i) (ADDRESS_AFTER_HEADER(x, unsigned char)[i])
+#define STRING_LENGTH(x) (STOB_BLENGTH(x)-1)
+#define STRING_REF(x, i) (ADDRESS_AFTER_HEADER(x, char)[i])
174 c/main.c
@@ -0,0 +1,174 @@
+/* Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.
+ See file COPYING. */
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <unistd.h>
+
+#if !defined(DEFAULT_HEAP_SIZE)
+/* 2 mega cells = 8 megabytes (4 per semispace), enlarged for Kali */
+#define DEFAULT_HEAP_SIZE 2000000L
+#endif
+
+#if !defined(DEFAULT_STACK_SIZE)
+/* 2500 cells = 10000 bytes */
+#define DEFAULT_STACK_SIZE 2500L
+#endif
+
+#if defined(STATIC_AREAS)
+#define DEFAULT_IMAGE_NAME NULL
+#else
+
+/* DEFAULT_IMAGE_NAME should be defined using the -D switch to cc. */
+#if !defined(DEFAULT_IMAGE_NAME)
+#define DEFAULT_IMAGE_NAME "scheme48.image"
+#endif
+
+#endif /* STATIC_AREAS */
+
+
+char *object_file; /* specified via a command line argument */
+char *reloc_file; /* dynamic loading will set this */
+
+
+extern void scheme48_init(void);
+extern void sysdep_init(void);
+extern void s48_heap_init(void);
+extern long required_init_space(unsigned char **, long);
+extern void initialize_heap(long, long);
+extern void initialize_vm(long, long);
+extern long call_startup_procedure(long, char **, long);
+extern long check_image_header(unsigned char *);
+extern long read_image(long);
+extern void register_static_areas(unsigned char, long *, long *, unsigned char, long *, long *);
+
+int
+main(argc, argv)
+ int argc; char **argv;
+{
+ char *image_name = DEFAULT_IMAGE_NAME;
+ long heap_size = DEFAULT_HEAP_SIZE; /* in numbers of cells */
+ long stack_size = DEFAULT_STACK_SIZE; /* in numbers of cells */
+ int errors = 0;
+ long return_value;
+ void *heap, *stack;
+ long required_heap_size, startup_proc;
+
+#if defined(STATIC_AREAS)
+ extern long entry;
+ extern long p_count, *p_areas[], p_sizes[];
+ extern long i_count, *i_areas[], i_sizes[];
+#endif
+
+ long vm_argc = 0;
+ char *me = *argv; /* Save program name. */
+
+ object_file = reloc_file = NULL;
+
+ argv++; argc--; /* Skip program name. */
+
+ for (; argc > 0; argc--, argv++)
+ if (argv[0][0] == '-')
+ switch (argv[0][1]) {
+ case 'h':
+ argc--; argv++;
+ if (argc == 0) { errors++; break; }
+ heap_size = atoi(*argv);
+ if (heap_size <= 0) errors++;
+ break;
+ case 's':
+ argc--; argv++;
+ if (argc == 0) { errors++; break; }
+ stack_size = atoi(*argv);
+ if (stack_size <= 0) errors++;
+ break;
+ case 'i':
+ argc--; argv++;
+ if (argc == 0) { errors++; break; }
+ image_name = *argv;
+ break;
+ case 'a':
+ argc--;
+ vm_argc = argc; /* remaining args are passed to the VM */
+ argc = 0;
+ break;
+ case 'o':
+ argc--; argv++;
+ if (argc == 0) { errors++; break; }
+ object_file = *argv;
+ break;
+ default:
+ fprintf(stderr, "Invalid argument: %s\n", *argv);
+ errors++;
+ }
+ else
+ if (argv[0][0] != '\0')
+ { fprintf(stderr, "Invalid argument: %s\n", *argv);
+ errors++; }
+ if (errors != 0) {
+ fprintf(stderr,
+"Usage: %s [options] [-a arguments]\n\
+Options: -h <total heap size in words>\n\
+ -s <stack buffer size in words>\n\
+ -i <image file name>\n\
+ -o <object file name>\n",
+ me);
+ return 1;
+ }
+
+ sysdep_init();
+ s48_heap_init();
+ scheme48_init();
+
+ if (image_name == NULL)
+ required_heap_size = 0;
+ else {
+ /* check_image_header returns number of bytes; required_heap_size
+ is number of cells. */