From e5a2148d4a766b888dcc5fde9e083ebbdd3a3b49 Mon Sep 17 00:00:00 2001 From: bdc Date: Sat, 14 Oct 1995 03:34:21 +0000 Subject: [PATCH] scsh 0.4.x prerelease --- .gdbinit | 106 --- .notify | 0 INSTALL | 120 --- NEWS.s48-0.36 | 497 ------------ TODO.s48-0.36 | 263 ------ alt-packages.scm | 166 ---- alt/annotate.scm | 13 - alt/ascii.scm | 69 -- alt/bitwise-tests.scm | 58 -- alt/bitwise.scm | 44 - alt/closure.scm | 11 - alt/code-vector.scm | 19 - alt/config.scm | 192 ----- alt/contin.scm | 20 - alt/environments.scm | 6 - alt/escape.scm | 32 - alt/features-packages.scm | 29 - alt/features.scm | 58 -- alt/fluid.scm | 33 - alt/init-defpackage.scm | 14 - alt/locations.scm | 30 - alt/loophole.scm | 9 - alt/low-packages.scm | 26 - alt/low.scm | 25 - alt/primitives.scm | 175 ---- alt/pseudoscheme-features.scm | 120 --- alt/pseudoscheme-record.scm | 18 - alt/queue.scm | 28 - alt/record.scm | 96 --- alt/reroot.scm | 54 -- alt/schemetoc-features.scm | 142 ---- alt/schemetoc-record.scm | 120 --- alt/silly.scm | 8 - alt/syntax.scm | 204 ----- alt/t-features.scm | 118 --- alt/t-record.scm | 57 -- alt/table.scm | 14 - alt/template.scm | 21 - alt/values.scm | 19 - alt/weak.scm | 8 - bcomp/comp.scm | 573 ------------- bcomp/config.scm | 35 - bcomp/cprim.scm | 384 --------- bcomp/ddata.scm | 89 --- bcomp/for-reify.scm | 35 - bcomp/interface.scm | 88 -- bcomp/module-language.scm | 229 ------ bcomp/mtype.scm | 711 ----------------- bcomp/package.scm | 425 ---------- bcomp/recon.scm | 383 --------- bcomp/rules.scm | 253 ------ bcomp/schemify.scm | 125 --- bcomp/segment.scm | 230 ------ bcomp/state.scm | 79 -- bcomp/syntax.scm | 825 ------------------- bcomp/type.scm | 53 -- bcomp/undefined.scm | 56 -- bcomp/usual.scm | 233 ------ big/array.scm | 315 -------- big/bigbit.scm | 207 ----- big/compose-cont.scm | 44 - big/defrecord.scm | 93 --- big/destructure.scm | 53 -- big/dump.scm | 429 ---------- big/external.scm | 126 --- big/filename.scm | 115 --- big/format.scm | 151 ---- big/general-table.scm | 213 ----- big/lu-decomp.scm | 144 ---- big/new-ports.scm | 298 ------- big/pp.scm | 431 ---------- big/queue.scm | 92 --- big/random.scm | 54 -- big/receive.scm | 8 - big/search-tree.scm | 397 --------- big/sleep.scm | 101 --- big/sort.scm | 151 ---- big/xport.scm | 170 ---- build-usual-image | 32 - cig/cig.scm | 989 ----------------------- cig/doc/boxedminipage.sty | 45 -- cig/doc/draftfooters.sty | 76 -- cig/doc/headings.tex | 16 - comp-packages.scm | 160 ---- debug-packages.scm | 134 ---- debug/byte-code-test.scm | 76 -- debug/check.scm | 104 --- debug/describe.scm | 41 - debug/fact.scm | 8 - debug/fix-low.scm | 72 -- debug/for-debugging.scm | 59 -- debug/level-0.scm | 30 - debug/link-debug.scm | 36 - debug/linker.scm | 34 - debug/mini-command.scm | 65 -- debug/mini-package.scm | 74 -- debug/mini-start.scm | 19 - debug/mumble-packages.scm | 73 -- debug/mutation.scm | 130 --- debug/profile.scm | 107 --- debug/read-image.scm | 223 ------ debug/spatial-hack.scm | 63 -- debug/test-generic.scm | 34 - debug/test-methods.scm | 37 - debug/test.scm | 32 - debug/tiny-packages.scm | 7 - debug/tiny.scm | 20 - debug/vector-space.scm | 132 --- debug/wind-test.scm | 52 -- doc/big-scheme.txt | 314 -------- doc/code.tex | 94 --- doc/external.txt | 95 --- doc/hacking.txt | 290 ------- doc/latex-stuff.tex | 45 -- doc/meeting.ps | 1090 ------------------------- doc/meeting.tex | 439 ---------- doc/module.ps | 1417 --------------------------------- doc/module.tex | 728 ----------------- doc/no-leaf-env.txt | 175 ---- doc/package.txt | 81 -- doc/scsh-src-roadmap.txt | 83 -- doc/summary.tex | 83 -- doc/threads.txt | 113 --- doc/type.txt | 240 ------ doc/user-guide.txt | 682 ---------------- emacs/README | 47 -- emacs/cmulisp.el | 693 ---------------- emacs/cmuscheme.el | 433 ---------- emacs/cmuscheme48.el | 99 --- emacs/cmushell.el | 594 -------------- emacs/comint.el | 1372 ------------------------------- emacs/jar-hacks.el | 91 --- env/assem.scm | 317 -------- env/basic-command.scm | 55 -- env/build.scm | 76 -- env/debug.scm | 575 ------------- env/debuginfo.scm | 77 -- env/disasm.scm | 132 --- env/disclosers.scm | 261 ------ env/dispcond.scm | 77 -- env/flatload.scm | 107 --- env/init-defpackage.scm | 23 - env/inspect.scm | 401 ---------- env/jar-assem.scm | 133 ---- env/list-interface.scm | 46 -- env/load-package.scm | 26 - env/more-thread.scm | 112 --- env/pedit.scm | 351 -------- env/read-command.scm | 186 ----- env/shadow.scm | 70 -- env/space.scm | 206 ----- env/start.scm | 67 -- env/traverse.scm | 213 ----- env/version-info.scm | 1 - filenames.make | 7 - filenames.scm | 46 -- infix/packages.scm | 29 - infix/pratt.scm | 308 ------- infix/sgol-runtime.scm | 11 - infix/sgol.scm | 213 ----- infix/tokenize.scm | 154 ---- initial-packages.scm | 94 --- initial.scm | 59 -- install-sh | 238 ------ link-packages.scm | 101 --- link/data.scm | 142 ---- link/generate-c-header.scm | 152 ---- link/link.scm | 147 ---- link/load-linker.exec | 89 --- link/loadc.scm | 21 - link/lucid-script.lisp | 62 -- link/reify.scm | 281 ------- link/transport.scm | 279 ------- link/write-image.scm | 73 -- low-packages.scm | 30 - main-original.c | 160 ---- minor-version-number | 1 - misc/annotate.scm | 38 - misc/argument.scm | 49 -- misc/doodl.scm | 299 ------- misc/either.scm | 90 --- misc/getenv.scm | 15 - misc/hilbert.scm | 107 --- misc/ilength.scm | 33 - misc/integertostring.scm | 64 -- misc/load-static.scm | 40 - misc/mail.scm | 34 - misc/packages.scm | 103 --- misc/psd-s48.scm | 130 --- misc/remote.scm | 145 ---- misc/require.scm | 40 - misc/separate.scm | 140 ---- misc/sicp.scm | 112 --- misc/slib-init.scm | 151 ---- misc/socket.scm | 55 -- misc/static.scm | 210 ----- misc/test-doodl.scm | 52 -- more-interfaces.scm | 375 --------- more-packages.scm | 592 -------------- opt/analyze.scm | 397 --------- opt/expand.scm | 289 ------- opt/inline.scm | 96 --- opt/tst.scm | 26 - packages.scm | 357 --------- postgcstub.c | 1 - prescheme.c | 37 - prescheme.h | 36 - rts-packages.scm | 188 ----- rts/base.scm | 380 --------- rts/bignum.scm | 336 -------- rts/bummed-jar-defrecord.scm | 69 -- rts/condition.scm | 76 -- rts/continuation.scm | 43 - rts/defenum.scm | 72 -- rts/enum.scm | 25 - rts/env.scm | 97 --- rts/exception.scm | 147 ---- rts/floatnum.scm | 296 ------- rts/fluid.scm | 89 --- rts/init.scm | 18 - rts/innum.scm | 108 --- rts/interrupt.scm | 72 -- rts/jar-defrecord.scm | 47 -- rts/lize.scm | 35 - rts/low.scm | 118 --- rts/method.scm | 512 ------------ rts/number.scm | 78 -- rts/numio.scm | 175 ---- rts/population.scm | 37 - rts/port.scm | 80 -- rts/ratnum.scm | 141 ---- rts/read.scm | 266 ------- rts/recnum.scm | 117 --- rts/record.scm | 119 --- rts/signal.scm | 35 - rts/template.scm | 27 - rts/util.scm | 67 -- rts/wind.scm | 100 --- rts/write.scm | 151 ---- rts/xnum.scm | 292 ------- rts/xprim.scm | 125 --- scheme48.1 | 80 -- scheme48.h | 94 --- scheme48.man | 80 -- scsh/aix/sigset.h | 10 - scsh/aix/sysdep.h | 4 - scsh/aix/time_dep1.c | 38 - scsh/bsd/Makefile.inc | 0 scsh/bsd/sysdep.h | 0 scsh/bsd/time_dep1.c | 38 - scsh/char-set.scm | 2 +- scsh/cstuff.h | 9 - scsh/cxux/Makefile.inc | 4 - scsh/cxux/sysdep.h | 2 - scsh/cxux/time_dep1.c | 38 - scsh/ekko.scm | 13 - scsh/fdports.h | 16 - scsh/generic/Makefile.inc | 0 scsh/generic/sysdep.h | 0 scsh/generic/time_dep1.c | 38 - scsh/hpux/Makefile.inc | 0 scsh/hpux/sigset.h | 10 - scsh/hpux/sysdep.h | 0 scsh/hpux/time_dep1.c | 38 - scsh/irix/Makefile.inc | 0 scsh/irix/sigset.h | 10 - scsh/irix/sysdep.h | 0 scsh/irix/time_dep1.c | 38 - scsh/linux/Makefile.inc | 0 scsh/linux/sysdep.h | 0 scsh/linux/time_dep1.c | 38 - scsh/next/Makefile.inc | 0 scsh/next/sigset.h | 7 - scsh/next/sysdep.h | 2 - scsh/next/time_dep1.c | 38 - scsh/nextbs.c | 17 - scsh/nt2.c | 16 - scsh/oldfr.scm | 568 ------------- scsh/oldhere.scm | 100 --- scsh/scsh-tramp.c | 73 -- scsh/solaris/Makefile.inc | 0 scsh/solaris/sigset.h | 10 - scsh/solaris/sysdep.h | 1 - scsh/solaris/time_dep1.c | 38 - scsh/sunos/Makefile.inc | 0 scsh/sunos/sigset.h | 10 - scsh/sunos/sysdep.h | 0 scsh/sunos/time_dep1.c | 38 - scsh/time.c | 109 --- scsh/time1.h | 23 - scsh/ultrix/Makefile.inc | 0 scsh/ultrix/sigset.h | 10 - scsh/ultrix/sysdep.h | 0 scsh/ultrix/time_dep1.c | 38 - vm/README | 49 -- vm/arch.scm | 263 ------ vm/arith.scm | 117 --- vm/data.scm | 240 ------ vm/defenum.scm | 71 -- vm/define-primitive.scm | 68 -- vm/disasm.scm | 106 --- vm/env.scm | 91 --- vm/external.scm | 17 - vm/gc.scm | 218 ----- vm/interp.scm | 737 ----------------- vm/macro-package-defs.scm | 6 - vm/memory.scm | 99 --- vm/prescheme.scm | 48 -- vm/prim.scm | 673 ---------------- vm/ps-interface.scm | 90 --- vm/ps-memory.scm | 116 --- vm/ps-package-defs.scm | 28 - vm/ps-package.scm | 5 - vm/resume.scm | 65 -- vm/s48-package-defs.scm | 31 - vm/stack.scm | 470 ----------- vm/stob.scm | 128 --- vm/struct.scm | 300 ------- vm/vm-utilities.scm | 52 -- vm/vmio.scm | 195 ----- 320 files changed, 1 insertion(+), 44558 deletions(-) delete mode 100644 .gdbinit delete mode 100644 .notify delete mode 100644 INSTALL delete mode 100644 NEWS.s48-0.36 delete mode 100644 TODO.s48-0.36 delete mode 100644 alt-packages.scm delete mode 100644 alt/annotate.scm delete mode 100644 alt/ascii.scm delete mode 100644 alt/bitwise-tests.scm delete mode 100644 alt/bitwise.scm delete mode 100644 alt/closure.scm delete mode 100644 alt/code-vector.scm delete mode 100644 alt/config.scm delete mode 100644 alt/contin.scm delete mode 100644 alt/environments.scm delete mode 100644 alt/escape.scm delete mode 100644 alt/features-packages.scm delete mode 100644 alt/features.scm delete mode 100644 alt/fluid.scm delete mode 100644 alt/init-defpackage.scm delete mode 100644 alt/locations.scm delete mode 100644 alt/loophole.scm delete mode 100644 alt/low-packages.scm delete mode 100644 alt/low.scm delete mode 100644 alt/primitives.scm delete mode 100644 alt/pseudoscheme-features.scm delete mode 100644 alt/pseudoscheme-record.scm delete mode 100644 alt/queue.scm delete mode 100644 alt/record.scm delete mode 100644 alt/reroot.scm delete mode 100644 alt/schemetoc-features.scm delete mode 100644 alt/schemetoc-record.scm delete mode 100644 alt/silly.scm delete mode 100644 alt/syntax.scm delete mode 100644 alt/t-features.scm delete mode 100644 alt/t-record.scm delete mode 100644 alt/table.scm delete mode 100644 alt/template.scm delete mode 100644 alt/values.scm delete mode 100644 alt/weak.scm delete mode 100644 bcomp/comp.scm delete mode 100644 bcomp/config.scm delete mode 100644 bcomp/cprim.scm delete mode 100644 bcomp/ddata.scm delete mode 100644 bcomp/for-reify.scm delete mode 100644 bcomp/interface.scm delete mode 100644 bcomp/module-language.scm delete mode 100644 bcomp/mtype.scm delete mode 100644 bcomp/package.scm delete mode 100644 bcomp/recon.scm delete mode 100644 bcomp/rules.scm delete mode 100644 bcomp/schemify.scm delete mode 100644 bcomp/segment.scm delete mode 100644 bcomp/state.scm delete mode 100644 bcomp/syntax.scm delete mode 100644 bcomp/type.scm delete mode 100644 bcomp/undefined.scm delete mode 100644 bcomp/usual.scm delete mode 100644 big/array.scm delete mode 100644 big/bigbit.scm delete mode 100644 big/compose-cont.scm delete mode 100644 big/defrecord.scm delete mode 100644 big/destructure.scm delete mode 100644 big/dump.scm delete mode 100644 big/external.scm delete mode 100644 big/filename.scm delete mode 100644 big/format.scm delete mode 100644 big/general-table.scm delete mode 100644 big/lu-decomp.scm delete mode 100644 big/new-ports.scm delete mode 100644 big/pp.scm delete mode 100644 big/queue.scm delete mode 100644 big/random.scm delete mode 100644 big/receive.scm delete mode 100644 big/search-tree.scm delete mode 100644 big/sleep.scm delete mode 100644 big/sort.scm delete mode 100644 big/xport.scm delete mode 100644 build-usual-image delete mode 100644 cig/cig.scm delete mode 100644 cig/doc/boxedminipage.sty delete mode 100644 cig/doc/draftfooters.sty delete mode 100644 cig/doc/headings.tex delete mode 100644 comp-packages.scm delete mode 100644 debug-packages.scm delete mode 100644 debug/byte-code-test.scm delete mode 100644 debug/check.scm delete mode 100644 debug/describe.scm delete mode 100644 debug/fact.scm delete mode 100644 debug/fix-low.scm delete mode 100644 debug/for-debugging.scm delete mode 100644 debug/level-0.scm delete mode 100644 debug/link-debug.scm delete mode 100644 debug/linker.scm delete mode 100644 debug/mini-command.scm delete mode 100644 debug/mini-package.scm delete mode 100644 debug/mini-start.scm delete mode 100644 debug/mumble-packages.scm delete mode 100644 debug/mutation.scm delete mode 100644 debug/profile.scm delete mode 100644 debug/read-image.scm delete mode 100644 debug/spatial-hack.scm delete mode 100644 debug/test-generic.scm delete mode 100644 debug/test-methods.scm delete mode 100644 debug/test.scm delete mode 100644 debug/tiny-packages.scm delete mode 100644 debug/tiny.scm delete mode 100644 debug/vector-space.scm delete mode 100644 debug/wind-test.scm delete mode 100644 doc/big-scheme.txt delete mode 100644 doc/code.tex delete mode 100644 doc/external.txt delete mode 100644 doc/hacking.txt delete mode 100644 doc/latex-stuff.tex delete mode 100644 doc/meeting.ps delete mode 100644 doc/meeting.tex delete mode 100644 doc/module.ps delete mode 100644 doc/module.tex delete mode 100644 doc/no-leaf-env.txt delete mode 100644 doc/package.txt delete mode 100644 doc/scsh-src-roadmap.txt delete mode 100644 doc/summary.tex delete mode 100644 doc/threads.txt delete mode 100644 doc/type.txt delete mode 100644 doc/user-guide.txt delete mode 100644 emacs/README delete mode 100644 emacs/cmulisp.el delete mode 100644 emacs/cmuscheme.el delete mode 100644 emacs/cmuscheme48.el delete mode 100644 emacs/cmushell.el delete mode 100644 emacs/comint.el delete mode 100644 emacs/jar-hacks.el delete mode 100644 env/assem.scm delete mode 100644 env/basic-command.scm delete mode 100644 env/build.scm delete mode 100644 env/debug.scm delete mode 100644 env/debuginfo.scm delete mode 100644 env/disasm.scm delete mode 100644 env/disclosers.scm delete mode 100644 env/dispcond.scm delete mode 100644 env/flatload.scm delete mode 100644 env/init-defpackage.scm delete mode 100644 env/inspect.scm delete mode 100644 env/jar-assem.scm delete mode 100644 env/list-interface.scm delete mode 100644 env/load-package.scm delete mode 100644 env/more-thread.scm delete mode 100644 env/pedit.scm delete mode 100644 env/read-command.scm delete mode 100644 env/shadow.scm delete mode 100644 env/space.scm delete mode 100644 env/start.scm delete mode 100644 env/traverse.scm delete mode 100644 env/version-info.scm delete mode 100644 filenames.make delete mode 100644 filenames.scm delete mode 100644 infix/packages.scm delete mode 100644 infix/pratt.scm delete mode 100644 infix/sgol-runtime.scm delete mode 100644 infix/sgol.scm delete mode 100644 infix/tokenize.scm delete mode 100644 initial-packages.scm delete mode 100644 initial.scm delete mode 100755 install-sh delete mode 100644 link-packages.scm delete mode 100644 link/data.scm delete mode 100644 link/generate-c-header.scm delete mode 100644 link/link.scm delete mode 100644 link/load-linker.exec delete mode 100644 link/loadc.scm delete mode 100644 link/lucid-script.lisp delete mode 100644 link/reify.scm delete mode 100644 link/transport.scm delete mode 100644 link/write-image.scm delete mode 100644 low-packages.scm delete mode 100644 main-original.c delete mode 100644 minor-version-number delete mode 100644 misc/annotate.scm delete mode 100644 misc/argument.scm delete mode 100644 misc/doodl.scm delete mode 100644 misc/either.scm delete mode 100644 misc/getenv.scm delete mode 100644 misc/hilbert.scm delete mode 100644 misc/ilength.scm delete mode 100644 misc/integertostring.scm delete mode 100644 misc/load-static.scm delete mode 100644 misc/mail.scm delete mode 100644 misc/packages.scm delete mode 100644 misc/psd-s48.scm delete mode 100644 misc/remote.scm delete mode 100644 misc/require.scm delete mode 100644 misc/separate.scm delete mode 100644 misc/sicp.scm delete mode 100644 misc/slib-init.scm delete mode 100644 misc/socket.scm delete mode 100644 misc/static.scm delete mode 100644 misc/test-doodl.scm delete mode 100644 more-interfaces.scm delete mode 100644 more-packages.scm delete mode 100644 opt/analyze.scm delete mode 100644 opt/expand.scm delete mode 100644 opt/inline.scm delete mode 100644 opt/tst.scm delete mode 100644 packages.scm delete mode 100644 postgcstub.c delete mode 100644 prescheme.c delete mode 100644 prescheme.h delete mode 100644 rts-packages.scm delete mode 100644 rts/base.scm delete mode 100644 rts/bignum.scm delete mode 100644 rts/bummed-jar-defrecord.scm delete mode 100644 rts/condition.scm delete mode 100644 rts/continuation.scm delete mode 100644 rts/defenum.scm delete mode 100644 rts/enum.scm delete mode 100644 rts/env.scm delete mode 100644 rts/exception.scm delete mode 100644 rts/floatnum.scm delete mode 100644 rts/fluid.scm delete mode 100644 rts/init.scm delete mode 100644 rts/innum.scm delete mode 100644 rts/interrupt.scm delete mode 100644 rts/jar-defrecord.scm delete mode 100644 rts/lize.scm delete mode 100644 rts/low.scm delete mode 100644 rts/method.scm delete mode 100644 rts/number.scm delete mode 100644 rts/numio.scm delete mode 100644 rts/population.scm delete mode 100644 rts/port.scm delete mode 100644 rts/ratnum.scm delete mode 100644 rts/read.scm delete mode 100644 rts/recnum.scm delete mode 100644 rts/record.scm delete mode 100644 rts/signal.scm delete mode 100644 rts/template.scm delete mode 100644 rts/util.scm delete mode 100644 rts/wind.scm delete mode 100644 rts/write.scm delete mode 100644 rts/xnum.scm delete mode 100644 rts/xprim.scm delete mode 100644 scheme48.1 delete mode 100644 scheme48.h delete mode 100644 scheme48.man delete mode 100644 scsh/aix/sigset.h delete mode 100644 scsh/aix/sysdep.h delete mode 100644 scsh/aix/time_dep1.c delete mode 100644 scsh/bsd/Makefile.inc delete mode 100644 scsh/bsd/sysdep.h delete mode 100644 scsh/bsd/time_dep1.c delete mode 100644 scsh/cstuff.h delete mode 100644 scsh/cxux/Makefile.inc delete mode 100644 scsh/cxux/sysdep.h delete mode 100644 scsh/cxux/time_dep1.c delete mode 100755 scsh/ekko.scm delete mode 100644 scsh/fdports.h delete mode 100644 scsh/generic/Makefile.inc delete mode 100644 scsh/generic/sysdep.h delete mode 100644 scsh/generic/time_dep1.c delete mode 100644 scsh/hpux/Makefile.inc delete mode 100644 scsh/hpux/sigset.h delete mode 100644 scsh/hpux/sysdep.h delete mode 100644 scsh/hpux/time_dep1.c delete mode 100644 scsh/irix/Makefile.inc delete mode 100644 scsh/irix/sigset.h delete mode 100644 scsh/irix/sysdep.h delete mode 100644 scsh/irix/time_dep1.c delete mode 100644 scsh/linux/Makefile.inc delete mode 100644 scsh/linux/sysdep.h delete mode 100644 scsh/linux/time_dep1.c delete mode 100644 scsh/next/Makefile.inc delete mode 100644 scsh/next/sigset.h delete mode 100644 scsh/next/sysdep.h delete mode 100644 scsh/next/time_dep1.c delete mode 100644 scsh/nextbs.c delete mode 100644 scsh/nt2.c delete mode 100644 scsh/oldfr.scm delete mode 100644 scsh/oldhere.scm delete mode 100644 scsh/scsh-tramp.c delete mode 100644 scsh/solaris/Makefile.inc delete mode 100644 scsh/solaris/sigset.h delete mode 100644 scsh/solaris/sysdep.h delete mode 100644 scsh/solaris/time_dep1.c delete mode 100644 scsh/sunos/Makefile.inc delete mode 100644 scsh/sunos/sigset.h delete mode 100644 scsh/sunos/sysdep.h delete mode 100644 scsh/sunos/time_dep1.c delete mode 100644 scsh/time.c delete mode 100644 scsh/time1.h delete mode 100644 scsh/ultrix/Makefile.inc delete mode 100644 scsh/ultrix/sigset.h delete mode 100644 scsh/ultrix/sysdep.h delete mode 100644 scsh/ultrix/time_dep1.c delete mode 100644 vm/README delete mode 100644 vm/arch.scm delete mode 100644 vm/arith.scm delete mode 100644 vm/data.scm delete mode 100644 vm/defenum.scm delete mode 100644 vm/define-primitive.scm delete mode 100644 vm/disasm.scm delete mode 100644 vm/env.scm delete mode 100644 vm/external.scm delete mode 100644 vm/gc.scm delete mode 100644 vm/interp.scm delete mode 100644 vm/macro-package-defs.scm delete mode 100644 vm/memory.scm delete mode 100644 vm/prescheme.scm delete mode 100644 vm/prim.scm delete mode 100644 vm/ps-interface.scm delete mode 100644 vm/ps-memory.scm delete mode 100644 vm/ps-package-defs.scm delete mode 100644 vm/ps-package.scm delete mode 100644 vm/resume.scm delete mode 100644 vm/s48-package-defs.scm delete mode 100644 vm/stack.scm delete mode 100644 vm/stob.scm delete mode 100644 vm/struct.scm delete mode 100644 vm/vm-utilities.scm delete mode 100644 vm/vmio.scm diff --git a/.gdbinit b/.gdbinit deleted file mode 100644 index be8c6b5..0000000 --- a/.gdbinit +++ /dev/null @@ -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 diff --git a/.notify b/.notify deleted file mode 100644 index e69de29..0000000 diff --git a/INSTALL b/INSTALL deleted file mode 100644 index 420b629..0000000 --- a/INSTALL +++ /dev/null @@ -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'. diff --git a/NEWS.s48-0.36 b/NEWS.s48-0.36 deleted file mode 100644 index d61487f..0000000 --- a/NEWS.s48-0.36 +++ /dev/null @@ -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 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 ) 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 - 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 *). - 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
,user - ,in config ,config - ,in for-syntax ,for-syntax - ,load-into config ,load-config - ,load-into for-syntax ,for-syntax (load "file") - - Features: - There is an ,expand 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 [] and ,user [] are like ,in . - 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 charnumber. - -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 diff --git a/TODO.s48-0.36 b/TODO.s48-0.36 deleted file mode 100644 index 86ade62..0000000 --- a/TODO.s48-0.36 +++ /dev/null @@ -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 ). - 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 ( ...) ) - 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 - -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. diff --git a/alt-packages.scm b/alt-packages.scm deleted file mode 100644 index 7ca907f..0000000 --- a/alt-packages.scm +++ /dev/null @@ -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))) diff --git a/alt/annotate.scm b/alt/annotate.scm deleted file mode 100644 index 2140472..0000000 --- a/alt/annotate.scm +++ /dev/null @@ -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))) diff --git a/alt/ascii.scm b/alt/ascii.scm deleted file mode 100644 index 09791a2..0000000 --- a/alt/ascii.scm +++ /dev/null @@ -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 diff --git a/alt/bitwise-tests.scm b/alt/bitwise-tests.scm deleted file mode 100644 index ab03a60..0000000 --- a/alt/bitwise-tests.scm +++ /dev/null @@ -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))) diff --git a/alt/bitwise.scm b/alt/bitwise.scm deleted file mode 100644 index d534879..0000000 --- a/alt/bitwise.scm +++ /dev/null @@ -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) ...) ;? diff --git a/alt/closure.scm b/alt/closure.scm deleted file mode 100644 index 6bcd075..0000000 --- a/alt/closure.scm +++ /dev/null @@ -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)) diff --git a/alt/code-vector.scm b/alt/code-vector.scm deleted file mode 100644 index a4915fc..0000000 --- a/alt/code-vector.scm +++ /dev/null @@ -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)) diff --git a/alt/config.scm b/alt/config.scm deleted file mode 100644 index dc178fe..0000000 --- a/alt/config.scm +++ /dev/null @@ -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 ' ?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 ' - (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) diff --git a/alt/contin.scm b/alt/contin.scm deleted file mode 100644 index f7d4869..0000000 --- a/alt/contin.scm +++ /dev/null @@ -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)) diff --git a/alt/environments.scm b/alt/environments.scm deleted file mode 100644 index e258447..0000000 --- a/alt/environments.scm +++ /dev/null @@ -1,6 +0,0 @@ - -; don't put a copyright notice, silly shell script - -(define (*structure-ref struct name) - (eval name (interaction-environment))) - diff --git a/alt/escape.scm b/alt/escape.scm deleted file mode 100644 index 45b792f..0000000 --- a/alt/escape.scm +++ /dev/null @@ -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))))))) diff --git a/alt/features-packages.scm b/alt/features-packages.scm deleted file mode 100644 index cb873f1..0000000 --- a/alt/features-packages.scm +++ /dev/null @@ -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)) diff --git a/alt/features.scm b/alt/features.scm deleted file mode 100644 index de75805..0000000 --- a/alt/features.scm +++ /dev/null @@ -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 diff --git a/alt/fluid.scm b/alt/fluid.scm deleted file mode 100644 index b2c8c7c..0000000 --- a/alt/fluid.scm +++ /dev/null @@ -1,33 +0,0 @@ -; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING. - - -; Fluid variables - -(define (make-fluid val) - (vector ' 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)))))))) - diff --git a/alt/init-defpackage.scm b/alt/init-defpackage.scm deleted file mode 100644 index f4c8027..0000000 --- a/alt/init-defpackage.scm +++ /dev/null @@ -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)))))) diff --git a/alt/locations.scm b/alt/locations.scm deleted file mode 100644 index d26c399..0000000 --- a/alt/locations.scm +++ /dev/null @@ -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)) diff --git a/alt/loophole.scm b/alt/loophole.scm deleted file mode 100644 index d3214b1..0000000 --- a/alt/loophole.scm +++ /dev/null @@ -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)))) - diff --git a/alt/low-packages.scm b/alt/low-packages.scm deleted file mode 100644 index 577b20e..0000000 --- a/alt/low-packages.scm +++ /dev/null @@ -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)) diff --git a/alt/low.scm b/alt/low.scm deleted file mode 100644 index 6d33da1..0000000 --- a/alt/low.scm +++ /dev/null @@ -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)))) diff --git a/alt/primitives.scm b/alt/primitives.scm deleted file mode 100644 index 2c5f4f2..0000000 --- a/alt/primitives.scm +++ /dev/null @@ -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))))) diff --git a/alt/pseudoscheme-features.scm b/alt/pseudoscheme-features.scm deleted file mode 100644 index f9703d0..0000000 --- a/alt/pseudoscheme-features.scm +++ /dev/null @@ -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))) diff --git a/alt/pseudoscheme-record.scm b/alt/pseudoscheme-record.scm deleted file mode 100644 index be4827d..0000000 --- a/alt/pseudoscheme-record.scm +++ /dev/null @@ -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)) diff --git a/alt/queue.scm b/alt/queue.scm deleted file mode 100644 index 95a05c4..0000000 --- a/alt/queue.scm +++ /dev/null @@ -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))) diff --git a/alt/record.scm b/alt/record.scm deleted file mode 100644 index 3c1fcf4..0000000 --- a/alt/record.scm +++ /dev/null @@ -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") diff --git a/alt/reroot.scm b/alt/reroot.scm deleted file mode 100644 index e30b565..0000000 --- a/alt/reroot.scm +++ /dev/null @@ -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 , 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"))) diff --git a/alt/schemetoc-features.scm b/alt/schemetoc-features.scm deleted file mode 100644 index bfc6e56..0000000 --- a/alt/schemetoc-features.scm +++ /dev/null @@ -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)) diff --git a/alt/schemetoc-record.scm b/alt/schemetoc-record.scm deleted file mode 100644 index 96da051..0000000 --- a/alt/schemetoc-record.scm +++ /dev/null @@ -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 #\~) diff --git a/alt/silly.scm b/alt/silly.scm deleted file mode 100644 index 8ca9c4e..0000000 --- a/alt/silly.scm +++ /dev/null @@ -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))))))) diff --git a/alt/syntax.scm b/alt/syntax.scm deleted file mode 100644 index b65aee8..0000000 --- a/alt/syntax.scm +++ /dev/null @@ -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)))) diff --git a/alt/t-features.scm b/alt/t-features.scm deleted file mode 100644 index ba63313..0000000 --- a/alt/t-features.scm +++ /dev/null @@ -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)) diff --git a/alt/t-record.scm b/alt/t-record.scm deleted file mode 100644 index 0af9262..0000000 --- a/alt/t-record.scm +++ /dev/null @@ -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) diff --git a/alt/table.scm b/alt/table.scm deleted file mode 100644 index 1582945..0000000 --- a/alt/table.scm +++ /dev/null @@ -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)))))) diff --git a/alt/template.scm b/alt/template.scm deleted file mode 100644 index c65a3b4..0000000 --- a/alt/template.scm +++ /dev/null @@ -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)) diff --git a/alt/values.scm b/alt/values.scm deleted file mode 100644 index 789cb3f..0000000 --- a/alt/values.scm +++ /dev/null @@ -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)))) diff --git a/alt/weak.scm b/alt/weak.scm deleted file mode 100644 index 5aa72f2..0000000 --- a/alt/weak.scm +++ /dev/null @@ -1,8 +0,0 @@ -; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING. - - -(define (make-weak-pointer x) (cons ' x)) -(define weak-pointer-ref cdr) -(define (weak-pointer? x) - (and (pair? x) (eq? (car x) '))) - diff --git a/bcomp/comp.scm b/bcomp/comp.scm deleted file mode 100644 index 28cc89b..0000000 --- a/bcomp/comp.scm +++ /dev/null @@ -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 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))) diff --git a/bcomp/config.scm b/bcomp/config.scm deleted file mode 100644 index 21ce22a..0000000 --- a/bcomp/config.scm +++ /dev/null @@ -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) diff --git a/bcomp/cprim.scm b/bcomp/cprim.scm deleted file mode 100644 index ea0dc94..0000000 --- a/bcomp/cprim.scm +++ /dev/null @@ -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))))))) diff --git a/bcomp/ddata.scm b/bcomp/ddata.scm deleted file mode 100644 index 0bbdbc9..0000000 --- a/bcomp/ddata.scm +++ /dev/null @@ -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))) diff --git a/bcomp/for-reify.scm b/bcomp/for-reify.scm deleted file mode 100644 index c591358..0000000 --- a/bcomp/for-reify.scm +++ /dev/null @@ -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)) diff --git a/bcomp/interface.scm b/bcomp/interface.scm deleted file mode 100644 index 423d33f..0000000 --- a/bcomp/interface.scm +++ /dev/null @@ -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))) diff --git a/bcomp/module-language.scm b/bcomp/module-language.scm deleted file mode 100644 index 56699ab..0000000 --- a/bcomp/module-language.scm +++ /dev/null @@ -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 - -; ::= (define-interface ) -; ::= | (export ...) | (compound-interface ...) - -(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 ...)))) - - -; ::= | ( ) | (( ...) ) - -(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 ) -; 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 ( . ). To evaluate the -; right-hand side of a DEFINE-SYNTAX (LET-SYNTAX, etc.) form, -; is called on the right-hand side and . -; 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 ...))))) diff --git a/bcomp/mtype.scm b/bcomp/mtype.scm deleted file mode 100644 index d789ace..0000000 --- a/bcomp/mtype.scm +++ /dev/null @@ -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))))))) diff --git a/bcomp/package.scm b/bcomp/package.scm deleted file mode 100644 index 36c87d6..0000000 --- a/bcomp/package.scm +++ /dev/null @@ -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) diff --git a/bcomp/recon.scm b/bcomp/recon.scm deleted file mode 100644 index 43ae54d..0000000 --- a/bcomp/recon.scm +++ /dev/null @@ -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=? charascii - (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))) diff --git a/bcomp/rules.scm b/bcomp/rules.scm deleted file mode 100644 index 614d24f..0000000 --- a/bcomp/rules.scm +++ /dev/null @@ -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))) diff --git a/bcomp/schemify.scm b/bcomp/schemify.scm deleted file mode 100644 index 3023858..0000000 --- a/bcomp/schemify.scm +++ /dev/null @@ -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)) diff --git a/bcomp/segment.scm b/bcomp/segment.scm deleted file mode 100644 index 79918f8..0000000 --- a/bcomp/segment.scm +++ /dev/null @@ -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)) diff --git a/bcomp/state.scm b/bcomp/state.scm deleted file mode 100644 index 512d77d..0000000 --- a/bcomp/state.scm +++ /dev/null @@ -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))) diff --git a/bcomp/syntax.scm b/bcomp/syntax.scm deleted file mode 100644 index fb014e4..0000000 --- a/bcomp/syntax.scm +++ /dev/null @@ -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)) diff --git a/bcomp/type.scm b/bcomp/type.scm deleted file mode 100644 index 03a7f3f..0000000 --- a/bcomp/type.scm +++ /dev/null @@ -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)) diff --git a/bcomp/undefined.scm b/bcomp/undefined.scm deleted file mode 100644 index b39a2d0..0000000 --- a/bcomp/undefined.scm +++ /dev/null @@ -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))))))) diff --git a/bcomp/usual.scm b/bcomp/usual.scm deleted file mode 100644 index c6d50a8..0000000 --- a/bcomp/usual.scm +++ /dev/null @@ -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)) diff --git a/big/array.scm b/big/array.scm deleted file mode 100644 index b97488e..0000000 --- a/big/array.scm +++ /dev/null @@ -1,315 +0,0 @@ -; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING. - - -; (make-array ...) -; (array-shape ) -; (array-ref ...) -; (array-set! ...) -; (make-shared-array ...) -; (copy-array ) -; (array->vector ) -; (array . ) -; -; All arrays are zero based. -; -; ARRAY-MAP returns a list containing the array's bounds. -; -; The 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) - diff --git a/big/bigbit.scm b/big/bigbit.scm deleted file mode 100644 index 7722032..0000000 --- a/big/bigbit.scm +++ /dev/null @@ -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)) diff --git a/big/compose-cont.scm b/big/compose-cont.scm deleted file mode 100644 index d46c725..0000000 --- a/big/compose-cont.scm +++ /dev/null @@ -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)))) - diff --git a/big/defrecord.scm b/big/defrecord.scm deleted file mode 100644 index 2a827b8..0000000 --- a/big/defrecord.scm +++ /dev/null @@ -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 or (), the second -; indicating a field whose value can be modified. -; Other-fields are one of: -; ( ) = modifiable field with the given value. -; = 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)))))) diff --git a/big/destructure.scm b/big/destructure.scm deleted file mode 100644 index c96bc82..0000000 --- a/big/destructure.scm +++ /dev/null @@ -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))))))) - diff --git a/big/dump.scm b/big/dump.scm deleted file mode 100644 index 4e256aa..0000000 --- a/big/dump.scm +++ /dev/null @@ -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 -; ... _ represent 0 ... 63, -; { ... {_ represent 64 ... 127, -- { is ascii 123 -; | ... |_ represent 128 ... 191, -- | is ascii 124 -; } ... }_ 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))))))) diff --git a/big/external.scm b/big/external.scm deleted file mode 100644 index bfe8905..0000000 --- a/big/external.scm +++ /dev/null @@ -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*)))) diff --git a/big/filename.scm b/big/filename.scm deleted file mode 100644 index fb73d58..0000000 --- a/big/filename.scm +++ /dev/null @@ -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)))))))) diff --git a/big/format.scm b/big/format.scm deleted file mode 100644 index 7d1913b..0000000 --- a/big/format.scm +++ /dev/null @@ -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"))) - - diff --git a/big/general-table.scm b/big/general-table.scm deleted file mode 100644 index dc90518..0000000 --- a/big/general-table.scm +++ /dev/null @@ -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))) diff --git a/big/lu-decomp.scm b/big/lu-decomp.scm deleted file mode 100644 index 8e27e6b..0000000 --- a/big/lu-decomp.scm +++ /dev/null @@ -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)))))) diff --git a/big/new-ports.scm b/big/new-ports.scm deleted file mode 100644 index 9a6715a..0000000 --- a/big/new-ports.scm +++ /dev/null @@ -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)) diff --git a/big/pp.scm b/big/pp.scm deleted file mode 100644 index 37a198d..0000000 --- a/big/pp.scm +++ /dev/null @@ -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 "" "pretty-print" '(expression) -; (p (eval expression (user-package)) (command-output))) diff --git a/big/queue.scm b/big/queue.scm deleted file mode 100644 index 7937580..0000000 --- a/big/queue.scm +++ /dev/null @@ -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))) diff --git a/big/random.scm b/big/random.scm deleted file mode 100644 index 79bcf73..0000000 --- a/big/random.scm +++ /dev/null @@ -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 ) 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))) diff --git a/big/receive.scm b/big/receive.scm deleted file mode 100644 index 390320c..0000000 --- a/big/receive.scm +++ /dev/null @@ -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))))) diff --git a/big/search-tree.scm b/big/search-tree.scm deleted file mode 100644 index efafb88..0000000 --- a/big/search-tree.scm +++ /dev/null @@ -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))) diff --git a/big/sleep.scm b/big/sleep.scm deleted file mode 100644 index b1c4126..0000000 --- a/big/sleep.scm +++ /dev/null @@ -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))))))) diff --git a/big/sort.scm b/big/sort.scm deleted file mode 100644 index 711e9fd..0000000 --- a/big/sort.scm +++ /dev/null @@ -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))))) diff --git a/big/xport.scm b/big/xport.scm deleted file mode 100644 index 2a48e52..0000000 --- a/big/xport.scm +++ /dev/null @@ -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)) diff --git a/build-usual-image b/build-usual-image deleted file mode 100644 index 64e68d2..0000000 --- a/build-usual-image +++ /dev/null @@ -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 <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, . It takes the arguments -;;; arg1 ... argn, type-checks them, and then passes them to a C stub, -;;; df_. 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 i declarations, -;;; and then calls the C procedure . The C procedure is expected to -;;; return its first value () as its real value. The other return values -;;; are returned by assigning targets passed by-reference to by the -;;; stub. These return parameters are passed after the argument parameters. -;;; When returns, the C stub df_ 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 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 -#include /* 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. diff --git a/cig/doc/boxedminipage.sty b/cig/doc/boxedminipage.sty deleted file mode 100644 index 19e3e9d..0000000 --- a/cig/doc/boxedminipage.sty +++ /dev/null @@ -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} - diff --git a/cig/doc/draftfooters.sty b/cig/doc/draftfooters.sty deleted file mode 100644 index 862436d..0000000 --- a/cig/doc/draftfooters.sty +++ /dev/null @@ -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 diff --git a/cig/doc/headings.tex b/cig/doc/headings.tex deleted file mode 100644 index 96b622e..0000000 --- a/cig/doc/headings.tex +++ /dev/null @@ -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 diff --git a/comp-packages.scm b/comp-packages.scm deleted file mode 100644 index 8f70209..0000000 --- a/comp-packages.scm +++ /dev/null @@ -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))) diff --git a/debug-packages.scm b/debug-packages.scm deleted file mode 100644 index fa52cde..0000000 --- a/debug-packages.scm +++ /dev/null @@ -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))))) diff --git a/debug/byte-code-test.scm b/debug/byte-code-test.scm deleted file mode 100644 index 6f849a3..0000000 --- a/debug/byte-code-test.scm +++ /dev/null @@ -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)) diff --git a/debug/check.scm b/debug/check.scm deleted file mode 100644 index 80ff76d..0000000 --- a/debug/check.scm +++ /dev/null @@ -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))) diff --git a/debug/describe.scm b/debug/describe.scm deleted file mode 100644 index 2d57c5f..0000000 --- a/debug/describe.scm +++ /dev/null @@ -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)) diff --git a/debug/fact.scm b/debug/fact.scm deleted file mode 100644 index 29370c9..0000000 --- a/debug/fact.scm +++ /dev/null @@ -1,8 +0,0 @@ - -; don't copyright this, silly shell script - - -(define (fact n) - (if (= n 0) - 1 - (* n (fact (- n 1))))) diff --git a/debug/fix-low.scm b/debug/fix-low.scm deleted file mode 100644 index 8514e1a..0000000 --- a/debug/fix-low.scm +++ /dev/null @@ -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? - diff --git a/debug/for-debugging.scm b/debug/for-debugging.scm deleted file mode 100644 index 141032d..0000000 --- a/debug/for-debugging.scm +++ /dev/null @@ -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))) diff --git a/debug/level-0.scm b/debug/level-0.scm deleted file mode 100644 index 83a294f..0000000 --- a/debug/level-0.scm +++ /dev/null @@ -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)) diff --git a/debug/link-debug.scm b/debug/link-debug.scm deleted file mode 100644 index b719fb3..0000000 --- a/debug/link-debug.scm +++ /dev/null @@ -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))))))) diff --git a/debug/linker.scm b/debug/linker.scm deleted file mode 100644 index 5cbde5c..0000000 --- a/debug/linker.scm +++ /dev/null @@ -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) ...)))) diff --git a/debug/mini-command.scm b/debug/mini-command.scm deleted file mode 100644 index 929009c..0000000 --- a/debug/mini-command.scm +++ /dev/null @@ -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))))))) diff --git a/debug/mini-package.scm b/debug/mini-package.scm deleted file mode 100644 index ae643e9..0000000 --- a/debug/mini-package.scm +++ /dev/null @@ -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))) - diff --git a/debug/mini-start.scm b/debug/mini-start.scm deleted file mode 100644 index 07c9dd5..0000000 --- a/debug/mini-start.scm +++ /dev/null @@ -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))))) diff --git a/debug/mumble-packages.scm b/debug/mumble-packages.scm deleted file mode 100644 index 1b4536d..0000000 --- a/debug/mumble-packages.scm +++ /dev/null @@ -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)) diff --git a/debug/mutation.scm b/debug/mutation.scm deleted file mode 100644 index 74776b5..0000000 --- a/debug/mutation.scm +++ /dev/null @@ -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)) - diff --git a/debug/profile.scm b/debug/profile.scm deleted file mode 100644 index ae857cb..0000000 --- a/debug/profile.scm +++ /dev/null @@ -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))) diff --git a/debug/read-image.scm b/debug/read-image.scm deleted file mode 100644 index bdfe0d5..0000000 --- a/debug/read-image.scm +++ /dev/null @@ -1,223 +0,0 @@ -; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING. - - - -;(define-syntax assert -; (lambda ignore -; ''assert)) - -(define debugging? #t) - -; ,bench -; ,load rts/defenum.scm -; ,for-syntax ,load my-vm/for-syntax.scm -; ,load my-vm/s48-prescheme.scm my-vm/util.scm my-vm/memory.scm -; ,load my-vm/arch.scm my-vm/data.scm my-vm/struct.scm -; ,load link/s48-features.scm link/read-image.scm -; ,load-into extended-numbers misc/bigbit.scm - -(define (resume filename arg) - (call-startup-procedure (extract (read-image filename)) arg)) - -(define (call-startup-procedure proc arg) - (proc arg (current-input-port) (current-output-port))) - -(define level 14) - -(define (read-image filename) - (call-with-input-file filename - (lambda (port) - (read-page port) ; read past any user cruft at the beginning of the file - (let* ((old-level (read-number port)) - (old-bytes-per-cell (read-number port)) - (old-begin (cells->a-units (read-number port))) - (old-hp (cells->a-units (read-number port))) - (startup-proc (read-number port))) - (read-page port) - (if (not (= old-level level)) - (error "format of image is incompatible with this version of system" - old-level level)) - (if (not (= old-bytes-per-cell bytes-per-cell)) - (error "incompatible bytes-per-cell" - old-bytes-per-cell bytes-per-cell)) - - ;; ***CHANGED*** - (create-memory (a-units->cells (- (addr1+ old-hp) old-begin)) - quiescent) - (set! *hp* 0) - - (let* ((delta (- *hp* old-begin)) - (new-hp (+ old-hp delta))) - (let ((reverse? (check-image-byte-order port))) - (read-block port *memory* *hp* (- old-hp old-begin)) - (if reverse? - (reverse-byte-order new-hp)) - (if (= delta 0) - (set! *hp* new-hp) - (relocate-image delta new-hp)) - (set! *extracted* (make-vector (a-units->cells *memory-end*) #f)) - (adjust startup-proc delta))))))) - -(define (check-image-byte-order port) - (read-block port *memory* *hp* (cells->a-units 1)) - (cond ((= (fetch *hp*) 1) - #f) - (else - (reverse-descriptor-byte-order! *hp*) - (if (= (fetch *hp*) 1) - #t - (begin (error "unable to correct byte order" (fetch *hp*)) - #f))))) - -(define *hp* 0) - -(define *extracted* #f) - -(define (extract obj) - (cond ((vm-fixnum? obj) (extract-vm-fixnum obj)) - ((stob? obj) - (let ((index (a-units->cells (address-after-header obj)))) - (or (vector-ref *extracted* index) - (extract-stored-object obj - (lambda (new) - (vector-set! *extracted* index new) - new))))) - ((vm-char? obj) (extract-char obj)) - ((vm-eq? obj null) '()) - ((vm-eq? obj false) #f) - ((vm-eq? obj true) #t) - ((vm-eq? obj vm-unspecific) (if #f 0)) - ((vm-eq? obj unbound-marker) ') - ((vm-eq? obj unassigned-marker) ') - (else (error "random descriptor" obj)))) - -(define (extract-stored-object old store-new!) - ((vector-ref stored-object-extractors (header-type (stob-header old))) - old store-new!)) - -(define stored-object-extractors - (make-vector stob-count (lambda rest (apply error "no extractor" rest)))) - -(define (define-extractor which proc) - (vector-set! stored-object-extractors which proc)) - -(define-extractor stob/pair - (lambda (old store-new!) - (let ((new (cons #f #f))) - (store-new! new) - (set-car! new (extract (vm-car old))) - (set-cdr! new (extract (vm-cdr old))) - new))) - -(define-extractor stob/vm-closure - (lambda (old store-new!) - (store-new! (make-closure (extract (vm-closure-template old)) - (extract (vm-closure-env old)))))) - -(define-extractor stob/symbol - (lambda (obj store-new!) - (store-new! (string->symbol (extract (vm-symbol->string obj)))))) - -(define-extractor stob/vm-location - (lambda (obj store-new!) - (let ((new (store-new! (make-undefined-location - (+ 10000 - (extract (vm-location-id obj)))))) - (val (vm-contents obj))) - (if (not (vm-eq? val unbound-marker)) - (begin (set-location-defined?! new #t) - (if (not (vm-eq? val unassigned-marker)) - (set-contents! new (extract val))))) - new))) - -(define-extractor stob/string - (lambda (obj store-new!) - (store-new! (extract-string obj)))) - -(define-extractor stob/vm-code-vector - (lambda (obj store-new!) - (store-new! (extract-code-vector obj)))) - -(define-extractor stob/vector - (lambda (obj store-new!) - (let* ((z (vm-vector-length obj)) - (v (make-vector z))) - (store-new! v) - (do ((i 0 (+ i 1))) - ((= i z) v) - (vector-set! v i (extract (vm-vector-ref obj i))))))) - -;(define-extractor stob/record -; (lambda (obj store-new!) -; (let* ((z (vm-record-length obj)) -; (v (make-record z))) -; (store-new! v) -; (do ((i 0 (+ i 1))) -; ((= i z) v) -; (record-set! v i (extract (vm-record-ref obj i))))))) - -(define-extractor stob/port - (lambda (obj store-new!) - (store-new! - (case (extract-vm-fixnum (port-index obj)) - ((0) (current-input-port)) - ((1) (current-output-port)) - (else (error "unextractable port" obj)))))) - - - -(define (extract-code-vector x) - (let ((z (vm-code-vector-length x))) - (let ((v (make-code-vector z 0))) - (do ((i 0 (+ i 1))) - ((>= i z) v) - (code-vector-set! v i (vm-code-vector-ref x i)))))) - - - -; Various things copied from vm/gc.scm - -(define (store-next! descriptor) - (store! *hp* descriptor) - (set! *hp* (addr1+ *hp*))) - -(define (reverse-descriptor-byte-order! addr) - (let ((x (fetch-byte addr))) - (store-byte! addr (fetch-byte (addr+ addr 3))) - (store-byte! (addr+ addr 3) x)) - (let ((x (fetch-byte (addr+ addr 1)))) - (store-byte! (addr+ addr 1) (fetch-byte (addr+ addr 2))) - (store-byte! (addr+ addr 2) x))) - -(define (reverse-byte-order end) - (write-string "Correcting byte order of resumed image." - (current-output-port)) - (newline (current-output-port)) - (let loop ((ptr *hp*)) - (reverse-descriptor-byte-order! ptr) - (let ((value (fetch ptr))) - (if (addr< ptr end) - (loop (if (b-vector-header? value) - (addr+ (addr1+ ptr) (header-a-units value)) - (addr1+ ptr))))))) - -(define (adjust descriptor delta) - (if (stob? descriptor) - (make-stob-descriptor (addr+ (address-after-header descriptor) delta)) - descriptor)) - -(define (relocate-image delta new-hp) - (let loop () - (cond ((addr< *hp* new-hp) - (let ((d (adjust (fetch *hp*) delta))) - (store-next! d) - (cond ;;((eq? d the-primitive-header) - ;; Read symbolic label name. - ;;(store-next! - ;; (label->fixnum (name->label (read port))))) - ((b-vector-header? d) - (set! *hp* (addr+ *hp* - (cells->bytes - (bytes->cells - (header-length-in-bytes d))))))) - (loop)))))) diff --git a/debug/spatial-hack.scm b/debug/spatial-hack.scm deleted file mode 100644 index fc9e418..0000000 --- a/debug/spatial-hack.scm +++ /dev/null @@ -1,63 +0,0 @@ -; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING. - - -; load into initial image - -(init-defpackage! eval - (lambda () - (delay (make-simple-package (list scheme-level-1) - #t (delay #f) 'for-syntax)))) - -(define-structures ((assembler (export (lap syntax)))) - (open scheme-level-2 compiler architecture - signals ;error - enumerated ;name->enumerand - code-vectors - locations) ;location? - (specials lap) - (files (env assem))) - -(ensure-loaded assembler) - -(define-structures ((spatial (export space init-space))) - (open scheme-level-2 architecture primitives packages) - (files (debug space))) - -(ensure-loaded spatial) - -((*structure-ref spatial 'init-space) eval assembler) - -(define-interface define-record-types-interface - (export (define-record-type syntax) - define-record-discloser)) -(define-structures ((define-record-types define-record-types-interface)) - (open scheme-level-1 record) - (files (rts jar-defrecord))) -(define-interface queue-interface - (export make-queue enqueue dequeue queue-empty? - queue? queue->list queue-length delete-from-queue!)) -(define-structures ((queues queue-interface)) - (open scheme-level-1 define-record-types signals) - (files (big queue)) - (optimize auto-integrate)) -(define-structure traverse - (export traverse-depth-first traverse-breadth-first trail - set-leaf-predicate! usual-leaf-predicate) - (open scheme-level-2 - primitives ; ? - queues table - bitwise locations closures code-vectors - features ; string-hash - low-level) ; flush-the-symbol-table! - (files (env traverse))) - -(ensure-loaded traverse) - -(define foo - (make-simple-package (list scheme-level-2 - spatial traverse vm-exposure) - eval (delay #f) 'foo)) - -; (define command-processor (*structure-ref command 'command-processor)) - -; (set-interaction-environment! foo) diff --git a/debug/test-generic.scm b/debug/test-generic.scm deleted file mode 100644 index 9f879c3..0000000 --- a/debug/test-generic.scm +++ /dev/null @@ -1,34 +0,0 @@ -; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING. - - -(define g-methods (make-method-table 'g)) - -(define g (make-generic g-methods)) - -(define foo-family (make-family 'foo 1)) - -(define-method g-methods foo-family - (lambda (x) - (if (even? x) - 'win - (fail)))) - -(define bar-family (make-family 'bar 2)) ;More specific - -(define-method g-methods bar-family - (lambda (x) - (case x - ((1 3 5) 'ok) - (else (fail))))) - -(define-method g-methods (make-family 'baz 2) ;Same priority as bar-family - (lambda (x) - (case x - ((3) 'great) - (else (fail))))) - -; (g 0) => 'win -; (g 1) => 'ok -; (g 3) => 'great -; (g 9) => error - diff --git a/debug/test-methods.scm b/debug/test-methods.scm deleted file mode 100644 index bde4a76..0000000 --- a/debug/test-methods.scm +++ /dev/null @@ -1,37 +0,0 @@ -; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING. - - -(define-generic g &g) - -(define-method &g ((x :number)) 'win) - -(define-method &g ((n :integer)) - (if (= n 13) - (next-method) - 'ok)) - -(define-method &g ((s :symbol)) - (if (= s 13) - (next-method) - 'ok)) - -; (g 1/2) => 'win -; (g 10) => 'ok -; (g 13) => 'win - - -(define-generic elt &elt) - -(define-method &elt ((x :vector) y) - (vector-ref x y)) - -(define-method &elt ((x :string) y) - (string-ref x y)) - -(define-method &elt ((x :list) y) - (list-ref x y)) - -; Generic length - -; (define-generic-function glength ((s :sequence))) - diff --git a/debug/test.scm b/debug/test.scm deleted file mode 100644 index ce7d861..0000000 --- a/debug/test.scm +++ /dev/null @@ -1,32 +0,0 @@ - -; ,config ,load debug/test.scm - -(define-structure testing (export (test :syntax) lost?) - (open scheme signals handle conditions) - (begin - -(define *lost?* #f) -(define (lost?) *lost?*) - -(define (run-test string compare want thunk) - (let ((result - (call-with-current-continuation - (lambda (k) - (with-handler (lambda (condition punt) - (if (error? condition) - (k condition) - (punt))) - thunk))))) - (if (not (compare want result)) - (begin (display "Test ") (write string) (display " failed.") (newline) - (display "Wanted ") (write want) - (display ", but got ") (write result) (display ".") - (newline) - (set! *lost?* #t))))) - -(define-syntax test - (syntax-rules () - ((test ?string ?compare ?want ?exp) - (run-test ?string ?compare ?want (lambda () ?exp))))) - -)) diff --git a/debug/tiny-packages.scm b/debug/tiny-packages.scm deleted file mode 100644 index 69fe8c1..0000000 --- a/debug/tiny-packages.scm +++ /dev/null @@ -1,7 +0,0 @@ -; no copyright - -; (link-simple-system '(debug tiny) 'start tiny-system) - -(define-structure tiny-system (export start) - (define-all-operators) - (files tiny)) diff --git a/debug/tiny.scm b/debug/tiny.scm deleted file mode 100644 index f084a30..0000000 --- a/debug/tiny.scm +++ /dev/null @@ -1,20 +0,0 @@ -; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING. - -; Tiny image test system - -;(initialize-defpackage! ?? ??) -;(define-structure tiny-system (export start) -; (define-all-operators) -; (files (debug tiny))) -;(link-simple-system '(debug tiny) 'start tiny-system) - - -(define (start arg in out) - (write-string "Hello " out) - (if (vector? arg) - (if (< 0 (vector-length arg)) - (write-string (vector-ref arg 0) out))) - (write-char #\newline out) - (force-output out) - 0) - diff --git a/debug/vector-space.scm b/debug/vector-space.scm deleted file mode 100644 index b76fbf4..0000000 --- a/debug/vector-space.scm +++ /dev/null @@ -1,132 +0,0 @@ -; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING. - - - -; ,open architecture primitives low-level locations debug-data syntactic - -; July 5th -;total number of 3-vectors: 10896 -;probably table entries: 10381 -;symbol keys: 7363 -;integer keys: 3018 -;symbol values: 3793 -;location values: 2062 -;pair values: 1723 -;operator values: 989 -;debug-data values: 1208 -;transform values: 510 -; pair 4039 48468 -; symbol 1067 8536 -; vector 4477 124132 -; closure 1541 18492 -; location 807 9684 -; port 2 40 -; ratio 0 0 -; record 579 16732 -; continuation 6 136 -; extended-number 0 0 -; template 985 23916 -; weak-pointer 33 264 -; external 0 0 -;unused-d-header1 0 0 -;unused-d-header2 0 0 -; string 1207 19338 -; code-vector 986 51097 -; double 0 0 -; bignum 0 0 -; total 15729 320835 - - -(define (analyze-3-vectors) - (collect) - (let ((vs (find-all-xs (enum stob vector))) - (total 0) - (table-entries 0) - (symbol-keys 0) - (int-keys 0) - (symbols 0) - (locations 0) - (debug-datas 0) - (pairs 0) - (operators 0)) - (set! *foo* '()) - (vector-for-each - (lambda (v) - (if (= (vector-length v) 3) - (let ((x (vector-ref v 2))) - (set! total (+ total 1)) - (cond ((or (vector? x) (eq? x #f)) - (set! table-entries (+ table-entries 1)) - (let ((key (vector-ref v 0))) - (cond ((symbol? key) - (set! symbol-keys (+ symbol-keys 1))) - ((integer? key) - (set! int-keys (+ int-keys 1))))) - (let ((val (vector-ref v 1))) - (cond ((symbol? val) - (set! symbols (+ symbols 1))) - ((location? val) - (set! locations (+ locations 1))) - ((pair? val) - (set! pairs (+ pairs 1))) - ((transform? val) - (set! operators (+ operators 1))) - ((debug-data? val) - (set! debug-datas (+ debug-datas 1))) - (else (set! *foo* (cons v *foo*)))))))))) - vs) - (display "total number of 3-vectors: ") (write total) (newline) - (display "probably table entries: ") (write table-entries) (newline) - (display "symbol keys: ") (write symbol-keys) (newline) - (display "integer keys: ") (write int-keys) (newline) - (display "symbol values: ") (write symbols) (newline) - (display "location values: ") (write locations) (newline) - (display "pair values: ") (write pairs) (newline) - (display "transform values: ") (write operators) (newline) - (display "debug-data values: ") (write debug-datas) (newline))) - -(define *foo* '()) - -(define (bar) - (collect) - (vector-size-histogram (find-all-xs (enum stob vector)))) - -(define (vector-size-histogram vs) - (write (vector-length vs)) (display " vectors") (newline) - (let ((n 0)) - (vector-for-each (lambda (v) - (if (eq? v vs) 'foo - (if (> (vector-length v) n) - (set! n (vector-length v))))) - vs) - (display "longest: ") (write n) (newline) - (let ((hist (make-vector (+ n 1) 0))) - (vector-for-each (lambda (v) - (let ((l (vector-length v))) - (vector-set! hist l (+ (vector-ref hist l) 1)))) - vs) - (let loop ((i 0)) - (if (< i n) - (let ((m (vector-ref hist i))) - (if (> m 0) - (begin (write-padded i 6) - (write-padded m 7) - (write-padded (* (+ (* i m) 1) 4) 7) - (newline))) - (loop (+ i 1)))))))) - -(define (write-padded x pad) - (let ((s (if (symbol? x) - (symbol->string x) - (number->string x)))) - (do ((i (- pad (string-length s)) (- i 1))) - ((<= i 0) (display s)) - (write-char #\space)))) - - -(define (vector-for-each proc v) - (let ((z (vector-length v))) - (do ((i (- z 1) (- i 1))) - ((< i 0) #f) - (if (not (vector-unassigned? v i)) - (proc (vector-ref v i)))))) diff --git a/debug/wind-test.scm b/debug/wind-test.scm deleted file mode 100644 index 3057fa3..0000000 --- a/debug/wind-test.scm +++ /dev/null @@ -1,52 +0,0 @@ -; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING. - - -" -The correct output looks something like this: - -wind-1 f: 1 -wind-2 f: 2 -before-throw-out f: 3 -unwind-2 f: 2 -unwind-1 f: 1 -after-throw-out f: top -wind-1 f: 1 -wind-2 f: 2 -after-throw-in f: 3 -unwind-2 f: 2 -unwind-1 f: 1 -done f: top -" - -(define (wind-test) - (let* ((f (make-fluid 'top)) - (report (lambda (foo) - (write foo) - (display " f: ") - (write (fluid f)) - (newline)))) - ((call-with-current-continuation - (lambda (k1) - (let-fluid f 1 - (lambda () - (dynamic-wind - (lambda () (report 'wind-1)) - (lambda () - (let-fluid f 2 - (lambda () - (dynamic-wind - (lambda () (report 'wind-2)) - (lambda () - (let-fluid f 3 - (lambda () - (report 'before-throw-out) - (call-with-current-continuation - (lambda (k2) - (k1 (lambda () - (report 'after-throw-out) - (k2 #f))))) - (report 'after-throw-in) - (lambda () (report 'done))))) - (lambda () (report 'unwind-2)))))) - (lambda () (report 'unwind-1)))))))))) - diff --git a/doc/big-scheme.txt b/doc/big-scheme.txt deleted file mode 100644 index 847ba55..0000000 --- a/doc/big-scheme.txt +++ /dev/null @@ -1,314 +0,0 @@ - - Documentation for Big Scheme - - -Big Scheme is a set of generally useful facilities. - -Easiest way to access these things: - - > ,open big-scheme - Load structure big-scheme (y/n)? y - ... - -A better way is to use the module system. - ------ - -Ascii conversions - -(CHAR->ASCII ) => -(ASCII->CHAR ) => - These are identical to CHAR->INTEGER and INTEGER->CHAR except that - they use the ASCII encoding. - ------ - -Bitwise operations - -(BITWISE-NOT ) => -(BITWISE-AND ) => -(BITWISE-IOR ) => -(BITWISE-XOR ) => - These perform various logical operations on integers on a bit-by-bit - basis, using a two's-complement representation. - -(ARITHMETIC-SHIFT ) => - Shift the integer by the given bit count, shifting left for positive - counts and right for negative ones. A two's complement - representation is used. - ------ - -Hash tables - -(MAKE-TABLE) => -(MAKE-STRING-TABLE) => - Make a new, empty table. MAKE-TABLE returns a table that uses EQ? - for comparing keys and an ad-hoc hash function. String tables uses - strings for keys. - -(MAKE-TABLE-MAKER ) => - Returns a procedure of no arguments that makes tables that use the - given comparison and hash procedures. - ( ) => - ( ) => - -(TABLE? ) => - True if is a table. - -(TABLE-REF
) => - Return the value for in
, or #F if there is none. - should be of a type appropriate for
. - -(TABLE-SET!
) => - Make be the value of in
. should be of a - type appropriate for
. - -(TABLE-WALK
) => - Apply , which must accept two arguments, to every - associated key and value in
. - ------ - -Enumerations - -(DEFINE-ENUMERATION ( ...)) *SYNTAX* - Defines to be an enumeration with components - .... Also defines -COUNT to be the number of - components. - -(ENUM ) => *SYNTAX* - Evaluates to the value of within the enumeration - . For example, if (DEFINE-ENUMERATION COLOR (GREEN - RED)), then (ENUM COLOR GREEN) is zero and (ENUM COLOR RED) is one. - The mapping from name to integer is done at macro-expansion time, so - there is no run-time overhead. - -(ENUMERAND->NAME ) => - Returns the name associated with within . - E.g. (ENUMERAND->NAME 1 COLOR) => 'RED. - -(NAME->ENUMERAND ) => - Returns the integer associated with within . - E.g. (ENUMERAND->NAME 'GREEN COLOR) => 0. - ------ - -Port extensions - -(MAKE-TRACKING-INPUT-PORT ) => -(MAKE-TRACKING-OUTPUT-PORT ) => - These return ports that keep track of the current row and column and - are otherwise identical to their arguments. - -(MAKE-STRING-INPUT-PORT ) => - Returns a port that reads characters from the supplied string. - -(CALL-WITH-STRING-OUTPUT-PORT ) => - The procedure is called on a port. When it returns, CALL-WITH-STRING- - OUTPUT-PORT returns a string containing the characters written to the port. - -(WRITE-ONE-LINE ) => - The procedure is called on an output port. Output written to that - port is copied to until characters - have been written, at which point WRITE-ONE-LINE returns. - -(CURRENT-ROW ) => or #f -(CURRENT-COLUMN ) => or #f - These return the current read or write location of the port. #F is - returned if the port does not keep track of its location. - -(FRESH-LINE ) => - Write a newline character to if its current column is not 0. - -(INPUT-PORT? ) => -(OUTPUT-PORT? ) => - These are versions of the standard Scheme predicates that answer true for - extended ports. - ------ - -Queues - -(MAKE-QUEUE) => - Returns a new, empty queue. - -(ENQUEUE ) => - Puts on the queue. - -(DEQUEUE ) => - Removes and returns the first element of the queue. - -(QUEUE-EMPTY? ) => - True if the queue is empty. - -(QUEUE? ) => - True if is a queue. - -(QUEUE->LIST ) => - Returns a list of the elements of the queue, in order. - -(QUEUE-LENGTH ) => - The number of elements currently on the queue. - -(DELETE-FROM-QUEUE! ) => - Removes the first occurance of from the queue, returning true if - it was found and false otherwise. - ------ - -Little utility procedures - -(ATOM? ) => -(ATOM? x) == (NOT (PAIR? x)) - -(NULL-LIST? ) => - Returns #t for the empty list, #f for a pair, and signals an error - otherwise. - -(NEQ? ) => - (NEQ? x y) is the same as (NOT (EQ? x y)). - -(N= ) => - (N= x y) is the same as (NOT (= x y)). - -(IDENTITY ) => -(NO-OP ) => - These both just return their argument. NO-OP is guaranteed not to - be compiled in-line, IDENTITY may be. - ------ - -List utilities - -(MEMQ? ) => - Returns true if is in , false otherwise. - -(ANY? ) => - Returns true if is true for any element of . - -(EVERY? ) => - Returns true if is true for every element of . - -(ANY ) -(FIRST ) - ANY returns some element of for which is true, or - #F if there are none. FIRST does the same except that it returns - the first element for which is true. - -(FILTER ) -(FILTER! ) - Returns a list containing all of the elements of for which - is true. The order of the elements is preserved. - FILTER! may reuse the storage of . - -(FILTER-MAP ) - The same as FILTER except the returned list contains the results of - applying instead of elements of . (FILTER-MAP p - l) is the same as (FILTER IDENTITY (MAP p l)). - -(PARTITION-LIST ) => -(PARTITION-LIST! ) => - The first return value contains those elements for which - is true, the second contains the remaining elements. - The order of the elements is preserved. PARTITION-LIST! may resuse - the storage of the . - -(REMOVE-DUPLICATES ) => - Returns its argument with all duplicate elements removed. The first - instance of each element is preserved. - -(DELQ ) => -(DELQ! ) => -(DELETE ) => - All three of these return with some elements removed. DELQ - removes all elements EQ? to . DELQ! does the same and may - reuse the storage of the list argument. DELETE removes all elements - for which is true. - -(REVERSE! ) => - Destructively reverses . - -(SORT-LIST ) => -(SORT-LIST! ) => - Returns a sorted copy of . The sorting algorithm is stable. - (SORT-LIST '(6 5 1 3 2 4) <) => '(1 2 3 4 5 6) - ------ - -Additional syntax - -(DESTRUCTURE (( ) ...) ...) *SYNTAX* - The s are evaluated and their values are dissasembled - according to the corresponding patterns, with identifiers in the - patterns being bound to fresh locations holding the corresponding - part, and the body is evaluated in the extended environment. - Patterns may be any of the following: - - #f Discard the corresponding part. - Bind the to the part. - ( ...) The part must be a list at least as long as the - pattern. - ( ... . ) - The same thing, except that the final CDR of the - part is dissasembled according to . - #( ...) The part must be a vector at least as long as the - pattern. - -(RECEIVE ...) *SYNTAX* - => (CALL-WITH-VALUES (LAMBDA () ) (LAMBDA ...)) - Bind to the values returned by , and evaluate the - body in the resulting environment. - ------ - -Printing and related procedures - -(CONCATENATE-SYMBOL . ) - Returns the symbol whose name is produced by concatenating the DISPLAYed - representations of . - (CONCATENATE-SYMBOL 'abc "-" 4) => 'abc-4 - -(FORMAT . ) => or - Prints the arguments to the port as directed by the string. - should be either: - An output port. The output is written directly to the port. The result - of the call to FORMAT is undefined. - #T. The output is written to the current output port. The result of the - call to FORMAT is undefined. - #F. The output is written to a string, which is then the value returned - from the call to FORMAT. - Characters in which are not preceded by a ~ are written - directly to the output. Characters preceded by a ~ have the following - meaning (case is irrelevant; ~a and ~A have the same meaning): - ~~ prints a single ~ - ~A prints the next argument using DISPLAY - ~D prints the next argument as a decimal number - ~S prints the next argument using WRITE - ~% prints a newline character - ~& prints a NEWLINE character if the previous printed character was not one - (this is implemented using FRESH-LINE) - ~? performs a recursive call to FORMAT using the next two arguments as the - string and the list of arguments - -(ERROR . ) -(BREAKPOINT . ) - Signals an error or breakpoint condition, passing it the result of - applying FORMAT to the arguments. - -(P ) -(P ) -(PRETTY-PRINT ) - Pretty-print . The current output port is used if no port is - specified. is the starting offset. will be - pretty-printed to the right of this column. - ------ - -I couldn't bear to document DEFINE-RECORD-TYPE. - - ------ - -Original by RK, 26 Jan 1993. -Minor changes by JAR, 5 Dec 1993. diff --git a/doc/code.tex b/doc/code.tex deleted file mode 100644 index aa8de05..0000000 --- a/doc/code.tex +++ /dev/null @@ -1,94 +0,0 @@ -% Latex Macros for Lisp code in text. -% Based on macros found in C. Rich's library. - -\makeatletter - -% \vobeyspaces turns all spaces into non-breakable spaces. -% Note: this is like \@vobeyspaces except without spurious space in defn. - -{\catcode`\ =\active\gdef\vobeyspaces{\catcode`\ =\active\let =\@xobeysp}} - -% \def\vobeytabs turns all tabs into 8 non-breakable spaces - -{\catcode`\^^I=\active\gdef\vobeytabs{\catcode`\^^I=\active\let^^I=\xvobeytabs}} - -\def\xvobeytabs{\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp} - -% \vobeylines turns all cr's into non-breakable \par's - -{\catcode`\^^M=\active\gdef\vobeylines{\catcode`\^^M=\active\let^^M=\xvobeylines}} - -\def\xvobeylines{\par\penalty10000} - -% \obeycrsp turns cr's into non-breakable spaces - -{\catcode`\^^M=\active\gdef\obeycrsp{\catcode`\^^M=\active\let^^M=\@xobeysp}} - -%% \@noligs prevents ?` and !` from being treated as ligatures -%% added 19 April 86 [copied from Latex sources] - -\begingroup -\catcode``=13 -\gdef\@noligs{\let`=\@lquote} -\endgroup - -% Set up code environment, in which most of the common special characters -% appearing in code are treated verbatim, namely: _ # & ^ $ ~ @ " % -% *** JAR NEEDED $ AND _ IN SOME CODE *** - -% Note: \ { } are still enabled so that macros can be called in this -% environment. Use \\, \{ and \} to use these characters verbatim -% in this environment. - -% Note: this environment allows no breaking of lines whatsoever; not -% at spaces or hypens. To arrange for a break use the standard \- macro, -% or the \= macro which breaks, but inserts nothing. This is useful, -% for example for allowing hypenated identifiers to be broken, e.g. -% FOO-\=BAR. - -\def\setupcode{\parsep=0pt\parindent=0pt - \tt\frenchspacing\catcode``=13\@noligs% - \def\\{\char`\\}% - \@makeother\#\@makeother\&\@makeother\^%\@makeother\_\@makeother\$% - \@makeother\`\@makeother\'% - \@makeother\~\@makeother\@\@makeother\"\@makeother\%\vobeytabs\vobeyspaces} - -% Code environment as described above. Note that blank lines are -% not preserved, and lines are not kept on one page. Code is -% indented by the same amount as quotes. -% Note: to increase left margin, use \leftmargini=1in. -% was {\list{}{\parsep=0pt}\item[]\setupcode\obeylines}% -% then {\list{\parsep=0pt\listparindent=0pt\leftmargin=0pt}{}\item[]\setupcode% - -\newenvironment{bigcode}% - {\list{}{\parsep=0pt\leftmargin=0pt\labelwidth=0pt\itemindent=0pt% -\listparindent=0pt}\item[]\setupcode% -\obeylines}% - {\endlist} - -% Code is just like bigcode, but everything inside is kept on one page -% Note: This actually works by setting a huge penalty for breaking -% between lines of code. -% was {\list{}{\parsep=0pt}\item[]\setupcode\vobeylines}% - -\newenvironment{code}% - {\list{}{\parsep=0pt\leftmargin=0pt\labelwidth=0pt\itemindent=0pt% -\listparindent=0pt}\item[]\setupcode% -\vobeylines}% - {\endlist} - -% Reasonable separation between lines of code - -\newcommand{\codeskip}{\penalty0\vspace{2ex}} - -% \cd is used to build a code environment in the middle of text. -% Note: only difference from display code is that cr's are taken -% as unbreakable spaces instead of \par's. - -\newcommand{\cd}{\begingroup\setupcode\obeycrsp\startcode} - -\newcommand{\startcode}[1]{#1\endgroup} - -%\setbox0\hbox{\@xobeysp}\hline{43\wd0} - -\makeatother diff --git a/doc/external.txt b/doc/external.txt deleted file mode 100644 index 7dd15c2..0000000 --- a/doc/external.txt +++ /dev/null @@ -1,95 +0,0 @@ - - External function calls - - -(GET-EXTERNAL string) -Returns an external pointer to the given name. A null will be added to the -end of the name if there isn't already one. - -(LOOKUP-ALL-EXTERNALS) -Looks up all externals in the currently job. Ideally this should be called -automatically on startup. - -(EXTERNAL-CALL external arg1 arg2 ...) -Calls the external value, passing it the number of arguments (as a long), -and a pointer to a C array containing the rest of the arguments (also -a long). Don't mess with the array, it is really the Scheme 48 argument -stack. The arguments are probably in reverse order, I can't remember. - -(NULL-TERMINATE string) - - -The file dynload.c contains the function s48_dynamic_load which can -be called using EXTERNAL-CALL. To make it work you need to do the -following: - - 1) If you're using ultrix, link the VM using -N. - - 2) When invoking the VM, use the -o flag to pass it the name of the - executable file containing the VM. [This is done automatically by - the shell script created by "make".] - - 3) If your OS supports shared libraries, do as appropriate to arrange - for your C code to be position-independent and to create a shared - library. - -If dynamic loading doesn't work you can always link the external stuff -in with the VM. The dynamic loading code has problems. I am not much -of a Unix hacker. - -Here is a transcript on SunOS 4.something: - - kama$ gcc -fpic -c test.c - kama$ /bin/ld -assert pure-text -o test.so test.o - kama$ file test.so - test.so: sparc demand paged shared library executable not stripped - kama$ - kama$ scheme48 - 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. - > ,open externals - Load structure externals (y/n)? y - [externals - /usr/public/sun4/lib/scheme48/big/external.scm .............. - ] - > (define dynamic-load (get-external "s48_dynamic_load")) - > (external-call dynamic-load (null-terminate "test.so")) - #t - > (define test (get-external "test")) - > (external-call test "yow" 3) - string: yow - fixnum: 3 - #t - > - -If using cc instead of gcc, do "cc -pic -c ...". - -(get-external "_s48_dynamic_load") and (get-external "_test") might be -required on some versions of Unix (like maybe SGI). - -Here is file test.c: - - #include "/usr/local/include/scheme48.h" - #include - - scheme_value test () - long argc; scheme_value *argv; - { - int i; - for (i = argc-1; i >= 0; i--) { - scheme_value arg = argv[i]; - if (STRINGP(arg)) { - printf ("string: "); - fwrite(&STRING_REF(arg, 0), 1, STRING_LENGTH(arg), stdout); - printf ("\n"); - } - else if (FIXNUMP(arg)) { - printf("fixnum: %d\n", EXTRACT_FIXNUM(arg)); - } - else - printf("?\n"); - } - return SCHTRUE; - } diff --git a/doc/hacking.txt b/doc/hacking.txt deleted file mode 100644 index 081d7e5..0000000 --- a/doc/hacking.txt +++ /dev/null @@ -1,290 +0,0 @@ - -,bench -,load-package linker -,new-package =link= linker debuginfo defpackage -,load scripts.scm -(link-initial-system) - - -To change between initial image starting in mini-command (MINI) and -command (MAXI): - - 1. Definition of initial system's command module in comp-packages.scm: - MINI: (make-mini-command scheme) - MAXI: (make-command scheme) - 2. Location of (define-module (make-command ...)...): - MINI: more-packages.scm - MAXI: comp-packages.scm - 3. Location of (define-interface command-interface ...): - MINI: more-interfaces.scm - MAXI: interfaces.scm - - - - -> ,new-package z architecture primitives packages table enumerated debug-data -z> (let ((i 0)) - (table-walk (lambda (x y) (set! i (+ i 1))) - location-name-table) - i) -1385 -z> (vector-length (find-all-xs (name->enumerand 'location stob))) -1259 -(vector-length (find-all-xs (name->enumerand 'record stob))) -2150 - -(find-all-xs (name->enumerand 'record stob)) -z> (do ((i 0 (+ i 1)) - (j 0 (if (package? (vector-ref rs i)) (+ j 1) j))) ((= i (vector-length rs)) j)) -72 -z> - - - - -> ,new-package z architecture primitives compiler table -z> (vector-ref stob 10) -'template -z> stob -'#(pair symbol vector closure location port ratio record continuation extended-number template weak-pointer external unused-d-header1 unused-d-header2 string code-vector double bignum) -z> (vector-ref stob 7) -'record -z> (define rs (find-all-xs 7)) -z> (vector-length rs) -2178 -z> (define ls (find-all-xs 4)) -z> (vector-length ls) -1266 -z> - - - - -To get a fresh config package: - -,in config (define-structures ((config1 (export))) - (open defpackage built-in-structures more-structures)) -,config-package-is config1 - - -To load a linker with a fresh new compiler: - x48 -i new-scheme48.image -h 10000000 ,in reification reify-structures -'#{Procedure 8447 reify-structures} -debug-config> (define reify-structures ##) -debug-config> make-simple-package - -Error: undefined variable - make-simple-package - (package debug-config) -1 debug-config> -debug-config> (define-structures ((p (export start))) (open initial-system scheme-level-2 packages)) -debug-config> (define go (in p `(start ,(reify-structures (desirable-packages) (lambda (loc) `',loc))))) - - - -### Small images for exercising the linker and/or runtime system - -debug/tiny.image: debug/tiny.scm $(LINKER_IMAGE) - ($(START_LINKER_RUNNABLE) \ - echo "(load \"debug/tiny-packages.scm\")"; \ - echo "(link-simple-system '(debug tiny) 'start tiny-system)") \ - | $(LINKER_RUNNABLE) -i $(LINKER_IMAGE) - -debug/little.image: $(LINKER_IMAGE) $(CONFIG_FILES) $(little-files) - ($(START_LINKER_RUNNABLE) \ - echo "(load \"scripts.scm\")"; \ - echo "(link-little-system)") \ - | $(LINKER_RUNNABLE) -i $(LINKER_IMAGE) $(BIG_HEAP) - -debug/medium.image: $(LINKER_IMAGE) $(CONFIG_FILES) $(medium-files) - ($(START_LINKER_RUNNABLE) \ - echo "(load \"scripts.scm\")"; \ - echo "(link-medium-system)") \ - | $(LINKER_RUNNABLE) -i $(LINKER_IMAGE) $(BIG_HEAP) - - - echo "(define l-f (package-all-filenames little-system))"; \ - echo "(define m-f (package-all-filenames medium-system))"; \ - - 'little-files l-f 'medium-files m-f \ - - -[The following is from June 1992, and probably not quite compatible -with the current compiler internals.] - -To eliminate use of the stack GC to implement tail recursion, change -comp.scm as follows: - -(define (compile-unknown-call exp cenv depth cont) - (note-source-code - exp - (maybe-push-continuation (sequentially - (push-all (cdr exp) cenv 0) - (compile (car exp) - cenv - (length (cdr exp)) - (fall-through-cont)) - (instruction (if (return-cont? cont) - op/move-args-and-call - op/call) - (length (cdr exp)))) - depth - cont))) - - --------------------- - -Here's another cool thing. 6/28/93 - -(define-interface evaluation-interface - (export eval load eval-from-file)) - -(define-structure run evaluation-interface - (open scheme-level-2 syntactic packages scan - environments - signals - locations - features ;force-output - table - fluids) - (files (debug run))) - -,load-package run -,in run -,in package-commands (environment-for-syntax-promise) -(define cool (make-simple-package (list scheme) eval ## 'cool)) -,in command set-environment-for-commands! -(## cool) - -cool> ,inspect (lambda (x) x) -'#{Procedure 6394} - - [0: exp] '(lambda (x) x) - [1: env] '#{Package 286 cool} -inspect: -inspect: q -cool> - - - -(define (z s) - (define (show-type name static) - (write name) - (display " : ") - (write (static-type static)) - (newline)) - (if (package? s) - (for-each-definition (lambda (name static loc) - (show-type name static)) - s) - (interface-walk (lambda (name type) - (show-type name - (car (structure-lookup - s name #t)))) - (structure-interface s)))) - -; ,open expander syntactic packages reconstruction - -(define (e x) - (let ((p (interaction-environment))) - (let ((node (expand-form x p))) - (write (node-type node (package->environment p))) - (newline) - (eval node p)))) - - - -> (define hunk3 (lap hunk3 - 0 (check-nargs= 3) - 2 (pop) - 3 (make-stored-object 3 0) - 6 (return))) -> (hunk3 1 2 3) -'(1 . 2) -> (define cxr (lap cxr - 0 (check-nargs= 2) - 2 (pop) - 3 (stored-object-indexed-ref 0) - 5 (return))) -> (cxr (hunk3 1 2 3) 2) -3 -> - - -(define-syntax %cons - (lambda (e r c) - (let ((n (cadr e)) - (kind (caddr e))) - `(,(r 'lap) (%cons ,n ,kind) - (check-nargs= ,n) - (pop) - (make-stored-object ,n ,kind) - (return))))) - - -(define (& x) - (or (node-ref x 'uid) - (begin (set! *n* (+ *n* 1)) - (node-set! x 'uid *n*) - *n*)) - x) - -(define (uid n) (node-ref (& n) 'uid)) - -(define *n* 0) diff --git a/doc/latex-stuff.tex b/doc/latex-stuff.tex deleted file mode 100644 index 9ceb43d..0000000 --- a/doc/latex-stuff.tex +++ /dev/null @@ -1,45 +0,0 @@ - -% Latex macros for The Scheme of Things - -\newcommand{\ev}{\hbox{$\longrightarrow$}} -\newcommand{\asterisk}{\hbox{$\ast$}} -\newcommand{\foo}{\discretionary{}{}{}} -\newcommand{\var}[1]{\hbox{\em{}#1}} -\newcommand{\piece}[1]{\subsubsection*{#1}} -\newcommand{\syn}[1]{\hbox{$\langle$\rm#1$\rangle$}} -\newcommand{\xform}{\hbox{$\Longrightarrow$}} -\newcommand{\etc}{$\ldots$} -\newcommand{\ok}{\discretionary{}{}{}} - -\newcommand{\separator}{ -\vspace{1ex} -\begin{center} -\noindent \asterisk\hspace{1em}\asterisk\hspace{1em}\asterisk -\end{center} -\vspace{1ex}} - - -% ----------------------------------------------------------------------------- - %% doframeit draws a box around it argument by manipulating boxes. It - %% is used in the frame environments. - %% - %% Rene' Seindal (seindal@diku.dk) Fri Feb 12 16:03:07 1988 - %% added \fboxrule and \fboxsep to \doframeit - -\def\doframeit#1{\vbox{% - \hrule height\fboxrule - \hbox{% - \vrule width\fboxrule \kern\fboxsep - \vbox{\kern\fboxsep #1\kern\fboxsep }% - \kern\fboxsep \vrule width\fboxrule }% - \hrule height\fboxrule }} - - %% The frameit and Frameit environments formats text within a single - %% Anything can be framed, including verbatim text. - -\def\frameit{\smallskip \advance \linewidth by -7.5pt \setbox0=\vbox \bgroup -\strut \ignorespaces } - -\def\endframeit{\ifhmode \par \nointerlineskip \fi \egroup -\doframeit{\box0}} -% ----------------------------------------------------------------------------- diff --git a/doc/meeting.ps b/doc/meeting.ps deleted file mode 100644 index 3fcb07d..0000000 --- a/doc/meeting.ps +++ /dev/null @@ -1,1090 +0,0 @@ -%!PS-Adobe-2.0 -%%Creator: dvips 5.521 Copyright 1986, 1993 Radical Eye Software -%%CreationDate: Sat Jan 15 16:05:04 1994 -%%Pages: 8 -%%PageOrder: Ascend -%%BoundingBox: 0 0 612 792 -%%EndComments -%DVIPSCommandLine: dvips -f -%DVIPSSource: TeX output 1994.01.15:1605 -%%BeginProcSet: tex.pro -/TeXDict 250 dict def TeXDict begin /N{def}def /B{bind def}N /S{exch}N -/X{S N}B /TR{translate}N /isls false N /vsize 11 72 mul N /hsize 8.5 72 -mul N /landplus90{false}def /@rigin{isls{[0 landplus90{1 -1}{-1 1} -ifelse 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale -isls{landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div -hsize mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul -TR matrix currentmatrix dup dup 4 get round 4 exch put dup dup 5 get -round 5 exch put setmatrix}N /@landscape{/isls true N}B /@manualfeed{ -statusdict /manualfeed true put}B /@copies{/#copies X}B /FMat[1 0 0 -1 0 -0]N /FBB[0 0 0 0]N /nn 0 N /IE 0 N /ctr 0 N /df-tail{/nn 8 dict N nn -begin /FontType 3 N /FontMatrix fntrx N /FontBBox FBB N string /base X -array /BitMaps X /BuildChar{CharBuilder}N /Encoding IE N end dup{/foo -setfont}2 array copy cvx N load 0 nn put /ctr 0 N[}B /df{/sf 1 N /fntrx -FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0]N df-tail}B /E{ -pop nn dup definefont setfont}B /ch-width{ch-data dup length 5 sub get} -B /ch-height{ch-data dup length 4 sub get}B /ch-xoff{128 ch-data dup -length 3 sub get sub}B /ch-yoff{ch-data dup length 2 sub get 127 sub}B -/ch-dx{ch-data dup length 1 sub get}B /ch-image{ch-data dup type -/stringtype ne{ctr get /ctr ctr 1 add N}if}B /id 0 N /rw 0 N /rc 0 N /gp -0 N /cp 0 N /G 0 N /sf 0 N /CharBuilder{save 3 1 roll S dup /base get 2 -index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx 0 ch-xoff -ch-yoff ch-height sub ch-xoff ch-width add ch-yoff setcachedevice -ch-width ch-height true[1 0 0 -1 -.1 ch-xoff sub ch-yoff .1 add]{ -ch-image}imagemask restore}B /D{/cc X dup type /stringtype ne{]}if nn -/base get cc ctr put nn /BitMaps get S ctr S sf 1 ne{dup dup length 1 -sub dup 2 index S get sf div put}if put /ctr ctr 1 add N}B /I{cc 1 add D -}B /bop{userdict /bop-hook known{bop-hook}if /SI save N @rigin 0 0 -moveto /V matrix currentmatrix dup 1 get dup mul exch 0 get dup mul add -.99 lt{/QV}{/RV}ifelse load def pop pop}N /eop{SI restore showpage -userdict /eop-hook known{eop-hook}if}N /@start{userdict /start-hook -known{start-hook}if pop /VResolution X /Resolution X 1000 div /DVImag X -/IE 256 array N 0 1 255{IE S 1 string dup 0 3 index put cvn put}for -65781.76 div /vsize X 65781.76 div /hsize X}N /p{show}N /RMat[1 0 0 -1 0 -0]N /BDot 260 string N /rulex 0 N /ruley 0 N /v{/ruley X /rulex X V}B /V -{}B /RV statusdict begin /product where{pop product dup length 7 ge{0 7 -getinterval dup(Display)eq exch 0 4 getinterval(NeXT)eq or}{pop false} -ifelse}{false}ifelse end{{gsave TR -.1 -.1 TR 1 1 scale rulex ruley -false RMat{BDot}imagemask grestore}}{{gsave TR -.1 -.1 TR rulex ruley -scale 1 1 false RMat{BDot}imagemask grestore}}ifelse B /QV{gsave -transform round exch round exch itransform moveto rulex 0 rlineto 0 -ruley neg rlineto rulex neg 0 rlineto fill grestore}B /a{moveto}B /delta -0 N /tail{dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail} -B /c{-4 M}B /d{-3 M}B /e{-2 M}B /f{-1 M}B /g{0 M}B /h{1 M}B /i{2 M}B /j{ -3 M}B /k{4 M}B /w{0 rmoveto}B /l{p -4 w}B /m{p -3 w}B /n{p -2 w}B /o{p --1 w}B /q{p 1 w}B /r{p 2 w}B /s{p 3 w}B /t{p 4 w}B /x{0 S rmoveto}B /y{ -3 2 roll p a}B /bos{/SS save N}B /eos{SS restore}B end -%%EndProcSet -TeXDict begin 40258431 52099146 1000 300 300 () @start -/Fa 1 111 df<383C0044C6004702004602008E06000C06000C06000C0C00180C00180C -40181840181880300880300F00120E7F8D15>110 D E /Fb 3 111 -df<70F8F8F87005057C840D>58 D<70F8FCFC74040404080810102040060E7C840D>I<1E -07802318C023A06043C0704380704380708700E00700E00700E00700E00E01C00E01C00E -01C00E03821C03841C07041C07081C03083803101801E017147E931B>110 -D E /Fc 28 122 df<00003FE00000E01000018038000380780003007800070030000700 -000007000000070000000E0000000E0000000E000000FFFFE0000E00E0001C01C0001C01 -C0001C01C0001C01C0001C03800038038000380380003803800038070000380700007007 -000070071000700E2000700E2000700E2000E00E2000E0064000E0038000E0000000C000 -0001C0000001C000003180000079800000F3000000620000003C0000001D29829F1A>12 -D<7FF0FFE07FE00C037D8A10>45 D<01FFF800001F0000001E0000001E0000001E000000 -3C0000003C0000003C0000003C00000078000000780000007800000078000000F0000000 -F0000000F0000000F0000001E0000001E0000001E0000001E0008003C0010003C0010003 -C0030003C00200078006000780060007800C0007801C000F007800FFFFF800191F7D9E1D ->76 D<01FFFF80001E00E0001E0070001E0038001E003C003C003C003C003C003C003C00 -3C003C0078007800780078007800F0007800E000F003C000F00F0000FFFC0000F0000001 -E0000001E0000001E0000001E0000003C0000003C0000003C0000003C000000780000007 -80000007800000078000000F800000FFF000001E1F7D9E1F>80 D86 D<00F1800389C00707800E03801C03803C03 -80380700780700780700780700F00E00F00E00F00E00F00E20F01C40F01C40703C40705C -40308C800F070013147C9317>97 D<07803F8007000700070007000E000E000E000E001C -001C001CF01D0C3A0E3C0E380F380F700F700F700F700FE01EE01EE01EE01CE03CE03860 -7060E031C01F0010207B9F15>I<007E0001C1000300800E07801E07801C07003C020078 -0000780000780000F00000F00000F00000F00000F0000070010070020030040018380007 -C00011147C9315>I<0000780003F80000700000700000700000700000E00000E00000E0 -0000E00001C00001C000F1C00389C00707800E03801C03803C0380380700780700780700 -780700F00E00F00E00F00E00F00E20F01C40F01C40703C40705C40308C800F070015207C -9F17>I<007C01C207010E011C013C013802780C7BF07C00F000F000F000F00070007001 -70023804183807C010147C9315>I<00007800019C00033C00033C000718000700000700 -000E00000E00000E00000E00000E0001FFE0001C00001C00001C00001C00003800003800 -00380000380000380000700000700000700000700000700000700000E00000E00000E000 -00E00000C00001C00001C0000180003180007B0000F300006600003C00001629829F0E> -I<003C6000E27001C1E00380E00700E00F00E00E01C01E01C01E01C01E01C03C03803C03 -803C03803C03803C07003C07001C0F001C17000C2E0003CE00000E00000E00001C00001C -00301C00783800F0700060E0003F8000141D7E9315>I<01E0000FE00001C00001C00001 -C00001C000038000038000038000038000070000070000071E000763000E81800F01C00E -01C00E01C01C03801C03801C03801C0380380700380700380700380E10700E20700C2070 -1C20700C40E00CC060070014207D9F17>I<00C001E001E001C000000000000000000000 -000000000E003300230043804300470087000E000E000E001C001C001C00384038803080 -7080310033001C000B1F7C9E0E>I<0001800003C00003C0000380000000000000000000 -000000000000000000000000003C00004600008700008700010700010700020E00000E00 -000E00000E00001C00001C00001C00001C00003800003800003800003800007000007000 -00700000700000E00000E00030E00079C000F180006300003C00001228829E0E>I<01E0 -000FE00001C00001C00001C00001C0000380000380000380000380000700000700000703 -C00704200E08E00E11E00E21E00E40C01C80001D00001E00001FC00038E0003870003870 -00383840707080707080707080703100E03100601E0013207D9F15>I<03C01FC0038003 -800380038007000700070007000E000E000E000E001C001C001C001C0038003800380038 -007000700070007100E200E200E200E200640038000A207C9F0C>I<1C0F80F0002630C3 -18004740640C004780680E004700700E004700700E008E00E01C000E00E01C000E00E01C -000E00E01C001C01C038001C01C038001C01C038001C01C0708038038071003803806100 -380380E10038038062007007006600300300380021147C9325>I<1C0F802630C0474060 -4780604700704700708E00E00E00E00E00E00E00E01C01C01C01C01C01C01C0384380388 -3803083807083803107003303001C016147C931A>I<007C0001C3000301800E01C01E01 -C01C01E03C01E07801E07801E07801E0F003C0F003C0F003C0F00780F00700700F00700E -0030180018700007C00013147C9317>I<01C1E002621804741C04781C04701E04701E08 -E01E00E01E00E01E00E01E01C03C01C03C01C03C01C0380380780380700380E003C1C007 -2380071E000700000700000E00000E00000E00000E00001C00001C0000FFC000171D8093 -17>I<1C1E002661004783804787804707804703008E00000E00000E00000E00001C0000 -1C00001C00001C000038000038000038000038000070000030000011147C9313>114 -D<00FC030206010C030C070C060C000F800FF007F803FC003E000E700EF00CF00CE00840 -1020601F8010147D9313>I<018001C0038003800380038007000700FFF007000E000E00 -0E000E001C001C001C001C003800380038003820704070407080708031001E000C1C7C9B -0F>I<0E00C03300E02301C04381C04301C04701C08703800E03800E03800E03801C0700 -1C07001C07001C07101C0E20180E20180E201C1E200C264007C38014147C9318>I<0E03 -803307802307C04383C04301C04700C08700800E00800E00800E00801C01001C01001C01 -001C02001C02001C04001C04001C08000E300003C00012147C9315>I<0383800CC44010 -68E01071E02071E02070C040E00000E00000E00000E00001C00001C00001C00001C04063 -8080F38080F38100E5810084C60078780013147D9315>120 D<0E00C03300E02301C043 -81C04301C04701C08703800E03800E03800E03801C07001C07001C07001C07001C0E0018 -0E00180E001C1E000C3C0007DC00001C00001C00003800F03800F07000E06000C0C00043 -80003E0000131D7C9316>I E /Fd 10 117 df<03FF8000700000700000700000E00000 -E00000E00000E00001C00001C00001C00001C00003800003800003800003800007000007 -00100700100700200E00200E00600E00400E00C01C0380FFFF80141A7D9918>76 -D<03FFF800701C00700600700700E00700E00700E00700E00701C00E01C00E01C01C01C0 -3803807003FF800380000380000700000700000700000700000E00000E00000E00000E00 -001C0000FFC000181A7D991A>80 D<01E006181C08380870087010FFE0E000E000E000E0 -00E0086010602030C01F000D107C8F12>101 D<030706000000000000384C4E8E9C9C1C -3838707272E2E4643808197C980C>105 D<307C005986009E07009E07009C07009C0700 -380E00380E00380E00381C00701C80701C80703880703900E01900600E0011107C8F16> -110 D<01F006180C0C180E300E700E600EE00EE00EE00CE01CE018E030606030C01F000F -107C8F14>I<030F000590C009E0C009C06009C06009C0600380E00380E00380E00380E0 -0701C00701800703800703000E8E000E78000E00000E00001C00001C00001C00001C0000 -FF00001317808F14>I<30F059189E389C189C009C003800380038003800700070007000 -7000E00060000D107C8F10>114 D<03E004300830187018601C001F801FC00FE000E000 -60E060E06080C041803E000C107D8F10>I<06000E000E000E000E001C001C00FFC01C00 -38003800380038007000700070007000E100E100E100E200640038000A177C960D>I -E /Fe 24 124 df<00800100020004000C00080018003000300030006000600060006000 -E000E000E000E000E000E000E000E000E000E00060006000600060003000300030001800 -08000C00040002000100008009267D9B0F>40 D<8000400020001000180008000C000600 -060006000300030003000300038003800380038003800380038003800380038003000300 -030003000600060006000C0008001800100020004000800009267E9B0F>I<60F0F07010 -101020204080040B7D830B>44 D<60F0F06004047D830B>46 D<03000700FF0007000700 -070007000700070007000700070007000700070007000700070007000700070007000700 -FFF00C187D9713>49 D<0F80106020304038803CC01CE01C401C003C0038003800700060 -00C001800100020004040804100430083FF87FF8FFF80E187E9713>I<00300030007000 -F000F001700370027004700C7008701070307020704070C070FFFF007000700070007000 -70007007FF10187F9713>52 D<07801860303070306018E018E018E01CE01CE01C601C60 -3C303C185C0F9C001C00180018003870307060604021801F000E187E9713>57 -D68 D<007F000001C1C000070070000E0038001C001C003C -001E0038000E0078000F0070000700F0000780F0000780F0000780F0000780F0000780F0 -000780F0000780F000078078000F0078000F0038000E003C001E001C001C000E00380007 -00700001C1C000007F0000191A7E991E>79 D<7FFFFF00701C0700401C0100401C0100C0 -1C0180801C0080801C0080801C0080001C0000001C0000001C0000001C0000001C000000 -1C0000001C0000001C0000001C0000001C0000001C0000001C0000001C0000001C000000 -1C0000001C0000001C000003FFE000191A7F991C>84 D86 D<3F8070C070E0207000 -70007007F01C7030707070E070E071E071E0F171FB1E3C10107E8F13>97 -DI<07F80C1C381C30087000E000E000E000E000E000E000 -7000300438080C1807E00E107F8F11>I<07C01C3030187018600CE00CFFFCE000E000E0 -00E0006000300438080C1807E00E107F8F11>101 D<18003C003C001800000000000000 -000000000000FC001C001C001C001C001C001C001C001C001C001C001C001C001C001C00 -FF80091A80990A>105 D109 DI<07E01C3830 -0C700E6006E007E007E007E007E007E0076006700E381C1C3807E010107F8F13>II114 D<0400040004000C000C001C003C00FFC01C001C001C001C001C001C001C -001C001C201C201C201C201C200E4003800B177F960F>116 D123 -D E /Ff 1 50 df<0C003C00CC000C000C000C000C000C000C000C000C000C000C000C00 -0C00FF8009107E8F0F>49 D E /Fg 30 121 df<0000600000E00000E00001C00001C000 -0380000380000380000700000700000700000E00000E00001C00001C00001C0000380000 -380000380000700000700000E00000E00000E00001C00001C00003800003800003800007 -00000700000700000E00000E00001C00001C00001C000038000038000038000070000070 -0000E00000E00000C00000132D7DA11A>47 D<387CFEFEFE7C38000000000000387CFEFE -FE7C3807147C930F>58 D<0000E000000000E000000001F000000001F000000001F00000 -0003F800000003F800000006FC00000006FC0000000EFE0000000C7E0000000C7E000000 -183F000000183F000000303F800000301F800000701FC00000600FC00000600FC00000C0 -07E00000FFFFE00001FFFFF000018003F000018003F000030001F800030001F800060001 -FC00060000FC000E0000FE00FFE00FFFE0FFE00FFFE0231F7E9E28>65 -D<0007FC02003FFF0E00FE03DE03F000FE07E0003E0FC0001E1F80001E3F00000E3F0000 -0E7F0000067E0000067E000006FE000000FE000000FE000000FE000000FE000000FE0000 -00FE0000007E0000007E0000067F0000063F0000063F00000C1F80000C0FC0001807E000 -3803F0007000FE01C0003FFF800007FC001F1F7D9E26>67 D69 D73 D77 D<03FC080FFF381E03F83800 -F8700078700038F00038F00018F00018F80000FC00007FC0007FFE003FFF801FFFE00FFF -F007FFF000FFF80007F80000FC00007C00003CC0003CC0003CC0003CE00038E00078F800 -70FE01E0E7FFC081FF00161F7D9E1D>83 D85 -D<07FC001FFF003F0F803F07C03F03E03F03E00C03E00003E0007FE007FBE01F03E03C03 -E07C03E0F803E0F803E0F803E0FC05E07E0DE03FF8FE0FE07E17147F9319>97 -D<01FE0007FF801F0FC03E0FC03E0FC07C0FC07C0300FC0000FC0000FC0000FC0000FC00 -00FC00007C00007E00003E00603F00C01F81C007FF0001FC0013147E9317>99 -D<0007F80007F80000F80000F80000F80000F80000F80000F80000F80000F80000F80000 -F801F8F80FFEF81F83F83E01F87E00F87C00F87C00F8FC00F8FC00F8FC00F8FC00F8FC00 -F8FC00F87C00F87C00F87E00F83E01F81F07F80FFEFF03F8FF18207E9F1D>I<01FE0007 -FF800F83C01E01E03E00F07C00F07C00F8FC00F8FFFFF8FFFFF8FC0000FC0000FC00007C -00007C00003E00181E00180F807007FFE000FF8015147F9318>I<001F8000FFC001F3E0 -03E7E003C7E007C7E007C3C007C00007C00007C00007C00007C000FFFC00FFFC0007C000 -07C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C000 -07C00007C00007C0003FFC003FFC0013207F9F10>I<01FC3C07FFFE0F079E1E03DE3E03 -E03E03E03E03E03E03E03E03E01E03C00F07800FFF0009FC001800001800001C00001FFF -800FFFF007FFF81FFFFC3C007C70003EF0001EF0001EF0001E78003C78003C3F01F80FFF -E001FF00171E7F931A>II<1C003E007F007F007F003E001C00000000000000000000000000FF00FF00 -1F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F00FFE0FFE0 -0B217EA00E>I107 DIII<01FF00 -07FFC01F83F03E00F83E00F87C007C7C007CFC007EFC007EFC007EFC007EFC007EFC007E -7C007C7C007C3E00F83E00F81F83F007FFC001FF0017147F931A>II114 D<0FE63FFE701E600EE006E006F800FFC07FF83FFC1FFE03FE00 -1FC007C007E007F006F81EFFFCC7F010147E9315>I<0180018001800380038003800780 -0F803F80FFFCFFFC0F800F800F800F800F800F800F800F800F800F800F860F860F860F86 -0F8607CC03F801F00F1D7F9C14>IIIII E /Fh 6 106 df0 D<01800180018001800180 -C183F18F399C0FF003C003C00FF0399CF18FC1830180018001800180018010147D9417> -3 D<03C00FF01FF83FFC7FFE7FFEFFFFFFFFFFFFFFFFFFFFFFFF7FFE7FFE3FFC1FF80FF0 -03C010127D9317>15 D<0000000400000000020000000002000000000100000000008000 -000000400000000020FFFFFFFFFCFFFFFFFFFC0000000020000000004000000000800000 -00010000000002000000000200000000040026107D922D>33 D<004000C0018001800180 -0300030003000600060006000C000C00180018001800300030003000600060006000C000 -C0006000600060003000300030001800180018000C000C00060006000600030003000300 -01800180018000C000400A2E7CA112>104 DI E /Fi 40 122 df<70F8F8F8F8F8F8F8F8F8F8F8F8F8F8F8F870 -000000000070F8F8F870051C779B18>33 D<030600078F00078F00078F00078F00078F00 -078F007FFFC0FFFFE0FFFFE07FFFC00F1E000F1E000F1E000F1E000F1E000F1E007FFFC0 -FFFFE0FFFFE07FFFC01E3C001E3C001E3C001E3C001E3C001E3C000C1800131C7E9B18> -35 D<387C7C7E3E0E0E0E1C1C38F8F0C0070E789B18>39 D<007000F001E003C007800F -001E001C00380038007000700070007000E000E000E000E000E000E000E000E000700070 -0070007000380038001C001E000F00078003C001F000F000700C24799F18>I<6000F000 -78003C001E000F000780038001C001C000E000E000E000E0007000700070007000700070 -0070007000E000E000E000E001C001C0038007800F001E003C007800F00060000C247C9F -18>I<01C00001C00001C00001C000C1C180F1C780F9CF807FFF001FFC0007F00007F000 -1FFC007FFF00F9CF80F1C780C1C18001C00001C00001C00001C00011147D9718>I<0060 -0000F00000F00000F00000F00000F00000F00000F0007FFFC0FFFFE0FFFFE07FFFC000F0 -0000F00000F00000F00000F00000F00000F00000600013147E9718>I<7FFF00FFFF80FF -FF807FFF0011047D8F18>45 D<3078FCFC78300606778518>I<03F0000FFE003FFF007C -0F807003C0E001C0F000E0F000E06000E00000E00000E00001C00001C00003C000078000 -0F00001E00003C0000780000F00001E00007C0000F80001E00E03C00E07FFFE0FFFFE07F -FFE0131C7E9B18>50 D<07F8001FFE003FFF007807807803C07801C03001C00001C00003 -C0000380000F0003FF0003FE0003FF000007800003C00001C00000E00000E00000E0F000 -E0F000E0F001C0F003C07C07803FFF001FFE0003F800131C7E9B18>I<1FFF803FFF803F -FF803800003800003800003800003800003800003800003800003BF8003FFE003FFF003C -07801803C00001C00000E00000E06000E0F000E0F000E0E001C07003C07C0F803FFF001F -FC0003F000131C7E9B18>53 D<007E0001FF0007FF800F83C01E03C01C03C03801803800 -00700000700000E1F800E7FE00FFFF00FE0780F803C0F001C0F000E0E000E0F000E07000 -E07000E07000E03801C03C03C01E07800FFF0007FE0001F800131C7E9B18>I<600000F0 -0000FC00007E00003F00001FC00007E00003F00001FC00007E00003F00001F80001F8000 -3F00007E0001FC0003F00007E0001FC0003F00007E0000FC0000F0000060000011187D99 -18>62 D<0FF0003FFC007FFF00700F00F00380F00380600780000F00003E00007C0001F0 -0001E00003C00003C00003C00003C00003C0000380000000000000000000000000000000 -0003800007C00007C00007C000038000111C7D9B18>I<007C0001FE0007FF000F87801E -03C03C1DC0387FC070FFE071E3E071C1E0E1C1E0E380E0E380E0E380E0E380E0E380E0E3 -80E0E1C1C071C1C071E3C070FF80387F003C1C001E00E00F83E007FFC001FF80007E0013 -1C7E9B18>I<1FE0003FF8007FFC00781E00300E0000070000070000FF0007FF001FFF00 -7F0700780700E00700E00700E00700F00F00781F003FFFF01FFBF007E1F014147D9318> -97 D<7E0000FE00007E00000E00000E00000E00000E00000E00000E3E000EFF800FFFC0 -0FC1E00F80E00F00700E00700E00380E00380E00380E00380E00380E00380F00700F0070 -0F80E00FC1E00FFFC00EFF80063E00151C809B18>I<01FE0007FF001FFF803E07803803 -00700000700000E00000E00000E00000E00000E00000E000007000007001C03801C03E03 -C01FFF8007FF0001FC0012147D9318>I<001F80003F80001F8000038000038000038000 -038000038003E3800FFB801FFF803C1F80380F80700780700380E00380E00380E00380E0 -0380E00380E00380700780700780380F803C1F801FFFF00FFBF803E3F0151C7E9B18>I< -01F00007FC001FFE003E0F00380780700380700380E001C0E001C0FFFFC0FFFFC0FFFFC0 -E000007000007001C03801C03E03C01FFF8007FF0001FC0012147D9318>I<001F80007F -C000FFE000E1E001C0C001C00001C00001C0007FFFC0FFFFC0FFFFC001C00001C00001C0 -0001C00001C00001C00001C00001C00001C00001C00001C00001C00001C00001C0007FFF -007FFF007FFF00131C7F9B18>I<01E1F007FFF80FFFF81E1E301C0E0038070038070038 -07003807003807001C0E001E1E001FFC001FF80039E0003800001C00001FFE001FFFC03F -FFE07801F0700070E00038E00038E00038E000387800F07E03F01FFFC00FFF8001FC0015 -1F7F9318>I<7E0000FE00007E00000E00000E00000E00000E00000E00000E3E000EFF80 -0FFFC00FC1C00F80E00F00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E0 -0E00E00E00E00E00E07FC3FCFFE7FE7FC3FC171C809B18>I<03800007C00007C00007C0 -000380000000000000000000000000007FC000FFC0007FC00001C00001C00001C00001C0 -0001C00001C00001C00001C00001C00001C00001C00001C00001C00001C000FFFF00FFFF -80FFFF00111D7C9C18>I<0038007C007C007C003800000000000000000FFC1FFC0FFC00 -1C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C00 -1C001C001C001C6038F078FFF07FE03F800E277E9C18>I<7FE000FFE0007FE00000E000 -00E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E000 -00E00000E00000E00000E00000E00000E00000E00000E00000E0007FFFC0FFFFE07FFFC0 -131C7E9B18>108 D<7CE0E000FFFBF8007FFFF8001F1F1C001E1E1C001E1E1C001C1C1C -001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C -001C1C1C007F1F1F00FFBFBF807F1F1F001914819318>I<7E3E00FEFF807FFFC00FC1C0 -0F80E00F00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E0 -0E00E07FC3FCFFE7FE7FC3FC1714809318>I<01F0000FFE001FFF003E0F803803807001 -C07001C0E000E0E000E0E000E0E000E0E000E0F001E07001C07803C03C07803E0F801FFF -000FFE0001F00013147E9318>I<7E3E00FEFF807FFFC00FC1E00F80E00F00700E00700E -00380E00380E00380E00380E00380E00380F00700F00700F80E00FC1E00FFFC00EFF800E -3E000E00000E00000E00000E00000E00000E00000E00007FC000FFE0007FC000151E8093 -18>I<01E38007FB801FFF803E1F80380F80700780700780E00380E00380E00380E00380 -E00380E00380700780700780380F803C1F801FFF800FFB8003E380000380000380000380 -000380000380000380000380003FF8003FF8003FF8151E7E9318>I<7F87E0FF9FF07FBF -F803F87803F03003E00003C00003C0000380000380000380000380000380000380000380 -000380000380007FFE00FFFF007FFE0015147F9318>I<07F7003FFF007FFF00780F00E0 -0700E00700E007007C00007FE0001FFC0003FE00001F00600780E00380E00380F00380F8 -0F00FFFF00FFFC00E7F00011147D9318>I<0180000380000380000380000380007FFFC0 -FFFFC0FFFFC0038000038000038000038000038000038000038000038000038000038040 -0380E00380E00380E001C1C001FFC000FF80003E0013197F9818>I<7E07E0FE0FE07E07 -E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00 -E00E01E00F03E007FFFC03FFFE01FCFC1714809318>I<7F8FF0FF8FF87F8FF01E03C00E -03800E03800E0380070700070700070700038E00038E00038E00038E0001DC0001DC0001 -DC0000F80000F80000700015147F9318>II<7F8FF07F9FF07F8FF0070700078E00039E0001DC0001F8 -0000F80000700000F00000F80001DC00039E00038E000707000F07807F8FF0FF8FF87F8F -F015147F9318>I<7F8FF0FF8FF87F8FF00E01C00E03800E038007038007070007070003 -8700038600038E0001CE0001CE0000CC0000CC0000DC0000780000780000780000700000 -700000700000F00000E00079E0007BC0007F80003F00001E0000151E7F9318>I -E /Fj 73 123 df<001F83E000F06E3001C078780380F8780300F0300700700007007000 -0700700007007000070070000700700007007000FFFFFF80070070000700700007007000 -070070000700700007007000070070000700700007007000070070000700700007007000 -0700700007007000070070000700700007007000070070007FE3FF001D20809F1B>11 -D<003F0000E0C001C0C00381E00701E00701E00700000700000700000700000700000700 -00FFFFE00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700 -E00700E00700E00700E00700E00700E00700E00700E07FC3FE1720809F19>I<001F81F8 -0000F04F040001C07C06000380F80F000300F00F000700F00F0007007000000700700000 -0700700000070070000007007000000700700000FFFFFFFF000700700700070070070007 -007007000700700700070070070007007007000700700700070070070007007007000700 -700700070070070007007007000700700700070070070007007007000700700700070070 -070007007007007FE3FE3FF02420809F26>14 D<7038F87CFC7EFC7E743A040204020402 -0804080410081008201040200F0E7E9F17>34 D<70F8FCFC74040404080810102040060E -7C9F0D>39 D<0020004000800100020006000C000C001800180030003000300070006000 -60006000E000E000E000E000E000E000E000E000E000E000E000E0006000600060007000 -300030003000180018000C000C000600020001000080004000200B2E7DA112>I<800040 -002000100008000C00060006000300030001800180018001C000C000C000C000E000E000 -E000E000E000E000E000E000E000E000E000E000C000C000C001C0018001800180030003 -00060006000C00080010002000400080000B2E7DA112>I<70F8FCFC7404040408081010 -2040060E7C840D>44 DI<70F8F8F87005057C840D>I<03F0000E -1C001C0E00180600380700700380700380700380700380F003C0F003C0F003C0F003C0F0 -03C0F003C0F003C0F003C0F003C0F003C0F003C0F003C0F003C070038070038070038078 -07803807001806001C0E000E1C0003F000121F7E9D17>48 D<018003800F80F380038003 -800380038003800380038003800380038003800380038003800380038003800380038003 -80038003800380038007C0FFFE0F1E7C9D17>I<03F0000C1C00100E0020070040078080 -0780F007C0F803C0F803C0F803C02007C00007C0000780000780000F00000E00001C0000 -380000700000600000C0000180000300000600400C00401800401000803FFF807FFF80FF -FF80121E7E9D17>I<03F0000C1C00100E00200F00780F80780780780780380F80000F80 -000F00000F00000E00001C0000380003F000003C00000E00000F000007800007800007C0 -2007C0F807C0F807C0F807C0F00780400780400F00200E001C3C0003F000121F7E9D17> -I<000600000600000E00000E00001E00002E00002E00004E00008E00008E00010E00020E -00020E00040E00080E00080E00100E00200E00200E00400E00C00E00FFFFF0000E00000E -00000E00000E00000E00000E00000E0000FFE0141E7F9D17>I<1803001FFE001FFC001F -F8001FE00010000010000010000010000010000010000011F000161C00180E0010070010 -07800003800003800003C00003C00003C07003C0F003C0F003C0E0038040038040070020 -0600100E000C380003E000121F7E9D17>I<007C000182000701000E03800C07801C0780 -380300380000780000700000700000F1F000F21C00F40600F80700F80380F80380F003C0 -F003C0F003C0F003C0F003C07003C07003C07003803803803807001807000C0E00061C00 -01F000121F7E9D17>I<4000007FFFC07FFF807FFF804001008002008002008004000008 -0000080000100000200000200000400000400000C00000C00001C0000180000380000380 -00038000038000078000078000078000078000078000078000078000030000121F7D9D17 ->I<03F0000C0C001006003003002001806001806001806001807001807803003E03003F -06001FC8000FF00003F80007FC000C7E00103F00300F806003804001C0C001C0C000C0C0 -00C0C000C0C000806001802001001002000C0C0003F000121F7E9D17>I<03F0000E1800 -1C0C00380600380700700700700380F00380F00380F003C0F003C0F003C0F003C0F003C0 -7007C07007C03807C0180BC00E13C003E3C0000380000380000380000700300700780600 -780E00700C002018001070000FC000121F7E9D17>I<70F8F8F870000000000000000000 -0070F8F8F87005147C930D>I<70F8F8F8700000000000000000000070F0F8F878080808 -101010202040051D7C930D>I<0FC0307040384038E03CF03CF03C603C0038007000E000 -C001800180010003000200020002000200020002000000000000000000000007000F800F -800F8007000E207D9F15>63 D<000100000003800000038000000380000007C0000007C0 -000007C0000009E0000009E0000009E0000010F0000010F0000010F00000207800002078 -000020780000403C0000403C0000403C0000801E0000801E0000FFFE0001000F0001000F -0001000F00020007800200078002000780040003C00E0003C01F0007E0FFC03FFE1F207F -9F22>65 DI<000FC040007030C0 -01C009C0038005C0070003C00E0001C01E0000C01C0000C03C0000C07C0000407C000040 -78000040F8000000F8000000F8000000F8000000F8000000F8000000F8000000F8000000 -F8000000780000007C0000407C0000403C0000401C0000401E0000800E00008007000100 -0380020001C0040000703800000FC0001A217D9F21>IIII<000FE0200078186000E004E0038002E0 -070001E00F0000E01E0000601E0000603C0000603C0000207C00002078000020F8000000 -F8000000F8000000F8000000F8000000F8000000F8000000F8007FFCF80003E0780001E0 -7C0001E03C0001E03C0001E01E0001E01E0001E00F0001E0070001E0038002E000E00460 -00781820000FE0001E217D9F24>III<0F -FFC0007C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C0000 -3C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C00203C00F8 -3C00F83C00F83C00F0380040780040700030E0000F800012207E9E17>III78 -D<001F800000F0F00001C0380007801E000F000F000E0007001E0007803C0003C03C0003 -C07C0003E0780001E0780001E0F80001F0F80001F0F80001F0F80001F0F80001F0F80001 -F0F80001F0F80001F0F80001F0780001E07C0003E07C0003E03C0003C03C0003C01E0007 -800E0007000F000F0007801E0001C0380000F0F000001F80001C217D9F23>II82 D<07E0800C1980100780300380600180600180E00180E00080E0 -0080E00080F00000F000007800007F00003FF0001FFC000FFE0003FF00001F8000078000 -03C00003C00001C08001C08001C08001C08001C0C00180C00380E00300F00600CE0C0081 -F80012217D9F19>I<7FFFFFE0780F01E0600F0060400F0020400F0020C00F0030800F00 -10800F0010800F0010800F0010000F0000000F0000000F0000000F0000000F0000000F00 -00000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F00 -00000F0000000F0000000F0000000F0000001F800007FFFE001C1F7E9E21>IIII<7FF83F -F80FE00FC007C0070003C0020001E0040001F00C0000F0080000781000007C1000003C20 -00003E4000001E4000000F8000000F8000000780000003C0000007E0000005E0000009F0 -000018F8000010780000207C0000603C0000401E0000801F0001800F0001000780020007 -C0070003C01F8007E0FFE01FFE1F1F7F9E22>I<08041008201020104020402080408040 -8040B85CFC7EFC7E7C3E381C0F0E7B9F17>92 D<081020204040808080B8FCFC7C38060E -7D9F0D>96 D<1FE000303000781800781C00300E00000E00000E00000E0000FE00078E00 -1E0E00380E00780E00F00E10F00E10F00E10F01E10781E103867200F83C014147E9317> -I<0E0000FE00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00 -000E3E000EC3800F01C00F00E00E00E00E00700E00700E00780E00780E00780E00780E00 -780E00780E00700E00700E00E00F00E00D01C00CC300083E0015207F9F19>I<03F80E0C -1C1E381E380C70007000F000F000F000F000F000F00070007000380138011C020E0C03F0 -10147E9314>I<000380003F800003800003800003800003800003800003800003800003 -8000038000038003E380061B801C0780380380380380700380700380F00380F00380F003 -80F00380F00380F003807003807003803803803807801C07800E1B8003E3F815207E9F19 ->I<03F0000E1C001C0E00380700380700700700700380F00380F00380FFFF80F00000F0 -0000F000007000007000003800801800800C010007060001F80011147F9314>I<007C00 -C6018F038F07060700070007000700070007000700FFF007000700070007000700070007 -00070007000700070007000700070007000700070007007FF01020809F0E>I<0000E003 -E3300E3C301C1C30380E00780F00780F00780F00780F00780F00380E001C1C001E380033 -E0002000002000003000003000003FFE001FFF800FFFC03001E0600070C00030C00030C0 -0030C000306000603000C01C038003FC00141F7F9417>I<0E0000FE00000E00000E0000 -0E00000E00000E00000E00000E00000E00000E00000E00000E3E000E43000E81800F01C0 -0F01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C0 -0E01C00E01C00E01C0FFE7FC16207F9F19>I<1C003E003E003E001C0000000000000000 -00000000000E007E000E000E000E000E000E000E000E000E000E000E000E000E000E000E -000E000E000E00FFC00A1F809E0C>I<00E001F001F001F000E000000000000000000000 -0000007007F000F000700070007000700070007000700070007000700070007000700070 -00700070007000700070007000706070F060F0C061803F000C28829E0E>I<0E0000FE00 -000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0FF00E03 -C00E03000E02000E04000E08000E10000E30000E70000EF8000F38000E1C000E1E000E0E -000E07000E07800E03800E03C00E03E0FFCFF815207F9F18>I<0E00FE000E000E000E00 -0E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E00 -0E000E000E000E000E000E000E000E00FFE00B20809F0C>I<0E1F01F000FE618618000E -81C81C000F00F00E000F00F00E000E00E00E000E00E00E000E00E00E000E00E00E000E00 -E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E0 -0E000E00E00E000E00E00E00FFE7FE7FE023147F9326>I<0E3E00FE43000E81800F01C0 -0F01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C0 -0E01C00E01C00E01C0FFE7FC16147F9319>I<01F800070E001C03803801C03801C07000 -E07000E0F000F0F000F0F000F0F000F0F000F0F000F07000E07000E03801C03801C01C03 -80070E0001F80014147F9317>I<0E3E00FEC3800F01C00F00E00E00E00E00F00E00700E -00780E00780E00780E00780E00780E00780E00700E00F00E00E00F01E00F01C00EC3000E -3E000E00000E00000E00000E00000E00000E00000E00000E0000FFE000151D7F9319>I< -03E0800619801C05803C0780380380780380700380F00380F00380F00380F00380F00380 -F003807003807803803803803807801C0B800E138003E380000380000380000380000380 -000380000380000380000380003FF8151D7E9318>I<0E78FE8C0F1E0F1E0F0C0E000E00 -0E000E000E000E000E000E000E000E000E000E000E000E00FFE00F147F9312>I<1F9030 -704030C010C010C010E00078007F803FE00FF00070803880188018C018C018E030D0608F -800D147E9312>I<020002000200060006000E000E003E00FFF80E000E000E000E000E00 -0E000E000E000E000E000E000E080E080E080E080E080610031001E00D1C7F9B12>I<0E -01C0FE1FC00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E -01C00E01C00E01C00E01C00E03C00603C0030DC001F1FC16147F9319>III<7FC3FC0F01E00701C007018003810001C20000E40000EC00007800003800003C -00007C00004E000087000107000303800201C00601E01E01E0FF07FE1714809318>II<3FFF380E200E201C40384078407000 -E001E001C00380078007010E011E011C0338027006700EFFFE10147F9314>I -E /Fk 3 54 df<03000700FF000700070007000700070007000700070007000700070007 -00070007000700070007007FF00C157E9412>49 D<00300030007000F001F00170027004 -7008701870107020704070C070FFFE0070007000700070007003FE0F157F9412>52 -D<20303FE03FC0240020002000200020002F8030E020700030003800384038E038E03880 -30406020C01F000D157E9412>I E /Fl 20 118 df<000E00001E00007E0007FE00FFFE -00FFFE00F8FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE -0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE -0000FE0000FE0000FE0000FE0000FE0000FE0000FE007FFFFE7FFFFE7FFFFE17277BA622 ->49 D<00FF800003FFF0000FFFFC001F03FE003800FF007C007F80FE003FC0FF003FC0FF -003FE0FF001FE0FF001FE07E001FE03C003FE000003FE000003FC000003FC000007F8000 -007F000000FE000000FC000001F8000003F0000003E00000078000000F0000001E000000 -3C00E0007000E000E000E001C001C0038001C0070001C00FFFFFC01FFFFFC03FFFFFC07F -FFFFC0FFFFFF80FFFFFF80FFFFFF801B277DA622>I<007F800001FFF00007FFF8000FE0 -FC001F807E003F803F007F003F007F001F80FF001F80FF001FC0FF001FC0FF001FC0FF00 -1FE0FF001FE0FF001FE0FF001FE07F001FE07F003FE03F003FE01F807FE00F807FE007C1 -DFE003FF9FE0007E1FE000001FE000001FC000001FC000001FC000003F801F003F803F80 -3F003F803F003F807E003F807C001F01F8001E03F0000FFFE00007FF800001FE00001B27 -7DA622>57 D<1C003E007F00FF80FF80FF807F003E001C00000000000000000000000000 -0000000000001C003E007F00FF80FF80FF807F003E001C00091B7B9A13>I<01FFFFF001 -FFFFF001FFFFF00001FE000001FE000001FE000001FE000001FE000001FE000001FE0000 -01FE000001FE000001FE000001FE000001FE000001FE000001FE000001FE000001FE0000 -01FE000001FE000001FE000001FE000001FE000001FE000001FE000001FE000001FE0000 -01FE000001FE001801FE007E01FE00FF01FE00FF01FE00FF01FE00FF01FC007E03F8007C -03F0003E0FE0000FFFC00003FE00001C297DA824>74 D77 -D<007F806003FFF0E007FFF9E00F807FE01F001FE03E0007E07C0003E07C0001E0FC0001 -E0FC0001E0FC0000E0FE0000E0FE0000E0FF000000FFC000007FFE00007FFFE0003FFFFC -001FFFFE000FFFFF8007FFFFC003FFFFE000FFFFE00007FFF000007FF000000FF8000007 -F8000003F8600001F8E00001F8E00001F8E00001F8F00001F0F00001F0F80003F0FC0003 -E0FF0007C0FFE01F80F3FFFF00E0FFFE00C01FF0001D297CA826>83 -D<7FFFFFFFFFC07FFFFFFFFFC07FFFFFFFFFC07F803FC03FC07E003FC007C078003FC003 -C078003FC003C070003FC001C0F0003FC001E0F0003FC001E0E0003FC000E0E0003FC000 -E0E0003FC000E0E0003FC000E0E0003FC000E000003FC0000000003FC0000000003FC000 -0000003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC000 -0000003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC000 -0000003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC000 -0000003FC00000007FFFFFE000007FFFFFE000007FFFFFE0002B287EA730>I<001FF800 -00FFFE0003F01F0007E03F800FC03F801F803F803F801F007F800E007F0000007F000000 -FF000000FF000000FF000000FF000000FF000000FF000000FF0000007F0000007F000000 -7F8000003F8001C01F8001C00FC0038007E0070003F01E0000FFFC00001FE0001A1B7E9A -1F>99 D<003FE00001FFF80003F07E0007C01F000F801F801F800F803F800FC07F000FC0 -7F0007C07F0007E0FF0007E0FF0007E0FFFFFFE0FFFFFFE0FF000000FF000000FF000000 -7F0000007F0000007F0000003F8000E01F8000E00FC001C007E0038003F81F0000FFFE00 -001FF0001B1B7E9A20>101 D<0007F0003FFC00FE3E01F87F03F87F03F07F07F07F07F0 -3E07F00007F00007F00007F00007F00007F00007F000FFFFC0FFFFC0FFFFC007F00007F0 -0007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F0 -0007F00007F00007F00007F00007F00007F00007F0007FFF807FFF807FFF80182A7EA915 ->I<00FF81F003FFE7F80FC1FE7C1F80FC7C1F007C383F007E107F007F007F007F007F00 -7F007F007F007F007F007F007F003F007E001F007C001F80FC000FC1F8001FFFE00018FF -800038000000380000003C0000003E0000003FFFF8001FFFFF001FFFFF800FFFFFC007FF -FFE01FFFFFF03E0007F07C0001F8F80000F8F80000F8F80000F8F80000F87C0001F03C00 -01E01F0007C00FC01F8003FFFE00007FF0001E287E9A22>II<07000F801FC03FE03FE0 -3FE01FC00F8007000000000000000000000000000000FFE0FFE0FFE00FE00FE00FE00FE0 -0FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0FFFE -FFFEFFFE0F2B7DAA14>I109 -DI<00 -3FE00001FFFC0003F07E000FC01F801F800FC03F800FE03F0007E07F0007F07F0007F07F -0007F0FF0007F8FF0007F8FF0007F8FF0007F8FF0007F8FF0007F8FF0007F8FF0007F87F -0007F07F0007F03F800FE03F800FE01F800FC00FC01F8007F07F0001FFFC00003FE0001D -1B7E9A22>I<03FE300FFFF01E03F03800F0700070F00070F00070F80070FC0000FFE000 -7FFE007FFF803FFFE01FFFF007FFF800FFF80003FC0000FC60007CE0003CF0003CF00038 -F80038FC0070FF01E0F7FFC0C1FF00161B7E9A1B>115 D<007000007000007000007000 -00F00000F00000F00001F00003F00003F00007F0001FFFF0FFFFF0FFFFF007F00007F000 -07F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F038 -07F03807F03807F03807F03807F03803F03803F87001F86000FFC0001F8015267FA51B> -II -E end -%%EndProlog -%%BeginSetup -%%Feature: *Resolution 300dpi -TeXDict begin - -%%EndSetup -%%Page: 1 1 -1 0 bop 551 311 a Fl(The)23 b(Sc)n(heme)e(of)i(Things:)530 -407 y(The)f(June)h(1992)h(Meeting)1245 385 y Fk(1)751 -522 y Fj(Jonathan)15 b(Rees)715 579 y(Cornell)h(Univ)o(ersit)o(y)682 -635 y Fi(jar@cs.cornell.edu)220 796 y Fj(An)21 b(informally)i -(constituted)e(group)g(of)g(p)q(eople)h(in)o(terested)g(in)g(the)f -(future)g(of)149 852 y(the)f(Sc)o(heme)g(programming)f(language)h(met)g -(at)f(the)g(Xero)o(x)g(P)o(alo)h(Alto)f(Researc)o(h)149 -909 y(Cen)o(ter)d(on)f(25)h(June)g(1992.)k(The)c(main)h(purp)q(ose)f -(of)f(the)h(meeting)g(w)o(as)f(to)g(w)o(ork)g(on)149 -965 y(the)h(tec)o(hnical)g(con)o(ten)o(t)f(of)g(the)g(next)g(revision)i -(of)d(the)i(Sc)o(heme)g(rep)q(ort.)220 1021 y(W)l(e)f(made)h(progress)e -(on)h(sev)o(eral)h(fron)o(ts:)218 1112 y Fh(\017)22 b -Fj(Some)15 b(di\013erences)i(with)e(the)g(IEEE)h(Sc)o(heme)g(standard)e -(w)o(ere)h(resolv)o(ed.)218 1205 y Fh(\017)22 b Fj(Prop)q(osals)13 -b(for)g(m)o(ultiple)i(return)e(v)m(alues)i(and)e Fi(dynamic-wind)f -Fj(w)o(ere)h(adopted.)218 1297 y Fh(\017)22 b Fj(A)15 -b(prop)q(osal)h(for)e(an)h Fi(eval)g Fj(pro)q(cedure)h(w)o(as)f -(adopted.)218 1390 y Fh(\017)22 b Fj(The)d(high-lev)o(el)h(macro)e -(facilit)o(y)h(describ)q(ed)h(in)g(the)e(Revised)1354 -1373 y Fk(4)1394 1390 y Fj(Rep)q(ort's)g(ap-)263 1446 -y(p)q(endix)f(will)g(b)q(e)f(mo)o(v)o(ed)e(in)o(to)i(the)f(rep)q(ort)g -(prop)q(er.)220 1537 y(Tw)o(o)d(sub)q(committees)i(w)o(ere)e(formed:)19 -b(one)13 b(to)f(w)o(ork)g(on)h(exceptions,)h(and)f(one)g(to)149 -1593 y(c)o(harter)i(the)g(formation)f(of)h(a)g(standard)f(library)l(.) -21 b(The)16 b(sub)q(committees)f(will)i(rep)q(ort)149 -1650 y(bac)o(k)f(to)e(the)h(group)g(with)h(prop)q(osals)f(for)g -(inclusion)i(in)f(the)g(rep)q(ort.)220 1706 y(It)j(had)g(b)q(een)i(hop) -q(ed)f(that)e(there)h(w)o(ould)h(b)q(e)g(progress)e(on)h(some)g(other)g -(fron)o(ts)149 1763 y(\(user-de\014ned)e(t)o(yp)q(es,)e(dynamic)h -(binding,)h(impro)o(v)o(emen)o(ts)e(to)f(\\rest")g(parameters\),)149 -1819 y(but)20 b(after)e(inconclusiv)o(e)j(discussion)g(these)e(topics)g -(w)o(ere)g(dropp)q(ed.)32 b(These)19 b(topics)149 1876 -y(will)e(probably)f(b)q(e)g(tak)o(en)f(up)g(again)h(in)g(the)f(future.) -220 1932 y(Norman)e(Adams)g(w)o(as)f(app)q(oin)o(ted)i(the)f(Revised) -1068 1916 y Fk(5)1103 1932 y Fj(Rep)q(ort's)g(editor.)19 -b(It)13 b(is)h(hop)q(ed)149 1989 y(that)f(it)g(will)i(b)q(e)e(ready)g -(b)o(y)g(early)h(1993,)e(so)g(as)h(to)f(precede)i(the)f(reconstitution) -h(of)f(the)149 2045 y(IEEE)j(standard)f(group.)220 2102 -y(This)f(article)g(is)g(m)o(y)f(o)o(wn)g(in)o(terpretation)h(of)f(what) -g(transpired,)h(and)g(should)g(not)149 2158 y(b)q(e)i(construed)g(as)f -(de\014nitiv)o(e.)149 2277 y Fg(Agreemen)o(t)h(with)i(the)g(IEEE)g(Sc)o -(heme)f(standard)149 2363 y Fj(Un)o(til)e(no)o(w,)f(the)g(Sc)o(heme)h -(rep)q(orts)e(ha)o(v)o(e)h(encouraged)g(but)g(not)g(required)h(the)f -(empt)o(y)149 2420 y(list)j Fi(\(\))e Fj(and)h(the)f(b)q(o)q(olean)i -(false)f(v)m(alue)g Fi(#f)f Fj(to)g(b)q(e)i(distinct.)22 -b(It)15 b(has)g(b)q(een)i(the)f(in)o(ten)o(t)p 149 2453 -598 2 v 201 2480 a Ff(1)219 2496 y Fe(T)m(o)c(app)q(ear)i(in)g -Fd(Lisp)f(Pointers)e Fe(V\(4\),)h(Octob)q(er{Decem)o(b)q(er)j(1992.)885 -2620 y Fj(1)p eop -%%Page: 2 2 -2 1 bop 307 311 a Fj(ev)o(er)14 b(since)h(the)f(Revised)i(Revised)f -(Rep)q(ort,)g(ho)o(w)o(ev)o(er,)e(that)g(this)h(distinction)i(w)o(ould) -307 368 y(ev)o(en)o(tually)h(b)q(e)g(required.)25 b(The)16 -b(IEEE)h(Sc)o(heme)g(standard)f(bit)h(the)f(bullet)i(in)f(1990,)307 -424 y(and)f(no)o(w)e(the)i(Revised)721 408 y Fk(5)757 -424 y Fj(rep)q(ort)f(follo)o(ws.)378 482 y(The)20 b(standard)f(also)h -(dropp)q(ed)h(the)f(distinction)i(b)q(et)o(w)o(een)e(essen)o(tial)h -(and)f(not-)307 538 y(essen)o(tial)e(language)e(features;)h(most)f -(features)g(that)g(w)o(ere)g(formerly)h(not)f(essen)o(tial,)307 -595 y(suc)o(h)11 b(as)f(n-ary)g Fi(+)g Fj(and)g Fi(apply)p -Fj(,)g(are)g(no)o(w)g(required.)19 b(The)11 b(Revised)1427 -578 y Fk(5)1458 595 y Fj(Rep)q(ort)g(will)h(adopt)307 -651 y(this)18 b(stance,)g(at)f(least)h(as)g(regards)f(language)h -(features)f(that)g(are)h(shared)f(with)h(the)307 708 -y(IEEE)h(standard.)30 b(Non-essen)o(tial)20 b(non-IEEE)g(o)q(ddities)g -(suc)o(h)f(as)f Fi(transcript-on)307 764 y Fj(and)13 -b Fi(transcript-off)d Fj(and)i(the)h(prop)q(osed)f Fi -(interaction-environment)d Fj(\(see)k(b)q(e-)307 821 -y(lo)o(w\))20 b(w)o(ere)f(not)h(discussed)h(at)e(the)h(meeting,)h(ho)o -(w)o(ev)o(er,)f(and)g(consensus)g(on)g(their)307 877 -y(status)15 b(will)h(ha)o(v)o(e)f(to)g(b)q(e)h(reac)o(hed)f(via)h -(electronic)g(mail.)378 935 y(A)g(third)h(asp)q(ect)g(of)f(the)g -(standard)g(that)g(w)o(as)f(adopted)i(w)o(as)e(a)h(certain)h(obscure) -307 991 y(paragraph)11 b(regarding)h(assignmen)o(ts)f(to)g(top-lev)o -(el)i(v)m(ariables)g(\(section)f(6,)f(paragraph)307 1048 -y(2\).)19 b(The)12 b(e\013ect)h(of)f(this)h(is)g(that)f(if)i(a)e -(program)f(con)o(tains)i(an)g(assignmen)o(t)f(to)g(an)o(y)h(top-)307 -1104 y(lev)o(el)j(v)m(ariable,)g(then)f(the)f(program)g(m)o(ust)g(con)o -(tain)h(a)f Fi(define)g Fj(for)g(that)f(v)m(ariable;)j(it)307 -1161 y(is)e(not)f(su\016cien)o(t)i(that)d(the)i(v)m(ariable)h(b)q(e)f -(b)q(ound.)20 b(This)14 b(has)g(b)q(een)g(the)g(case)f(for)g(most)307 -1217 y(v)m(ariables,)22 b(but)e(the)h(rule)f(applies)i(as)e(w)o(ell)h -(to)e(v)m(ariables)i(suc)o(h)f(as)g Fi(car)g Fj(that)f(ha)o(v)o(e)307 -1274 y(built-in)h(bindings.)30 b(In)18 b(addition,)i(it)e(is)g -(clari\014ed)h(that)f(if)g(a)f(program)g(mak)o(es)g(suc)o(h)307 -1330 y(a)d(de\014nition)i(or)e(assignmen)o(t,)g(then)h(the)f(b)q(eha)o -(vior)h(of)f(built-in)j(pro)q(cedures)e(will)h(not)307 -1387 y(b)q(e)j(a\013ected.)28 b(F)l(or)17 b(example,)j(rede\014ning)f -Fi(length)e Fj(cannot)h(a\013ect)f(the)h(b)q(eha)o(vior)h(of)307 -1443 y(the)14 b(built-in)j Fi(list->vector)c Fj(pro)q(cedure.)20 -b(If)14 b(in)i(some)d(particular)i(implemen)o(tation)307 -1500 y Fi(list->vector)f Fj(is)j(written)e(in)i(Sc)o(heme)f(and)g -(calls)h Fi(length)p Fj(,)e(then)h(it)g(m)o(ust)f(b)q(e)h(sure)307 -1556 y(to)d(call)i(the)f(built-in)i Fi(length)d Fj(pro)q(cedure,)h(not) -f(whatev)o(er)g(happ)q(ens)i(to)e(b)q(e)i(the)e(v)m(alue)307 -1612 y(of)i(the)g(v)m(ariable)i Fi(length)p Fj(.)307 -1740 y Fg(Multiple)i(return)e(v)m(alues)307 1828 y Fj(The)d -Fi(call-with-values)d Fj(and)i Fi(values)f Fj(pro)q(cedures)i(w)o(ere)f -(describ)q(ed)i(in)f(an)g(earlier)307 1885 y(Sc)o(heme)e(of)e(Things)h -(\()p Fc(Lisp)h(Pointers)p Fj(,)e(v)o(olume)h(IV,)g(n)o(um)o(b)q(er)g -(1\),)g(but)g(I'll)h(review)g(them)307 1941 y(here.)20 -b(The)c(follo)o(wing)g(is)g(adapted)f(from)f(John)i(Ramsdell's)g -(concise)h(description:)421 2054 y Fi(\(values)23 b Fc(obje)n(ct)g -Fb(:)8 b(:)g(:)n Fi(\))600 b Fj(essen)o(tial)16 b(pro)q(cedure)421 -2132 y Fi(values)e Fj(deliv)o(ers)j(all)f(of)f(its)g(argumen)o(ts)f(to) -h(its)g(con)o(tin)o(uation.)421 2249 y Fi(\(call-with-values)21 -b Fc(thunk)j(r)n(e)n(c)n(eiver)o Fi(\))268 b Fj(essen)o(tial)16 -b(pro)q(cedure)421 2326 y Fi(call-with-values)c Fj(calls)j(its)f -Fc(thunk)g Fj(argumen)o(t)g(with)g(a)g(con)o(tin)o(uation)h(that,)421 -2383 y(when)h(passed)g(some)f(v)m(alues,)i(calls)g(the)f -Fc(r)n(e)n(c)n(eiver)e Fj(pro)q(cedure)j(with)f(those)g(v)m(al-)421 -2439 y(ues)22 b(as)g(argumen)o(ts.)40 b(The)23 b(con)o(tin)o(uation)f -(for)g(the)g(call)h(to)f Fc(r)n(e)n(c)n(eiver)f Fj(is)h(the)421 -2496 y(con)o(tin)o(uation)15 b(of)g(the)g(call)i(to)d -Fi(call-with-values)p Fj(.)1043 2620 y(2)p eop -%%Page: 3 3 -3 2 bop 220 311 a Fj(Except)17 b(for)g(con)o(tin)o(uations)h(created)f -(b)o(y)g(the)g Fi(call-with-values)e Fj(pro)q(cedure,)149 -368 y(all)21 b(con)o(tin)o(uations)g(tak)o(e)e(exactly)h(one)h(v)m -(alue,)h(as)d(no)o(w;)j(the)e(e\013ect)g(of)f(passing)i(no)149 -424 y(v)m(alue)i(or)e(more)g(than)g(one)g(v)m(alue)i(to)d(con)o(tin)o -(uations)i(that)f(w)o(ere)g(not)g(created)g(b)o(y)149 -481 y Fi(call-with-values)13 b Fj(is)j(unsp)q(eci\014ed)i(\(as)c -(indeed)j(it)f(is)g(unsp)q(eci\014ed)h(no)o(w\).)220 -537 y Fi(values)d Fj(migh)o(t)h(b)q(e)h(de\014ned)h(as)e(follo)o(ws:) -245 623 y Fi(\(define)23 b(\(values)g(.)g(things\))293 -679 y(\(call-with-current-cont)o(inuation)340 736 y(\(lambda)g -(\(cont\))g(\(apply)g(cont)h(things\)\)\)\))149 822 y -Fj(That)g(is,)j(the)d(pro)q(cedures)h(supplied)i(b)o(y)d -Fi(call-with-current-continua)o(tion)149 878 y Fj(m)o(ust)18 -b(b)q(e)h(passed)g(the)f(same)g(n)o(um)o(b)q(er)h(of)f(argumen)o(ts)f -(as)h(v)m(alues)i(exp)q(ected)f(b)o(y)g(the)149 934 y(con)o(tin)o -(uation.)220 991 y(Because)14 b(the)g(b)q(eha)o(vior)g(of)g(a)f(n)o(um) -o(b)q(er-of-v)m(alues)i(mismatc)o(h)f(b)q(et)o(w)o(een)g(a)f(con)o -(tin-)149 1047 y(uation)f(and)g(its)f(in)o(v)o(ok)o(er)h(is)g(unsp)q -(eci\014ed,)i(some)d(implemen)o(tations)i(ma)o(y)e(assign)g(some)149 -1104 y(sp)q(eci\014c)19 b(meaning)f(to)e(suc)o(h)h(situations;)h(for)f -(example,)g(extra)g(v)m(alues)h(migh)o(t)f(b)q(e)g(ig-)149 -1160 y(nored,)f(or)f(defaults)h(migh)o(t)g(b)q(e)g(supplied)i(for)d -(missing)i(v)m(alues.)22 b(Th)o(us)16 b(this)g(m)o(ultiple)149 -1217 y(return)k(v)m(alue)g(prop)q(osal)g(is)g(compatible)g(with)g -(Common)f(Lisp's)h(m)o(ultiple)h(v)m(alues,)149 1273 -y(but)e(strictly)g(more)f(conserv)m(ativ)o(e)i(than)e(it.)30 -b(The)19 b(b)q(eha)o(vior)g(of)g(programs)e(in)i(suc)o(h)149 -1330 y(situations)e(w)o(as)e(a)h(p)q(oin)o(t)g(of)g(con)o(ten)o(tion)g -(among)g(the)g(authors,)f(whic)o(h)i(is)f(wh)o(y)g(only)149 -1386 y(the)g(least)f(common)g(denominator)g(b)q(eha)o(vior)h(w)o(as)e -(sp)q(eci\014ed.)149 1505 y Fg(Un)o(wind/wind)19 b(protection)149 -1590 y Fi(dynamic-wind)p Fj(,)13 b(whic)o(h)i(w)o(as)e(describ)q(ed)j -(previously)f(in)g(this)g(column)g(\(when)f(it)h(w)o(as)149 -1647 y(The)k(Sc)o(heme)g(En)o(vironmen)o(t;)g Fc(Lisp)f(Pointers)p -Fj(,)g(v)o(olume)g(I,)h(n)o(um)o(b)q(er)f(2\),)g(is)h(already)149 -1703 y(implemen)o(ted)24 b(in)f(man)o(y)e(Sc)o(heme)h(dialects.)41 -b Fi(dynamic-wind)20 b Fj(tak)o(es)h(three)h(argu-)149 -1760 y(men)o(ts,)15 b(all)h(of)f(whic)o(h)h(are)f(th)o(unks)h(\(pro)q -(cedures)f(of)g(no)g(argumen)o(ts\).)k(It)d(b)q(eha)o(v)o(es)f(as)149 -1816 y(if)h(it)g(w)o(ere)e(de\014ned)j(with)245 1902 -y Fi(\(define)23 b(\(dynamic-wind)f(before)h(during)g(after\))293 -1958 y(\(before\))293 2015 y(\(call-with-values)e(during)340 -2071 y(\(lambda)i(results)388 2128 y(\(after\))388 2184 -y(\(apply)g(values)g(results\)\)\)\))149 2270 y Fj(except)17 -b(that)f(the)h(execution)g(of)f(the)h Fi(during)e Fj(th)o(unk)i(is)g -(\\protected")e(against)h(non-)149 2326 y(lo)q(cal)e(en)o(tries)f(and)g -(exits:)19 b(a)12 b(thro)o(w)g(out)g(of)g(the)h(execution)h(of)e -Fi(during)g Fj(will)i(cause)f(the)149 2383 y Fi(after)h -Fj(th)o(unk)g(to)f(b)q(e)i(in)o(v)o(ok)o(ed,)f(and)g(a)g(thro)o(w)e -(from)i(outside)g(bac)o(k)g(in)h(will)g(cause)g(the)149 -2439 y Fi(before)10 b Fj(th)o(unk)h(to)f(b)q(e)h(in)o(v)o(ok)o(ed.)19 -b(\(By)10 b(\\thro)o(w")f(I)i(mean)g(an)g(in)o(v)o(o)q(cation)g(of)f -(an)h(explicit)149 2496 y(con)o(tin)o(uation)16 b(as)f(obtained)h(from) -e Fi(call-with-current-continuati)o(on)p Fj(.\))885 2620 -y(3)p eop -%%Page: 4 4 -4 3 bop 378 311 a Fj(F)l(or)14 b(details,)h(the)f(earlier)i(Sc)o(heme)f -(En)o(vironmen)o(t)g(column)g(refers)f(the)h(reader)f(to)307 -368 y(F)l(riedman)19 b(and)f(Ha)o(ynes's)f(pap)q(er)h(\\Constraining)g -(Con)o(trol")f(in)i(POPL)f(1985,)f(but)307 424 y(to)h(sa)o(v)o(e)g(y)o -(ou)h(the)g(trouble)g(of)g(lo)q(oking)g(that)f(up,)i(I)f(ha)o(v)o(e)g -(supplied)i(a)d(more)h(direct)307 481 y(implemen)o(tation)e(of)d -Fi(dynamic-wind)g Fj(in)i(an)f(app)q(endix)i(to)e(the)g(presen)o(t)g -(column.)378 537 y Fi(dynamic-wind)9 b Fj(w)o(as)i(adopted)g(with)h -(the)f(follo)o(wing)i(clari\014cations:)19 b(The)11 b(seman-)307 -594 y(tics)18 b(of)g Fi(\(dynamic-wind)k Fc(b)n(efor)n(e)h(during)h -(after)p Fi(\))18 b Fj(should)h(lea)o(v)o(e)f(unsp)q(eci\014ed)i(what) -307 650 y(happ)q(ens)i(if)g(a)f(thro)o(w)f(o)q(ccurs)i(out)f(of)f -Fc(b)n(efor)n(e)h Fj(or)g Fc(after)5 b Fj(;)24 b(and)d(it)g(is)h(b)q -(est)g(to)e(defer)307 707 y(in)o(terrupts)c(during)g -Fc(b)n(efor)n(e)e Fj(and)i Fc(after)p Fj(.)307 827 y -Fg(Ev)m(aluating)k(computed)e(expressions)307 913 y Fj(The)f(original)g -(1975)f(memo)g(on)g(Sc)o(heme)h(describ)q(ed)h Fi(evaluate)p -Fj(,)e(whic)o(h)h(w)o(as)e(analo-)307 970 y(gous)g(to)f(Lisp's)i -(traditional)g Fi(eval)e Fj(function.)21 b Fi(evaluate)14 -b Fj(to)q(ok)g(a)h(single)i(argumen)o(t,)307 1026 y(an)e(S-expression,) -h(and)g(in)o(v)o(ok)o(ed)f(an)g(in)o(terpreter)h(on)f(it.)20 -b(F)l(or)15 b(example:)403 1121 y Fi(\(let)23 b(\(\(name)g('+\)\))g -(\(evaluate)g(\(list)g(name)g(2)h(3\)\)\))498 1177 y -Fh(\000)-7 b(!)48 b Fi(5)307 1271 y Fj(Sc)o(heme)11 b(b)q(eing)h -(lexically)h(scop)q(ed,)f(ho)o(w)o(ev)o(er,)e(there)g(w)o(as)g(some)g -(confusion)h(o)o(v)o(er)f(whic)o(h)307 1328 y(en)o(vironmen)o(t)16 -b(the)f(expression)h(w)o(as)e(to)h(b)q(e)h(ev)m(aluated)g(in.)21 -b(Should)403 1422 y Fi(\(let)i(\(\(name)g('+\)\))450 -1479 y(\(let)h(\(\(+)f(*\)\))498 1535 y(\(evaluate)g(\(list)g(name)g(2) -h(3\)\)\)\))307 1629 y Fj(ev)m(aluate)16 b(to)f(5)g(or)f(to)h(6?)378 -1686 y(T)l(o)c(clarify)i(matters,)d(the)i(Revised)h(Rep)q(ort)f -(replaced)h Fi(evaluate)e Fj(with)h Fi(enclose)p Fj(,)307 -1742 y(whic)o(h)k(to)q(ok)f(t)o(w)o(o)f(argumen)o(ts,)h(a)g -Fi(lambda)p Fj(-expression)g(and)h(a)f(represen)o(tation)h(of)f(an)307 -1799 y(en)o(vironmen)o(t)h(from)f(whic)o(h)h(to)f(supply)h(bindings)i -(of)d(the)g Fi(lambda)p Fj(-expression's)g(free)307 1855 -y(v)m(ariables.)21 b(F)l(or)15 b(example:)403 1950 y -Fi(\(let)23 b(\(\(name)g('+\)\))450 2006 y(\(let)h(\(\(+)f(*\)\))498 -2063 y(\(\(enclose)g(\(list)g('lambda)g('\(\))g(\(list)g(name)h(2)f -(3\)\))737 2119 y(\(list)g(\(cons)g('+)h(+\)\)\)\)\)\))498 -2176 y Fh(\000)-7 b(!)48 b Fi(6)307 2270 y Fj(This)20 -b(forced)g(the)g(programmer)e(to)h(b)q(e)i(explicit)h(ab)q(out)d(the)h -Fi(lambda)p Fj(-expression's)307 2326 y(enclosing)d(en)o(vironmen)o(t.) -378 2383 y(F)l(or)d(v)m(arious)h(tec)o(hnical)i(and)e(practical)g -(reasons,)f(there)h(w)o(as)f(no)h Fi(eval)f Fj(analogue)307 -2439 y(in)21 b(subsequen)o(t)g(Sc)o(heme)f(rep)q(orts.)34 -b(The)20 b(ma)s(jor)f(stum)o(bling)h(blo)q(c)o(ks)h(w)o(ere)f(ho)o(w)f -(to)307 2496 y(describ)q(e)j Fi(eval)d Fj(formally)h(and)g(ho)o(w)g(to) -f(de\014ne)i(something)f(that)f(mak)o(es)g(sense)i(in)1043 -2620 y(4)p eop -%%Page: 5 5 -5 4 bop 149 311 a Fj(all)17 b(extan)o(t)f(v)m(arian)o(ts)g(of)f(the)h -(language.)23 b(Some)16 b(Sc)o(heme)g(implemen)o(tations)i(con)o(tain) -149 368 y(a)e(distinguished)i(top-lev)o(el)f(en)o(vironmen)o(t,)e -(while)i(others)e(extend)h(the)g(language)g(b)o(y)149 -424 y(pro)o(viding)j(w)o(a)o(ys)e(to)g(create)g(m)o(ultiple)j(en)o -(vironmen)o(ts,)e(an)o(y)g(of)f(whic)o(h)h(migh)o(t)g(serv)o(e)149 -481 y(equally)f(w)o(ell.)220 537 y(The)12 b Fi(eval)g -Fj(prop)q(osal)g(adopted)g(at)g(the)g(June)h(meeting,)g(whic)o(h)f(I)h -(repro)q(duce)g(here,)149 594 y(is)j(one)f(that)g(comes)g(from)g(Bill)i -(Rozas.)263 702 y Fi(\(eval)23 b Fc(expr)n(ession)g(envir)n(onment-sp)n -(e)n(ci\014er)m Fi(\))190 b Fj(essen)o(tial)16 b(pro)q(cedure)263 -777 y Fi(eval)10 b Fj(ev)m(aluates)h Fc(expr)n(ession)e -Fj(in)h(the)h(en)o(vironmen)o(t)f(indicated)i(b)o(y)e -Fc(envir)n(onment-)263 834 y(sp)n(e)n(ci\014er)p Fj(.)21 -b Fc(envir)n(onment-sp)n(e)n(ci\014er)13 b Fj(ma)o(y)i(b)q(e)i(the)f -(return)g(v)m(alue)h(of)e(one)h(of)g(the)263 890 y(three)21 -b(pro)q(cedures)g(describ)q(ed)h(b)q(elo)o(w,)g(or)e(implemen)o -(tation-sp)q(eci\014c)j(exten-)263 947 y(sions.)31 b(No)19 -b(other)g(op)q(erations)g(on)f(en)o(vironmen)o(t)i(sp)q(eci\014ers)g -(are)f(de\014ned)h(b)o(y)263 1003 y(this)c(prop)q(osal.)263 -1079 y(Implemen)o(tations)g(ma)o(y)e(allo)o(w)h(non-expression)h -(programs)e(\(i.e.)g(de\014nitions\))263 1135 y(as)j(the)h(\014rst)f -(argumen)o(t)g(to)g Fi(eval)g Fc(only)h Fj(when)g(the)f(second)i -(argumen)o(t)e(is)h(the)263 1192 y(return)i(v)m(alue)h(of)f -Fi(interaction-environment)d Fj(or)j(some)f(implemen)o(tation)263 -1248 y(extension.)i(In)16 b(other)e(w)o(ords,)g Fi(eval)h -Fj(will)i(nev)o(er)e(create)g(new)h(bindings)h(in)f(the)263 -1305 y(return)f(v)m(alue)i(of)d Fi(null-environment)f -Fj(or)i Fi(scheme-report-environment)p Fj(.)263 1420 -y Fi(\(scheme-report-environment)20 b Fc(version)p Fi(\))193 -b Fj(essen)o(tial)16 b(pro)q(cedure)263 1495 y Fc(V)m(ersion)21 -b Fj(m)o(ust)i(b)q(e)g(an)g(exact)f(non-negativ)o(e)h(in)o(teger)g -(corresp)q(onding)h(to)e(a)263 1552 y(v)o(ersion)e(of)f(one)h(of)f(the) -h(Revised)857 1535 y Fa(n)902 1552 y Fj(Rep)q(orts)g(on)g(Sc)o(heme.)34 -b(This)20 b(pro)q(cedure)263 1608 y(returns)g(a)g(sp)q(eci\014er)h(for) -f(an)g(en)o(vironmen)o(t)g(that)f(con)o(tains)i(exactly)f(the)g(set)263 -1665 y(of)d(bindings)i(sp)q(eci\014ed)g(in)f(the)g(corresp)q(onding)g -(rep)q(ort)f(that)f(the)i(implemen-)263 1721 y(tation)h(supp)q(orts.)32 -b(Not)18 b(all)i(v)o(ersions)g(ma)o(y)e(b)q(e)i(a)o(v)m(ailable)h(in)f -(all)g(implemen-)263 1778 y(tations)g(at)f(all)i(times.)35 -b(Ho)o(w)o(ev)o(er,)20 b(an)g(implemen)o(tation)i(that)d(conforms)g(to) -263 1834 y(v)o(ersion)e Fb(n)g Fj(of)f(the)h(Revised)748 -1818 y Fa(n)789 1834 y Fj(Rep)q(orts)g(on)g(Sc)o(heme)g(m)o(ust)f -(accept)h(v)o(ersion)g Fb(n)p Fj(.)263 1891 y(If)e Fi -(scheme-report-environmen)o(t)d Fj(is)i(a)o(v)m(ailable,)i(but)f(the)f -(sp)q(eci\014ed)j(v)o(ersion)263 1947 y(is)f(not,)e(the)i(pro)q(cedure) -g(will)g(signal)h(an)e(error.)263 2023 y(The)e(e\013ect)g(of)f -(assigning)i(\(through)e(the)h(use)g(of)g Fi(eval)p Fj(\))f(a)g(v)m -(ariable)j(b)q(ound)e(in)h(a)263 2079 y Fi(scheme-report-environment)8 -b Fj(\(e.g.)j Fi(car)p Fj(\))f(is)i(unsp)q(eci\014ed.)22 -b(Th)o(us)11 b(the)h(en)o(vi-)263 2136 y(ronmen)o(ts)e(sp)q(eci\014ed)i -(b)o(y)e(the)g(return)g(v)m(alues)i(of)d Fi(scheme-report-environment) -263 2192 y Fj(ma)o(y)15 b(b)q(e)g(imm)o(utable.)263 2307 -y Fi(\(null-environment\))572 b Fj(essen)o(tial)16 b(pro)q(cedure)263 -2383 y(This)d(pro)q(cedure)h(returns)f(a)f(sp)q(eci\014er)j(for)d(an)h -(en)o(vironmen)o(t)g(that)f(con)o(tains)h(no)263 2439 -y(v)m(ariable)f(bindings,)g(but)f(con)o(tains)f(\(syn)o(tactic\))g -(bindings)i(for)d(all)j(the)e(syn)o(tactic)263 2496 y(k)o(eyw)o(ords)k -(de\014ned)j(in)f(the)f(rep)q(ort,)g(and)g(no)g(others.)885 -2620 y(5)p eop -%%Page: 6 6 -6 5 bop 421 311 a Fi(\(interaction-environment\))585 -b Fj(pro)q(cedure)421 387 y(This)20 b(pro)q(cedure)g(returns)g(a)f(sp)q -(eci\014er)i(for)e(an)h(en)o(vironmen)o(t)g(that)e(con)o(tains)421 -444 y(implementation-de\014ned)k(bindings,)e(t)o(ypically)g(a)f(sup)q -(erset)g(of)f(those)g(listed)421 500 y(in)h(the)g(rep)q(ort.)30 -b(The)19 b(in)o(ten)o(t)g(is)h(that)e(this)h(pro)q(cedure)g(will)i -(return)e(a)f(sp)q(eci-)421 557 y(\014er)f(for)e(the)i(en)o(vironmen)o -(t)g(in)g(whic)o(h)g(the)g(implemen)o(tation)h(w)o(ould)f(ev)m(aluate) -421 613 y(expressions)f(dynamically)h(t)o(yp)q(ed)e(b)o(y)h(the)f -(user.)378 722 y(Rozas)c(explains:)19 b(\\The)11 b(prop)q(osal)g(do)q -(es)g(not)g(imply)h(the)f(existence)h(or)f(supp)q(ort)g(of)307 -778 y(\014rst-class)j(en)o(vironmen)o(ts,)g(although)h(it)f(is)g -(compatible)h(with)g(them.)k(The)14 b(prop)q(osal)307 -835 y(only)22 b(requires)g(a)f(w)o(a)o(y)f(of)h(asso)q(ciating)h(tags)e -(with)i(a)f(\014nite)h(set)f(of)g(distinguished)307 891 -y(en)o(vironmen)o(ts)d(whic)o(h)g(the)f(implemen)o(tations)i(can)f -(main)o(tain)f(implicitl)q(y)j(\(without)307 947 y(rei\014cation\).)378 -1004 y(\\)7 b(`P)o(ascal-lik)o(e')k(implemen)o(tations)h(can)f(supp)q -(ort)f(b)q(oth)h Fi(null-environment)d Fj(and)307 1061 -y Fi(scheme-report-environment)f Fj(since)k(the)g(en)o(vironmen)o(ts)f -(sp)q(eci\014ed)i(b)o(y)e(the)h(return)307 1117 y(v)m(alues)j(of)e -(these)g(pro)q(cedures)i(need)f(not)f(share)h(an)o(y)f(bindings)i(with) -f(the)f(curren)o(t)h(pro-)307 1174 y(gram.)k(A)11 b(v)o(ersion)f(of)g -Fi(eval)f Fj(that)h(supp)q(orts)g(these)g(but)h(not)e -Fi(interaction-environment)307 1230 y Fj(can)j(b)q(e)g(written)g(p)q -(ortably)l(,)h(but)e(can)h(b)q(e)h(b)q(etter)e(written)h(b)o(y)g(the)g -(implemen)o(tor,)g(since)307 1287 y(it)k(can)f(share)g(co)q(de)h(with)f -(the)h(default)f(ev)m(aluator)h(or)e(compiler.")378 1343 -y(Here)f(\\P)o(ascal-lik)o(e")i(refers)e(to)g(implemen)o(tations)h -(that)f(are)g(restricted)h(to)f(static)307 1400 y(compilation)f(and)e -(linking.)20 b(Because)11 b(an)f Fi(eval)g Fj(that)f(do)q(esn't)h(supp) -q(ort)g Fi(interaction-)307 1456 y(environment)15 b Fj(can)i(b)q(e)h -(written)e(en)o(tirely)i(in)g(the)f(Sc)o(heme)g(language)g(describ)q -(ed)i(b)o(y)307 1513 y(the)g(rest)f(of)f(the)i(rep)q(ort,)f(it)h -(raises)f(no)h(troublesome)f(questions)h(ab)q(out)f(its)h(formal)307 -1569 y(seman)o(tics.)307 1692 y Fg(Macros)307 1778 y -Fj(The)11 b(consensus)g(of)f(the)g(meeting)h(w)o(as)e(that)h -Fi(define-syntax)p Fj(,)f Fi(syntax-rules)p Fj(,)g Fi(let-)307 -1835 y(syntax)p Fj(,)14 b(and)h Fi(letrec-syntax)f Fj(should)i(b)q(e)g -(mo)o(v)o(ed)f(out)f(of)h(the)g(rep)q(ort's)g(app)q(endix)307 -1891 y(in)o(to)e(the)h(main)g(b)q(o)q(dy)g(of)e(the)i(rep)q(ort.)19 -b(Although)14 b(ev)o(ery)o(one)f(agrees)g(that)f(a)h(lo)o(w-lev)o(el) -307 1948 y(macro)j(facilit)o(y)i(is)f(imp)q(ortan)o(t,)g(the)g(sub)s -(ject)f(is)h(to)q(o)g(con)o(ten)o(tious)f(at)g(presen)o(t,)h(with)307 -2004 y(three)h(or)f(more)g(comp)q(eting)h(prop)q(osals)f(at)g(presen)o -(t.)27 b(The)17 b(disp)q(osition)i(of)e(the)h(rest)307 -2061 y(of)f(the)h(app)q(endix)h(and)f(of)f(the)g(other)g(lo)o(w-lev)o -(el)i(prop)q(osals)f(will)h(b)q(e)f(left)g(up)g(to)e(the)307 -2117 y(rep)q(ort's)f(editor.)307 2240 y Fg(Committee)j(w)o(ork)307 -2326 y Fj(There)c(is)h(a)e(strong)g(sense)i(that)e(some)h(kind)h(of)e -(exception)i(system)f(is)g(needed.)21 b(Ho)o(w-)307 2383 -y(ev)o(er,)15 b(no)g(sp)q(eci\014c)i(prop)q(osal)e(w)o(as)f(ready)h(at) -g(the)g(time)g(of)g(the)g(meeting.)20 b(A)15 b(commit-)307 -2439 y(tee)k(has)g(b)q(een)g(formed)g(to)f(w)o(ork)g(on)g(one.)31 -b(What)18 b(seems)h(to)f(b)q(e)h(in)h(the)f(air)g(migh)o(t)307 -2496 y(b)q(e)d(describ)q(ed)h(as)d(a)h(highly)i(distilled)g(v)o(ersion) -f(of)e(the)h(condition)h(system)f(that)f(Ken)o(t)1043 -2620 y(6)p eop -%%Page: 7 7 -7 6 bop 149 311 a Fj(Pitman)18 b(dev)o(elop)q(ed)h(for)d(Common)h -(Lisp.)27 b(I)18 b(hop)q(e)g(that)f(I'll)h(b)q(e)g(able)g(to)f(rep)q -(ort)g(on)149 368 y(this)f(in)g(a)f(future)g(column.)220 -424 y(On)i(the)f(sub)s(ject)g(of)g(libraries,)i(Will)g(Clinger's)e(min) -o(utes)h(rep)q(ort)f(that)g(\\the)g(au-)149 481 y(thors)h(p)q(erceiv)o -(e)i(a)e(need)i(to)d(giv)o(e)i(some)f(library)i(o\016cial)f(status.)26 -b(In)18 b(fact,)f(w)o(e)g(need)149 537 y(to)e(giv)o(e)h(o\016cial)h -(sanction)f(to)f(m)o(ultiple)i(libraries.)23 b(There)16 -b(is)g(reason)g(to)f(distinguish)149 594 y(b)q(et)o(w)o(een)d(accepted) -f(\(or)g(standard\))f(libraries,)j(exp)q(erimen)o(tal)f(libraries,)i -(and)d(prop)q(os-)149 650 y(als.)26 b(The)17 b(accepted)h(libraries)g -(can)g(reduce)g(the)f(in)o(tellectual)i(size)f(of)e(the)i(language)149 -707 y(b)o(y)g(remo)o(ving)f(things)g(lik)o(e)h Fi(string->list)e -Fj(from)g(the)i(rep)q(ort.)25 b(The)17 b(exp)q(erimen)o(tal)149 -763 y(libraries)i(w)o(ould)f(con)o(tain)g(solid)g(implemen)o(tations)h -(of)e(exp)q(erimen)o(tal)i(features,)e(in-)149 819 y(cluding)i(things)e -(that)g(migh)o(t)f(nev)o(er)h(deserv)o(e)g(to)g(b)q(e)g(in)h(the)f(rep) -q(ort.)24 b(The)18 b(prop)q(osal)149 876 y(libraries)f(could)f(con)o -(tain)g(an)o(ything)f(implemen)o(ted)i(in)f(p)q(ortable)g(Sc)o(heme.") -220 932 y(Among)11 b(the)g(con)o(ten)o(t)g(of)g(the)g(accepted)h -(libraries,)h(some)e(features)g(\(suc)o(h)g(as)g(those)149 -989 y(that)18 b(ma)o(y)f(b)q(e)h(mo)o(v)o(ed)g(out)f(of)h(the)g(b)q(o)q -(dy)g(of)g(the)g(rep)q(ort\))f(ma)o(y)g(b)q(e)i(required)g(to)e(b)q(e) -149 1045 y(built)e(in)f(to)f(implemen)o(tations,)h(while)h(others)e -(will)i(b)q(e)f(exp)q(ected)g(to)f(b)q(e)h(a)o(v)m(ailable)h(on)149 -1102 y(demand)g(\(p)q(erhaps)f(using)h(something)g(similar)g(to,)e(but) -i(not)e(the)h(same)g(as,)g Fi(require)149 1158 y Fj(as)h(found)h(in)g -(Common)e(Lisp)j(and)e(GNU)g(Emacs\).)220 1215 y(A)f(librarian)h(w)o -(as)d(app)q(oin)o(ted)j(\(Rees\),)e(and)h(a)f(library)i(committee)e(is) -h(dev)o(eloping)149 1271 y(prop)q(osals)i(for)e(the)i(c)o(harter,)e -(structure,)g(and)i(con)o(ten)o(t)e(of)h(the)g(libraries.)817 -1394 y Fh(\003)45 b(\003)g(\003)220 1517 y Fj(I)17 b(w)o(ould)g(lik)o -(e)h(to)e(ac)o(kno)o(wledge)h(Will)h(Clinger,)g(who)e(prepared)h(the)g -(min)o(utes)g(of)149 1574 y(the)i(meeting,)g(and)g(the)g(v)m(arious)g -(p)q(eople)h(who)e(con)o(tributed)h(prop)q(osals,)g(including)149 -1630 y(Bill)f(Rozas)d(and)h(John)f(Ramsdell.)22 b(An)o(y)15 -b(errors)g(here)h(are)f(m)o(y)g(resp)q(onsibilit)o(y)l(,)i(ho)o(w-)149 -1687 y(ev)o(er.)j(Thanks)15 b(also)g(to)f(Norman)g(Adams)h(and)g(Ric)o -(hard)h(Kelsey)g(for)e(corrections)h(to)149 1743 y(a)g(draft)g(of)g -(this)g(article.)220 1799 y(I)i(w)o(ould)g(also)g(lik)o(e)h(to)f(b)q -(elatedly)h(ac)o(kno)o(wledge)f(Norman)g(Adams,)f(P)o(a)o(v)o(el)h -(Cur-)149 1856 y(tis,)g(Bruce)g(Donald,)f(and)h(Ric)o(hard)g(Kelsey)g -(for)f(their)h(commen)o(ts)f(on)g(drafts)f(of)h(m)o(y)149 -1912 y(previous)g(column.)220 1969 y(F)l(or)e(future)g(columns,)h(I)g -(am)f(en)o(tertaining)h(v)m(arious)g(topic)g(p)q(ossibilities,)i -(includ-)149 2025 y(ing)h Fi(eval)p Fj(,)e(threads,)g -Fi(amb)p Fj(,)g(and)h(monads.)24 b(If)17 b(y)o(ou)f(ha)o(v)o(e)h(other) -f(ideas,)h(and)g(particu-)149 2082 y(larly)f(if)g(y)o(ou)e(think)i(the) -f(written)h(record)f(on)g(the)g(language)g(is)h(particularly)g(p)q(o)q -(or)f(in)149 2138 y(certain)h(areas,)e(please)i(write)g(and)f(let)h(me) -f(kno)o(w.)149 2297 y Fg(App)q(endix:)23 b(An)17 b(implemen)o(tation)i -(of)f Fi(dynamic-wind)149 2383 y Fj(This)c(program)e(is)h(based)g(on)g -(m)o(y)g(v)m(ague)g(recollection)i(of)d(an)h(ancien)o(t)h(man)o -(uscript)f(b)o(y)149 2439 y(Chris)k(Hanson)f(and)h(John)g(Lamping.)24 -b(I)17 b(ap)q(ologize)g(for)f(the)g(lac)o(k)h(of)f(data)f(abstrac-)149 -2496 y(tion,)h(but)f(the)g(co)q(de)h(is)g(more)e(concise)j(this)e(w)o -(a)o(y)l(.)885 2620 y(7)p eop -%%Page: 8 8 -8 7 bop 378 311 a Fj(A)11 b(state)f(space)h(is)h(a)f(tree)g(with)g(the) -g(curren)o(t)g(state)f(at)h(the)g(ro)q(ot.)17 b(Eac)o(h)11 -b(no)q(de)h(other)307 368 y(than)i(the)f(ro)q(ot)g(is)h(a)g(triple)g -Fh(h)p Fc(b)n(efor)n(e)o Fb(;)8 b Fc(after)p Fb(;)g Fc(p)n(ar)n(ent)o -Fh(i)p Fj(,)13 b(represen)o(ted)h(in)g(this)h(implemen-)307 -424 y(tation)e(as)f(t)o(w)o(o)g(pairs)h Fi(\(\()p Fc(b)n(efor)n(e)23 -b Fi(.)h Fc(after)p Fi(\))g(.)g Fc(p)n(ar)n(ent)o Fi(\))p -Fj(.)19 b(Na)o(vigating)13 b(b)q(et)o(w)o(een)g(states)307 -481 y(requires)j(re-ro)q(oting)f(the)h(tree)f(b)o(y)g(rev)o(ersing)g -(paren)o(t-c)o(hild)i(links.)378 537 y(Since)c Fi(dynamic-wind)d -Fj(in)o(teracts)h(with)h Fi(call-with-current-continua)o(tion)p -Fj(,)307 594 y(this)k(implemen)o(tation)g(m)o(ust)f(replace)h(the)f -(usual)h(de\014nition)h(of)e(the)g(latter.)307 700 y -Fi(\(define)23 b(*here*)g(\(list)g(#f\)\))307 795 y(\(define)g -(original-cwcc)f(call-with-current-continuat)o(ion\))307 -891 y(\(define)h(\(call-with-current-continua)o(tion)e(proc\))355 -948 y(\(let)i(\(\(here)g(*here*\)\))403 1004 y(\(original-cwcc)f -(\(lambda)g(\(cont\))808 1060 y(\(proc)h(\(lambda)g(results)999 -1117 y(\(reroot!)g(here\))999 1173 y(\(apply)g(cont)h -(results\)\)\)\)\)\)\))307 1269 y(\(define)f(\(dynamic-wind)f(before)h -(during)g(after\))355 1325 y(\(let)g(\(\(here)g(*here*\)\))403 -1382 y(\(reroot!)f(\(cons)i(\(cons)f(before)g(after\))g(here\)\))403 -1438 y(\(call-with-values)e(during)450 1495 y(\(lambda)i(results)498 -1551 y(\(reroot!)g(here\))498 1608 y(\(apply)g(values)g -(results\)\)\)\)\))307 1703 y(\(define)g(\(reroot!)g(there\))355 -1760 y(\(if)g(\(not)h(\(eq?)f(*here*)g(there\)\))450 -1816 y(\(begin)g(\(reroot!)g(\(cdr)g(there\)\))617 1873 -y(\(let)h(\(\(before)e(\(caar)i(there\)\))761 1929 y(\(after)f(\(cdar)g -(there\)\)\))665 1986 y(\(set-car!)g(*here*)g(\(cons)g(after)g -(before\)\))665 2042 y(\(set-cdr!)g(*here*)g(there\))665 -2098 y(\(set-car!)g(there)g(#f\))665 2155 y(\(set-cdr!)g(there)g -('\(\)\))665 2211 y(\(set!)g(*here*)g(there\))665 2268 -y(\(before\)\)\)\)\))1043 2620 y Fj(8)p eop -%%Trailer -end -userdict /end-hook known{end-hook}if -%%EOF diff --git a/doc/meeting.tex b/doc/meeting.tex deleted file mode 100644 index 4a696cb..0000000 --- a/doc/meeting.tex +++ /dev/null @@ -1,439 +0,0 @@ -\documentstyle[11pt,twoside]{article} - -\input{code} -\input{latex-stuff} - -\advance \textheight by 2ex - -\begin{document} - -\begin{center} -{\Large\bf The Scheme of Things:} \\ -\vspace{2ex} -{\Large\bf The June 1992 Meeting$^{\hbox{\scriptsize 1}}$} \\ -\vspace{3ex} -Jonathan Rees \\ -Cornell University \\ -{\tt jar@cs.cornell.edu} -\end{center} - -\vspace{3ex} - -\footnotetext[1]{To appear in {\em Lisp Pointers} V(4), -October--December 1992.} - - -An informally constituted group of people interested in the future of -the Scheme programming language met at the Xerox Palo Alto Research -Center on 25 June 1992. The main purpose of the meeting was to work -on the technical content of the next revision of the Scheme report. - -We made progress on several fronts: -\begin{itemize} -\item Some differences with the IEEE Scheme standard were resolved. - -\item Proposals for multiple return values and {\tt dynamic-wind} were -adopted. - -\item A proposal for an {\tt eval} procedure was adopted. - -\item The high-level macro facility described in the -Revised$^4$ Report's appendix will be moved into the report proper. -\end{itemize} - -Two subcommittees were formed: one to work on exceptions, and one to -charter the formation of a standard library. The subcommittees will -report back to the group with proposals for inclusion in the report. - -It had been hoped that there would be progress on some other fronts -(user-defined types, dynamic binding, improvements to ``rest'' -parameters), but after inconclusive discussion these topics were -dropped. These topics will probably be taken up again in the future. - -Norman Adams was appointed the Revised$^5$ Report's editor. It is -hoped that it will be ready by early 1993, so as to precede the -reconstitution of the IEEE standard group. - -This article is my own interpretation of what transpired, and should -not be construed as definitive. - - -\piece{Agreement with the IEEE Scheme standard} - -Until now, the Scheme reports have encouraged but not required the -empty list {\tt()} and the boolean false value {\tt\#f} to be -distinct. It has been the intent ever since the Revised Revised -Report, however, that this distinction would eventually be required. -The IEEE Scheme standard bit the bullet in 1990, and now the -Revised$^5$ report follows. - -The standard also dropped the distinction between essential and -not-essential language features; most features that were formerly not -essential, such as n-ary {\tt+} and {\tt apply}, are now required. -The Revised$^5$ Report will adopt this stance, at least as regards -language features that are shared with the IEEE standard. -Non-essential non-IEEE oddities such as {\tt transcript-on} and {\tt -transcript-off} and the proposed {\tt interaction-\ok{}environment} (see -below) were not discussed at the meeting, however, and consensus on -their status will have to be reached via electronic mail. - -A third aspect of the standard that was adopted was a certain obscure -paragraph regarding assignments to top-level variables (section 6, -paragraph 2). The effect of this is that if a program contains an -assignment to any top-level variable, then the program must contain a -{\tt define} for that variable; it is not sufficient that the variable -be bound. This has been the case for most variables, but the rule -applies as well to variables such as {\tt car} that have built-in -bindings. In addition, it is clarified that if a program makes such a -definition or assignment, then the behavior of built-in procedures -will not be affected. For example, redefining {\tt length} cannot -affect the behavior of the built-in {\tt list->vector} procedure. -If in some particular implementation {\tt list->vector} is written -in Scheme and calls {\tt length}, then it must be sure to call the -built-in {\tt length} procedure, not whatever happens to be the value -of the variable {\tt length}. - - -\piece{Multiple return values} - -The {\tt call-with-values} and {\tt values} procedures were described -in an earlier Scheme of Things ({\em Lisp Pointers}, volume IV, number -1), but I'll review them here. The following is adapted from John Ramsdell's -concise description: - -\begin{list}{}{}{}\item - {\tt(values \var{object} $\ldots$)} - \hfill {\rm essential procedure} - - {\tt values} delivers all of its arguments to its continuation. - - \vspace{2ex} - - {\tt(call-with-values \var{thunk} \var{receiver})} - \hfill {\rm essential procedure} - - {\tt call-with-values} calls its \var{thunk} argument with a - continuation that, when passed some values, calls the - \var{receiver} procedure with those values as arguments. - The continuation for the call to \var{receiver} is the - continuation of the call to {\tt call-with-values}. -\end{list} - -Except for continuations created by the {\tt call-with-values} -procedure, all continuations take exactly one value, as now; the -effect of passing no value or more than one value to continuations -that were not created by {\tt call-with-values} is unspecified (as -indeed it is unspecified now). - -{\tt values} might be defined as follows: -\begin{code} - (define (values . things) - (call-with-current-continuation - (lambda (cont) (apply cont things)))) -\end{code} -That is, the procedures supplied by {\tt -call-with-current-continuation} must be passed the same number of -arguments as values expected by the continuation. - -Because the behavior of a number-of-values mismatch between a -continuation and its invoker is unspecified, some implementations may -assign some specific meaning to such situations; for example, extra -values might be ignored, or defaults might be supplied for missing -values. Thus this multiple return value proposal is compatible with -Common Lisp's multiple values, but strictly more conservative than it. -The behavior of programs in such situations was a point of contention -among the authors, which is why only the least common denominator -behavior was specified. - - -\piece{Unwind/wind protection} - -{\tt dynamic-wind}, which was described previously in this column (when it -was The Scheme Environment; {\em Lisp Pointers}, volume I, number 2), -is already implemented in many Scheme dialects. {\tt dynamic-wind} -takes three arguments, all of which are thunks (procedures of no arguments). -It behaves as if it were defined with -\begin{code} - (define (dynamic-wind before during after) - (before) - (call-with-values during - (lambda results - (after) - (apply values results)))) -\end{code} -except that the execution of the {\tt during} thunk is ``protected'' -against non-local entries and exits: a throw out of the execution -of {\tt during} will cause the {\tt after} thunk to be invoked, and a -throw from outside back in will cause the {\tt before} thunk to be -invoked. (By ``throw'' I mean an invocation of an explicit -continuation as obtained from {\tt call-with-current-continuation}.) - -For details, the earlier Scheme Environment column refers the reader -to Friedman and Haynes's paper ``Constraining Control'' in POPL 1985, -but to save you the trouble of looking that up, I have supplied a more -direct implementation of {\tt dynamic-wind} in an appendix to the -present column. - -{\tt dynamic-wind} was adopted with the following clarifications: The -semantics of {\tt(dynamic-wind \var{before} \var{during} \var{after})} -should leave unspecified what happens if a throw occurs out of {\em -before} or {\em after}\/; and it is best to defer interrupts during {\em -before} and {\em after}. - - - -\piece{Evaluating computed expressions} - -The original 1975 memo on Scheme described {\tt evaluate}, -which was analogous to Lisp's traditional {\tt eval} function. {\tt -evaluate} took a single argument, an S-expression, and invoked an -interpreter on it. For example: -\begin{code} - (let ((name '+)) (evaluate (list name 2 3))) - \ev 5 -\end{code} -Scheme being lexically scoped, however, there was some confusion over -which environment the expression was to be evaluated in. Should -\begin{code} - (let ((name '+)) - (let ((+ *)) - (evaluate (list name 2 3)))) -\end{code} -evaluate to 5 or to 6? - -To clarify matters, the Revised Report replaced {\tt evaluate} with -{\tt enclose}, which took two arguments, a {\tt lambda}-expression and -a representation of an environment from which to supply bindings of the -{\tt lambda}-expression's free variables. For example: -\begin{code} - (let ((name '+)) - (let ((+ *)) - ((enclose (list 'lambda '() (list name 2 3)) - (list (cons '+ +)))))) - \ev 6 -\end{code} -This forced the programmer to be explicit about the {\tt -lambda}-expression's enclosing environment. - -For various technical and practical reasons, there was no {\tt eval} -analogue in subsequent Scheme reports. The major stumbling blocks -were how to describe {\tt eval} formally and how to define something -that makes sense in all extant variants of the language. Some Scheme -implementations contain a distinguished top-level environment, while -others extend the language by providing ways to create multiple -environments, any of which might serve equally well. - -The {\tt eval} proposal adopted at the June meeting, which I reproduce -here, is one that comes from Bill Rozas. - -\begin{list}{}{}{}\item - - {\tt(eval \var{expression} \var{environment-specifier})} - \hfill {\rm essential procedure} - - {\tt eval} evaluates \var{expression} in the environment indicated - by {\em environment-\discretionary{}{}{}specifier}. {\em - environment-specifier} may be the return value of one of the three - procedures described below, or implementation-specific extensions. - No other operations on environment specifiers are defined by this - proposal. - - Implementations may allow non-expression programs (i.e.\ - definitions) as the first argument to {\tt eval} \var{only} when - the second argument is the return value of {\tt interaction-environment} - or some implementation extension. In other words, {\tt eval} will never - create new bindings in the return value of {\tt null-environment} or - {\tt scheme-report-environment}. - - \vspace{2ex} - - {\tt(scheme-report-environment \var{version})} - \hfill {\rm essential procedure} - - {\em Version} must be an exact non-negative integer corresponding to a - version of one of the Revised$^n$ Reports on Scheme. This procedure - returns a specifier for an environment that contains exactly the - set of bindings specified in the corresponding report that the - implementation supports. Not all versions may be available in all - implementations at all times. However, an implementation that - conforms to version $n$ of the Revised$^n$ Reports on Scheme must - accept version $n$. If {\tt scheme-report-environment} is - available, but the specified version is not, the procedure will - signal an error. - - The effect of assigning (through the use of {\tt eval}) a variable - bound in a {\tt scheme-report-environment} (e.g.\ {\tt car}) is - unspecified. Thus the environments specified by the return - values of {\tt scheme-report-environment} may be immutable. - - \vspace{2ex} - - {\tt(null-environment)} - \hfill {\rm essential procedure} - - This procedure returns a specifier for an environment that contains no - variable bindings, but contains (syntactic) bindings for all the - syntactic keywords defined in the report, and no others. - - \vspace{2ex} - %\newpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - - {\tt(interaction-environment)} - \hfill {\rm procedure} - - This procedure returns a specifier for an environment that - contains imple\-men\-ta\-tion-defined bindings, typically a superset of - those listed in the report. The intent is that this procedure - will return a specifier for the environment in which the - implementation would evaluate expressions dynamically typed by the - user. - -\end{list} - -Rozas explains: -``The proposal does not imply the existence or support of first-class -environments, although it is compatible with them. -The proposal only requires a way of associating tags with a finite set -of distinguished environments which the implementations can maintain -implicitly (without reification). - -``\,`Pascal-like' implementations can support both {\tt null-environment} and -%\penalty0 -{\tt scheme-report-environment} since the environments specified by -the return values of these procedures need not share any bindings with -the current program. A version of {\tt eval} that supports these but -not {\tt interaction-environment} can be written portably, -but can be better written by the implementor, since it can share code -with the default evaluator or compiler.'' - -Here ``Pascal-like'' refers to implementations that are restricted to -static compilation and linking. Because an {\tt eval} that doesn't -support -\penalty0 -{\tt interaction-\discretionary{}{}{}environment} can be written -entirely in the Scheme language described by the rest of the report, -it raises no troublesome questions about its formal semantics. - - -\piece{Macros} - -The consensus of the meeting was that {\tt define-syntax}, {\tt -syntax-rules}, {\tt let-\discretionary{}{}{}syntax}, and {\tt -letrec-syntax} should be moved out of the report's appendix into the -main body of the report. Although everyone agrees that a low-level -macro facility is important, the subject is too contentious at -present, with three or more competing proposals at present. The -disposition of the rest of the appendix and of the other low-level -proposals will be left up to the report's editor. - - -\piece{Committee work} - -There is a strong sense that some kind of exception system is needed. -However, no specific proposal was ready at the time of the meeting. A -committee has been formed to work on one. What seems to be in the -air might be described as a highly distilled version of the condition -system that Kent Pitman developed for Common Lisp. I hope that I'll -be able to report on this in a future column. - - -On the subject of libraries, Will Clinger's minutes report that -``the authors perceive a need to give some library official status. In -fact, we need to give official sanction to multiple libraries. There -is reason to distinguish between accepted (or standard) libraries, -experimental libraries, and proposals. The accepted libraries can -reduce the intellectual size of the language by removing things like -{\tt string->list} from the report. The experimental libraries would -contain solid implementations of experimental features, including -things that might never deserve to be in the report. The proposal -libraries could contain anything implemented in portable Scheme.'' - - -Among the content of the accepted libraries, some features (such as -those that may be moved out of the body of the report) may be required -to be built in to implementations, while others will be expected to be -available on demand (perhaps using something similar to, but not the -same as, {\tt require} as found in Common Lisp and GNU Emacs). - -A librarian was appointed (Rees), and a library committee is -developing proposals for the charter, structure, and content of the -libraries. - - -\separator - -I would like to acknowledge Will Clinger, who prepared the minutes of -the meeting, and the various people who contributed proposals, -including Bill Rozas and John Ramsdell. Any errors here are my -responsibility, however. Thanks also to Norman Adams and Richard -Kelsey for corrections to a draft of this article. - -I would also like to belatedly acknowledge Norman Adams, Pavel -Curtis, Bruce Donald, and Richard Kelsey for their comments on drafts of -my previous column. - -For future columns, I am entertaining various topic possibilities, -including {\tt eval}, threads, {\tt amb}, and monads. -If you have other ideas, and particularly if you think the written -record on the language is particularly poor in certain areas, please -write and let me know. - -\vspace{2ex} - -%\newpage - -%\bgroup \small - -\piece{Appendix: An implementation of {\tt dynamic-wind}} - -This program is based on my vague recollection of an ancient -manuscript by Chris Hanson and John Lamping. I apologize for the lack -of data abstraction, but the code is more concise this way. - -A state space is a tree with the current state at the root. Each node other -than the root is a triple $\langle\var{before}, \var{after}, -\var{parent}\rangle$, represented in this implementation as two pairs -{\tt((\var{before} .\ \var{after}) .\ \var{parent})}. -Navigating between states requires re-rooting the tree by reversing -parent-child links. - -Since {\tt dynamic-wind} interacts with {\tt -call-with-current-continuation}, this implementation must replace the -usual definition of the latter. - -\begin{code} -(define *here* (list #f)) -\codeskip -(define original-cwcc call-with-current-continuation) -\codeskip -(define (call-with-current-continuation proc) - (let ((here *here*)) - (original-cwcc (lambda (cont) - (proc (lambda results - (reroot! here) - (apply cont results))))))) -\codeskip -(define (dynamic-wind before during after) - (let ((here *here*)) - (reroot! (cons (cons before after) here)) - (call-with-values during - (lambda results - (reroot! here) - (apply values results))))) -\codeskip -(define (reroot! there) - (if (not (eq? *here* there)) - (begin (reroot! (cdr there)) - (let ((before (caar there)) - (after (cdar there))) - (set-car! *here* (cons after before)) - (set-cdr! *here* there) - (set-car! there #f) - (set-cdr! there '()) - (set! *here* there) - (before))))) -\end{code} - -%\egroup - -\end{document} diff --git a/doc/module.ps b/doc/module.ps deleted file mode 100644 index 9ef281b..0000000 --- a/doc/module.ps +++ /dev/null @@ -1,1417 +0,0 @@ -%!PS-Adobe-2.0 -%%Creator: dvips 5.521 Copyright 1986, 1993 Radical Eye Software -%%CreationDate: Sat Jan 15 16:16:41 1994 -%%Pages: 14 -%%PageOrder: Ascend -%%BoundingBox: 0 0 612 792 -%%EndComments -%DVIPSCommandLine: dvips -f -%DVIPSSource: TeX output 1994.01.15:1616 -%%BeginProcSet: tex.pro -/TeXDict 250 dict def TeXDict begin /N{def}def /B{bind def}N /S{exch}N -/X{S N}B /TR{translate}N /isls false N /vsize 11 72 mul N /hsize 8.5 72 -mul N /landplus90{false}def /@rigin{isls{[0 landplus90{1 -1}{-1 1} -ifelse 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale -isls{landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div -hsize mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul -TR matrix currentmatrix dup dup 4 get round 4 exch put dup dup 5 get -round 5 exch put setmatrix}N /@landscape{/isls true N}B /@manualfeed{ -statusdict /manualfeed true put}B /@copies{/#copies X}B /FMat[1 0 0 -1 0 -0]N /FBB[0 0 0 0]N /nn 0 N /IE 0 N /ctr 0 N /df-tail{/nn 8 dict N nn -begin /FontType 3 N /FontMatrix fntrx N /FontBBox FBB N string /base X -array /BitMaps X /BuildChar{CharBuilder}N /Encoding IE N end dup{/foo -setfont}2 array copy cvx N load 0 nn put /ctr 0 N[}B /df{/sf 1 N /fntrx -FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0]N df-tail}B /E{ -pop nn dup definefont setfont}B /ch-width{ch-data dup length 5 sub get} -B /ch-height{ch-data dup length 4 sub get}B /ch-xoff{128 ch-data dup -length 3 sub get sub}B /ch-yoff{ch-data dup length 2 sub get 127 sub}B -/ch-dx{ch-data dup length 1 sub get}B /ch-image{ch-data dup type -/stringtype ne{ctr get /ctr ctr 1 add N}if}B /id 0 N /rw 0 N /rc 0 N /gp -0 N /cp 0 N /G 0 N /sf 0 N /CharBuilder{save 3 1 roll S dup /base get 2 -index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx 0 ch-xoff -ch-yoff ch-height sub ch-xoff ch-width add ch-yoff setcachedevice -ch-width ch-height true[1 0 0 -1 -.1 ch-xoff sub ch-yoff .1 add]{ -ch-image}imagemask restore}B /D{/cc X dup type /stringtype ne{]}if nn -/base get cc ctr put nn /BitMaps get S ctr S sf 1 ne{dup dup length 1 -sub dup 2 index S get sf div put}if put /ctr ctr 1 add N}B /I{cc 1 add D -}B /bop{userdict /bop-hook known{bop-hook}if /SI save N @rigin 0 0 -moveto /V matrix currentmatrix dup 1 get dup mul exch 0 get dup mul add -.99 lt{/QV}{/RV}ifelse load def pop pop}N /eop{SI restore showpage -userdict /eop-hook known{eop-hook}if}N /@start{userdict /start-hook -known{start-hook}if pop /VResolution X /Resolution X 1000 div /DVImag X -/IE 256 array N 0 1 255{IE S 1 string dup 0 3 index put cvn put}for -65781.76 div /vsize X 65781.76 div /hsize X}N /p{show}N /RMat[1 0 0 -1 0 -0]N /BDot 260 string N /rulex 0 N /ruley 0 N /v{/ruley X /rulex X V}B /V -{}B /RV statusdict begin /product where{pop product dup length 7 ge{0 7 -getinterval dup(Display)eq exch 0 4 getinterval(NeXT)eq or}{pop false} -ifelse}{false}ifelse end{{gsave TR -.1 -.1 TR 1 1 scale rulex ruley -false RMat{BDot}imagemask grestore}}{{gsave TR -.1 -.1 TR rulex ruley -scale 1 1 false RMat{BDot}imagemask grestore}}ifelse B /QV{gsave -transform round exch round exch itransform moveto rulex 0 rlineto 0 -ruley neg rlineto rulex neg 0 rlineto fill grestore}B /a{moveto}B /delta -0 N /tail{dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail} -B /c{-4 M}B /d{-3 M}B /e{-2 M}B /f{-1 M}B /g{0 M}B /h{1 M}B /i{2 M}B /j{ -3 M}B /k{4 M}B /w{0 rmoveto}B /l{p -4 w}B /m{p -3 w}B /n{p -2 w}B /o{p --1 w}B /q{p 1 w}B /r{p 2 w}B /s{p 3 w}B /t{p 4 w}B /x{0 S rmoveto}B /y{ -3 2 roll p a}B /bos{/SS save N}B /eos{SS restore}B end -%%EndProcSet -TeXDict begin 40258431 52099146 1000 300 300 () @start -/Fa 3 103 df<70F8F8F87005057C840D>58 D<0000FE0200078186001C004C0038003C -0060003C00C0001C01C0001803800018070000180F0000181E0000101E0000103C000000 -3C00000078000000780000007800000078000000F0000000F0000000F0000000F0000000 -F00000807000008070000080700001003800010038000200180004000C00180006002000 -0381C00000FE00001F217E9F21>67 D<00007C0000CE00019E00039E00030C0007000007 -00000700000700000E00000E00000E0000FFF0000E00000E00001C00001C00001C00001C -00001C0000380000380000380000380000380000700000700000700000700000700000E0 -0000E00000E00000E00000C00001C000318000798000F300006200003C000017297E9F16 ->102 D E /Fb 2 54 df<00300030007000F001F0017002700470087018701070207040 -70C070FFFE0070007000700070007003FE0F157F9412>52 D<20303FE03FC02400200020 -00200020002F8030E020700030003800384038E038E0388030406020C01F000D157E9412 ->I E /Fc 1 4 df<020002000200C218F2783AE00F800F803AE0F278C218020002000200 -0D0E7E8E12>3 D E /Fd 7 107 df0 -D<03C00FF01FF83FFC7FFE7FFEFFFFFFFFFFFFFFFFFFFFFFFF7FFE7FFE3FFC1FF80FF003 -C010127D9317>15 D<000000040000000002000000000200000000010000000000800000 -0000400000000020FFFFFFFFFCFFFFFFFFFC000000002000000000400000000080000000 -010000000002000000000200000000040026107D922D>33 D<0000020000000003000000 -000300000000018000000000C000000000C00000000060007FFFFFF000FFFFFFFC000000 -000E00000000038000000001F0000000007C00000000F000000003C00000000700000000 -0C00FFFFFFF8007FFFFFF0000000006000000000C0000000018000000001800000000300 -0000000300000000020000261A7D972D>41 D<004000C001800180018003000300030006 -00060006000C000C00180018001800300030003000600060006000C000C0006000600060 -003000300030001800180018000C000C0006000600060003000300030001800180018000 -C000400A2E7CA112>104 DII E /Fe 41 123 df<70F8F8F8F8F8F8F8F8 -F8F8F8F8F8F8F8F870000000000070F8F8F870051C779B18>33 D<4010E038F078E038E0 -38E038E038E038E038E038E038E038E03860300D0E7B9C18>I<387C7C7E3E0E0E0E1C1C -38F8F0C0070E789B18>39 D<007000F001E003C007800F001E001C003800380070007000 -70007000E000E000E000E000E000E000E000E0007000700070007000380038001C001E00 -0F00078003C001F000F000700C24799F18>I<6000F00078003C001E000F000780038001 -C001C000E000E000E000E00070007000700070007000700070007000E000E000E000E001 -C001C0038007800F001E003C007800F00060000C247C9F18>I<01C00001C00001C00001 -C000C1C180F1C780F9CF807FFF001FFC0007F00007F0001FFC007FFF00F9CF80F1C780C1 -C18001C00001C00001C00001C00011147D9718>I<00600000F00000F00000F00000F000 -00F00000F00000F0007FFFC0FFFFE0FFFFE07FFFC000F00000F00000F00000F00000F000 -00F00000F00000600013147E9718>I<1C3E7E7F3F1F070E1E7CF860080C788518>I<7FFF -00FFFF80FFFF807FFF0011047D8F18>I<3078FCFC78300606778518>I<01800380038007 -800F803F80FF80FB80438003800380038003800380038003800380038003800380038003 -800380038003807FFCFFFE7FFC0F1C7B9B18>49 D<03F0000FFE003FFF007C0F807003C0 -E001C0F000E0F000E06000E00000E00000E00001C00001C00003C0000780000F00001E00 -003C0000780000F00001E00007C0000F80001E00E03C00E07FFFE0FFFFE07FFFE0131C7E -9B18>I<07F8001FFE003FFF007807807803C07801C03001C00001C00003C0000380000F -0003FF0003FE0003FF000007800003C00001C00000E00000E00000E0F000E0F000E0F001 -C0F003C07C07803FFF001FFE0003F800131C7E9B18>I<3078FCFC783000000000000000 -003078FCFC78300614779318>58 D<600000F00000FC00007E00003F00001FC00007E000 -03F00001FC00007E00003F00001F80001F80003F00007E0001FC0003F00007E0001FC000 -3F00007E0000FC0000F0000060000011187D9918>62 D<0FF0003FFC007FFF00700F00F0 -0380F00380600780000F00003E00007C0001F00001E00003C00003C00003C00003C00003 -C00003800000000000000000000000000000000003800007C00007C00007C00003800011 -1C7D9B18>I<1FE0003FF8007FFC00781E00300E0000070000070000FF0007FF001FFF00 -7F0700780700E00700E00700E00700F00F00781F003FFFF01FFBF007E1F014147D9318> -97 D<7E0000FE00007E00000E00000E00000E00000E00000E00000E3E000EFF800FFFC0 -0FC1E00F80E00F00700E00700E00380E00380E00380E00380E00380E00380F00700F0070 -0F80E00FC1E00FFFC00EFF80063E00151C809B18>I<01FE0007FF001FFF803E07803803 -00700000700000E00000E00000E00000E00000E00000E000007000007001C03801C03E03 -C01FFF8007FF0001FC0012147D9318>I<001F80003F80001F8000038000038000038000 -038000038003E3800FFB801FFF803C1F80380F80700780700380E00380E00380E00380E0 -0380E00380E00380700780700780380F803C1F801FFFF00FFBF803E3F0151C7E9B18>I< -01F00007FC001FFE003E0F00380780700380700380E001C0E001C0FFFFC0FFFFC0FFFFC0 -E000007000007001C03801C03E03C01FFF8007FF0001FC0012147D9318>I<001F80007F -C000FFE000E1E001C0C001C00001C00001C0007FFFC0FFFFC0FFFFC001C00001C00001C0 -0001C00001C00001C00001C00001C00001C00001C00001C00001C00001C00001C0007FFF -007FFF007FFF00131C7F9B18>I<01E1F007FFF80FFFF81E1E301C0E0038070038070038 -07003807003807001C0E001E1E001FFC001FF80039E0003800001C00001FFE001FFFC03F -FFE07801F0700070E00038E00038E00038E000387800F07E03F01FFFC00FFF8001FC0015 -1F7F9318>I<7E0000FE00007E00000E00000E00000E00000E00000E00000E3E000EFF80 -0FFFC00FC1C00F80E00F00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E0 -0E00E00E00E00E00E07FC3FCFFE7FE7FC3FC171C809B18>I<03800007C00007C00007C0 -000380000000000000000000000000007FC000FFC0007FC00001C00001C00001C00001C0 -0001C00001C00001C00001C00001C00001C00001C00001C00001C00001C000FFFF00FFFF -80FFFF00111D7C9C18>I107 -D<7FE000FFE0007FE00000E00000E00000E00000E00000E00000E00000E00000E00000E0 -0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0 -0000E0007FFFC0FFFFE07FFFC0131C7E9B18>I<7CE0E000FFFBF8007FFFF8001F1F1C00 -1E1E1C001E1E1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C00 -1C1C1C001C1C1C001C1C1C001C1C1C007F1F1F00FFBFBF807F1F1F001914819318>I<7E -3E00FEFF807FFFC00FC1C00F80E00F00E00E00E00E00E00E00E00E00E00E00E00E00E00E -00E00E00E00E00E00E00E00E00E07FC3FCFFE7FE7FC3FC1714809318>I<01F0000FFE00 -1FFF003E0F803803807001C07001C0E000E0E000E0E000E0E000E0E000E0F001E07001C0 -7803C03C07803E0F801FFF000FFE0001F00013147E9318>I<7E3E00FEFF807FFFC00FC1 -E00F80E00F00700E00700E00380E00380E00380E00380E00380E00380F00700F00700F80 -E00FC1E00FFFC00EFF800E3E000E00000E00000E00000E00000E00000E00000E00007FC0 -00FFE0007FC000151E809318>I<01E38007FB801FFF803E1F80380F80700780700780E0 -0380E00380E00380E00380E00380E00380700780700780380F803C1F801FFF800FFB8003 -E380000380000380000380000380000380000380000380003FF8003FF8003FF8151E7E93 -18>I<7F87E0FF9FF07FBFF803F87803F03003E00003C00003C000038000038000038000 -0380000380000380000380000380000380007FFE00FFFF007FFE0015147F9318>I<07F7 -003FFF007FFF00780F00E00700E00700E007007C00007FE0001FFC0003FE00001F006007 -80E00380E00380F00380F80F00FFFF00FFFC00E7F00011147D9318>I<01800003800003 -80000380000380007FFFC0FFFFC0FFFFC003800003800003800003800003800003800003 -80000380000380000380400380E00380E00380E001C1C001FFC000FF80003E0013197F98 -18>I<7E07E0FE0FE07E07E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E0 -0E00E00E00E00E00E00E00E00E01E00F03E007FFFC03FFFE01FCFC1714809318>I<7F8F -F0FF8FF87F8FF01E03C00E03800E03800E0380070700070700070700038E00038E00038E -00038E0001DC0001DC0001DC0000F80000F80000700015147F9318>II<7F8FF07F9FF07F8FF0070700 -078E00039E0001DC0001F80000F80000700000F00000F80001DC00039E00038E00070700 -0F07807F8FF0FF8FF87F8FF015147F9318>I<7F8FF0FF8FF87F8FF00E01C00E03800E03 -80070380070700070700038700038600038E0001CE0001CE0000CC0000CC0000DC000078 -0000780000780000700000700000700000F00000E00079E0007BC0007F80003F00001E00 -00151E7F9318>I<3FFFF07FFFF07FFFF07001E07003C0700780000F00001E00003C0000 -F80001F00003C0000780000F00701E00703C0070780070FFFFF0FFFFF0FFFFF014147F93 -18>I E /Ff 35 122 df<00003FE00000E0100001803800038078000300780007003000 -0700000007000000070000000E0000000E0000000E000000FFFFE0000E00E0001C01C000 -1C01C0001C01C0001C01C0001C0380003803800038038000380380003807000038070000 -7007000070071000700E2000700E2000700E2000E00E2000E0064000E0038000E0000000 -C0000001C0000001C000003180000079800000F3000000620000003C0000001D29829F1A ->12 D<1C3C3C3C3C040408081020204080060E7D840E>44 D<7FF0FFE07FE00C037D8A10 ->I<70F8F8F0E005057B840E>I<00000200000006000000060000000E0000001E0000001E -0000003F0000002F0000004F0000004F0000008F0000010F0000010F0000020F0000020F -0000040F00000C0F0000080F0000100F0000100F0000200F80003FFF800040078000C007 -800080078001000780010007800200078002000780060007801E000F80FF807FF81D207E -9F22>65 D<0000FE0200078186001C004C0038003C0060003C00C0001C01C00018038000 -18070000180F0000181E0000101E0000103C0000003C0000007800000078000000780000 -0078000000F0000000F0000000F0000000F0000000F00000807000008070000080700001 -003800010038000200180004000C001800060020000381C00000FE00001F217A9F21>67 -D<01FFFFFC001E0038001E0018001E0008001E0008003C0008003C0008003C0008003C00 -080078001000780800007808000078080000F0100000F0300000FFF00000F0300001E020 -0001E0200001E0200001E0200003C0000003C0000003C0000003C0000007800000078000 -0007800000078000000F800000FFF800001E1F7D9E1E>70 D<01FFF0001F00001E00001E -00001E00003C00003C00003C00003C0000780000780000780000780000F00000F00000F0 -0000F00001E00001E00001E00001E00003C00003C00003C00003C0000780000780000780 -000780000F8000FFF800141F7D9E12>73 D<01FFF800001F0000001E0000001E0000001E -0000003C0000003C0000003C0000003C00000078000000780000007800000078000000F0 -000000F0000000F0000000F0000001E0000001E0000001E0000001E0008003C0010003C0 -010003C0030003C00200078006000780060007800C0007801C000F007800FFFFF800191F -7D9E1D>76 D<01FE00007FC0001E0000FC00001E0000F800001700017800001700017800 -00270002F00000270004F00000270004F00000270008F00000470009E00000470011E000 -00470021E00000470021E00000870043C00000838043C00000838083C00000838083C000 -0103810780000103820780000103820780000103840780000203840F00000203880F0000 -0203900F00000203900F00000401E01E00000401E01E00000401C01E00000C01801E0000 -1C01803E0000FF8103FFC0002A1F7D9E29>I<01FFFF80001E00E0001E0070001E003800 -1E003C003C003C003C003C003C003C003C003C0078007800780078007800F0007800E000 -F003C000F00F0000FFFC0000F0000001E0000001E0000001E0000001E0000003C0000003 -C0000003C0000003C00000078000000780000007800000078000000F800000FFF000001E -1F7D9E1F>80 D<01FFFF00001E03C0001E00E0001E0070001E0078003C0078003C007800 -3C0078003C0078007800F0007800F0007801E0007801C000F0070000F01E0000FFF00000 -F0380001E01C0001E01E0001E00E0001E00F0003C01E0003C01E0003C01E0003C01E0007 -803C0007803C0807803C0807803C100F801C10FFF00C20000007C01D207D9E21>82 -D<0007E040001C18C0003005800060038000C0038001C001800180010003800100038001 -00038001000380000003C0000003C0000003F8000001FF800001FFE000007FF000001FF0 -000001F80000007800000078000000380000003800200038002000380020003000600070 -00600060006000E0007000C000E8038000C606000081F800001A217D9F1A>I<00F18003 -89C00707800E03801C03803C0380380700780700780700780700F00E00F00E00F00E00F0 -0E20F01C40F01C40703C40705C40308C800F070013147C9317>97 -D<07803F8007000700070007000E000E000E000E001C001C001CF01D0C3A0E3C0E380F38 -0F700F700F700F700FE01EE01EE01EE01CE03CE038607060E031C01F0010207B9F15>I< -007E0001C1000300800E07801E07801C07003C0200780000780000780000F00000F00000 -F00000F00000F0000070010070020030040018380007C00011147C9315>I<0000780003 -F80000700000700000700000700000E00000E00000E00000E00001C00001C000F1C00389 -C00707800E03801C03803C0380380700780700780700780700F00E00F00E00F00E00F00E -20F01C40F01C40703C40705C40308C800F070015207C9F17>I<007C01C207010E011C01 -3C013802780C7BF07C00F000F000F000F0007000700170023804183807C010147C9315> -I<00007800019C00033C00033C000718000700000700000E00000E00000E00000E00000E -0001FFE0001C00001C00001C00001C000038000038000038000038000038000070000070 -0000700000700000700000700000E00000E00000E00000E00000C00001C00001C0000180 -003180007B0000F300006600003C00001629829F0E>I<003C6000E27001C1E00380E007 -00E00F00E00E01C01E01C01E01C01E01C03C03803C03803C03803C03803C07003C07001C -0F001C17000C2E0003CE00000E00000E00001C00001C00301C00783800F0700060E0003F -8000141D7E9315>I<01E0000FE00001C00001C00001C00001C000038000038000038000 -038000070000070000071E000763000E81800F01C00E01C00E01C01C03801C03801C0380 -1C0380380700380700380700380E10700E20700C20701C20700C40E00CC060070014207D -9F17>I<00C001E001E001C000000000000000000000000000000E003300230043804300 -470087000E000E000E001C001C001C003840388030807080310033001C000B1F7C9E0E> -I<01E0000FE00001C00001C00001C00001C0000380000380000380000380000700000700 -000703C00704200E08E00E11E00E21E00E40C01C80001D00001E00001FC00038E0003870 -00387000383840707080707080707080703100E03100601E0013207D9F15>107 -D<03C01FC0038003800380038007000700070007000E000E000E000E001C001C001C001C -0038003800380038007000700070007100E200E200E200E200640038000A207C9F0C>I< -1C0F80F0002630C318004740640C004780680E004700700E004700700E008E00E01C000E -00E01C000E00E01C000E00E01C001C01C038001C01C038001C01C038001C01C070803803 -8071003803806100380380E10038038062007007006600300300380021147C9325>I<1C -0F802630C04740604780604700704700708E00E00E00E00E00E00E00E01C01C01C01C01C -01C01C03843803883803083807083803107003303001C016147C931A>I<007C0001C300 -0301800E01C01E01C01C01E03C01E07801E07801E07801E0F003C0F003C0F003C0F00780 -F00700700F00700E0030180018700007C00013147C9317>I<01C1E002621804741C0478 -1C04701E04701E08E01E00E01E00E01E00E01E01C03C01C03C01C03C01C0380380780380 -700380E003C1C0072380071E000700000700000E00000E00000E00000E00001C00001C00 -00FFC000171D809317>I<1C1E002661004783804787804707804703008E00000E00000E -00000E00001C00001C00001C00001C000038000038000038000038000070000030000011 -147C9313>114 D<00FC030206010C030C070C060C000F800FF007F803FC003E000E700E -F00CF00CE008401020601F8010147D9313>I<018001C0038003800380038007000700FF -F007000E000E000E000E001C001C001C001C003800380038003820704070407080708031 -001E000C1C7C9B0F>I<0E00C03300E02301C04381C04301C04701C08703800E03800E03 -800E03801C07001C07001C07001C07101C0E20180E20180E201C1E200C264007C3801414 -7C9318>I<0E00C1C03300E3C02301C3E04381C1E04301C0E04701C060870380400E0380 -400E0380400E0380401C0700801C0700801C0700801C0701001C0701001C0602001C0F02 -000C0F04000E13080003E1F0001B147C931E>119 D<0383800CC4401068E01071E02071 -E02070C040E00000E00000E00000E00001C00001C00001C00001C040638080F38080F381 -00E5810084C60078780013147D9315>I<0E00C03300E02301C04381C04301C04701C087 -03800E03800E03800E03801C07001C07001C07001C07001C0E00180E00180E001C1E000C -3C0007DC00001C00001C00003800F03800F07000E06000C0C0004380003E0000131D7C93 -16>I E /Fg 27 118 df<000FF000007FFC0001F80E0003E01F0007C03F000F803F000F -803F000F801E000F800C000F8000000F8000000F8000000F800000FFFFFF00FFFFFF000F -801F000F801F000F801F000F801F000F801F000F801F000F801F000F801F000F801F000F -801F000F801F000F801F000F801F000F801F000F801F000F801F000F801F000F801F007F -F0FFE07FF0FFE01B237FA21F>12 D45 -D<0003FE0080001FFF818000FF01E38001F8003F8003E0001F8007C0000F800F80000780 -1F800007803F000003803F000003807F000001807E000001807E00000180FE00000000FE -00000000FE00000000FE00000000FE00000000FE00000000FE00000000FE000000007E00 -0000007E000001807F000001803F000001803F000003801F800003000F8000030007C000 -060003F0000C0001F800380000FF00F000001FFFC0000003FE000021227DA128>67 -DI72 -DI77 -D<01FC0407FF8C1F03FC3C007C7C003C78001C78001CF8000CF8000CFC000CFC0000FF00 -00FFE0007FFF007FFFC03FFFF01FFFF80FFFFC03FFFE003FFE0003FF00007F00003F0000 -3FC0001FC0001FC0001FE0001EE0001EF0003CFC003CFF00F8C7FFE080FF8018227DA11F ->83 D<7FFFFFFF807FFFFFFF807E03F80F807803F807807003F803806003F80180E003F8 -01C0E003F801C0C003F800C0C003F800C0C003F800C0C003F800C00003F800000003F800 -000003F800000003F800000003F800000003F800000003F800000003F800000003F80000 -0003F800000003F800000003F800000003F800000003F800000003F800000003F8000000 -03F800000003F800000003F800000003F8000003FFFFF80003FFFFF80022227EA127>I< -07FC001FFF803F07C03F03E03F01E03F01F01E01F00001F00001F0003FF003FDF01FC1F0 -3F01F07E01F0FC01F0FC01F0FC01F0FC01F07E02F07E0CF81FF87F07E03F18167E951B> -97 D<00FF8007FFE00F83F01F03F03E03F07E03F07C01E07C0000FC0000FC0000FC0000 -FC0000FC0000FC00007C00007E00007E00003E00301F00600FC0E007FF8000FE0014167E -9519>99 D<0001FE000001FE0000003E0000003E0000003E0000003E0000003E0000003E -0000003E0000003E0000003E0000003E0000003E0001FC3E0007FFBE000F81FE001F007E -003E003E007E003E007C003E00FC003E00FC003E00FC003E00FC003E00FC003E00FC003E -00FC003E00FC003E007C003E007C003E003E007E001E00FE000F83BE0007FF3FC001FC3F -C01A237EA21F>I<00FE0007FF800F87C01E01E03E01F07C00F07C00F8FC00F8FC00F8FF -FFF8FFFFF8FC0000FC0000FC00007C00007C00007E00003E00181F00300FC07003FFC000 -FF0015167E951A>I<003F8000FFC001E3E003C7E007C7E00F87E00F83C00F80000F8000 -0F80000F80000F80000F8000FFFC00FFFC000F80000F80000F80000F80000F80000F8000 -0F80000F80000F80000F80000F80000F80000F80000F80000F80000F80000F80000F8000 -7FF8007FF80013237FA211>I<03FC1E0FFF7F1F0F8F3E07CF3C03C07C03E07C03E07C03 -E07C03E07C03E03C03C03E07C01F0F801FFF0013FC003000003000003800003FFF801FFF -F00FFFF81FFFFC3800FC70003EF0001EF0001EF0001EF0001E78003C7C007C3F01F80FFF -E001FF0018217E951C>II<1C003E007F007F007F003E001C000000000000000000 -000000000000FF00FF001F001F001F001F001F001F001F001F001F001F001F001F001F00 -1F001F001F001F001F00FFE0FFE00B247EA310>I107 DIII<00FE0007FFC00F83E01E00F03E00F87C007C7C007C7C00 -7CFC007EFC007EFC007EFC007EFC007EFC007EFC007E7C007C7C007C3E00F81F01F00F83 -E007FFC000FE0017167E951C>II114 D<0FF3003FFF00781F00600700E00300E00300F00300FC00007FE0007F -F8003FFE000FFF0001FF00000F80C00780C00380E00380E00380F00700FC0E00EFFC00C7 -F00011167E9516>I<0180000180000180000180000380000380000780000780000F8000 -3F8000FFFF00FFFF000F80000F80000F80000F80000F80000F80000F80000F80000F8000 -0F80000F80000F81800F81800F81800F81800F81800F830007C30003FE0000F80011207F -9F16>II -E /Fh 81 125 df<001F83E000F06E3001C078780380F8780300F0300700700007007000 -0700700007007000070070000700700007007000FFFFFF80070070000700700007007000 -070070000700700007007000070070000700700007007000070070000700700007007000 -0700700007007000070070000700700007007000070070007FE3FF001D20809F1B>11 -D<003F0000E0C001C0C00381E00701E00701E00700000700000700000700000700000700 -00FFFFE00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700 -E00700E00700E00700E00700E00700E00700E00700E07FC3FE1720809F19>I<003FE000 -E0E001C1E00381E00700E00700E00700E00700E00700E00700E00700E00700E0FFFFE007 -00E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E007 -00E00700E00700E00700E00700E00700E07FE7FE1720809F19>I<001F81F80000F04F04 -0001C07C06000380F80F000300F00F000700F00F00070070000007007000000700700000 -070070000007007000000700700000FFFFFFFF0007007007000700700700070070070007 -007007000700700700070070070007007007000700700700070070070007007007000700 -700700070070070007007007000700700700070070070007007007000700700700070070 -07007FE3FE3FF02420809F26>I<7038F87CFC7EFC7E743A040204020402080408041008 -1008201040200F0E7E9F17>34 D<70F8FCFC74040404080810102040060E7C9F0D>39 -D<0020004000800100020006000C000C00180018003000300030007000600060006000E0 -00E000E000E000E000E000E000E000E000E000E000E00060006000600070003000300030 -00180018000C000C000600020001000080004000200B2E7DA112>I<8000400020001000 -08000C00060006000300030001800180018001C000C000C000C000E000E000E000E000E0 -00E000E000E000E000E000E000E000C000C000C001C00180018001800300030006000600 -0C00080010002000400080000B2E7DA112>I<70F8FCFC74040404080810102040060E7C -840D>44 DI<70F8F8F87005057C840D>I<000100030003000600 -060006000C000C000C00180018001800300030003000600060006000C000C000C0018001 -8001800300030003000600060006000C000C000C00180018001800300030003000600060 -006000C000C000C000102D7DA117>I<03F0000E1C001C0E001806003807007003807003 -80700380700380F003C0F003C0F003C0F003C0F003C0F003C0F003C0F003C0F003C0F003 -C0F003C0F003C0F003C07003807003807003807807803807001806001C0E000E1C0003F0 -00121F7E9D17>I<018003800F80F3800380038003800380038003800380038003800380 -0380038003800380038003800380038003800380038003800380038007C0FFFE0F1E7C9D -17>I<03F0000C1C00100E00200700400780800780F007C0F803C0F803C0F803C02007C0 -0007C0000780000780000F00000E00001C0000380000700000600000C000018000030000 -0600400C00401800401000803FFF807FFF80FFFF80121E7E9D17>I<03F0000C1C00100E -00200F00780F80780780780780380F80000F80000F00000F00000E00001C0000380003F0 -00003C00000E00000F000007800007800007C02007C0F807C0F807C0F807C0F007804007 -80400F00200E001C3C0003F000121F7E9D17>I<000600000600000E00000E00001E0000 -2E00002E00004E00008E00008E00010E00020E00020E00040E00080E00080E00100E0020 -0E00200E00400E00C00E00FFFFF0000E00000E00000E00000E00000E00000E00000E0000 -FFE0141E7F9D17>I<1803001FFE001FFC001FF8001FE000100000100000100000100000 -10000010000011F000161C00180E001007001007800003800003800003C00003C00003C0 -7003C0F003C0F003C0E00380400380400700200600100E000C380003E000121F7E9D17> -I<007C000182000701000E03800C07801C0780380300380000780000700000700000F1F0 -00F21C00F40600F80700F80380F80380F003C0F003C0F003C0F003C0F003C07003C07003 -C07003803803803807001807000C0E00061C0001F000121F7E9D17>I<4000007FFFC07F -FF807FFF8040010080020080020080040000080000080000100000200000200000400000 -400000C00000C00001C00001800003800003800003800003800007800007800007800007 -8000078000078000078000030000121F7D9D17>I<03F0000C0C00100600300300200180 -6001806001806001807001807803003E03003F06001FC8000FF00003F80007FC000C7E00 -103F00300F806003804001C0C001C0C000C0C000C0C000C0C00080600180200100100200 -0C0C0003F000121F7E9D17>I<03F0000E18001C0C00380600380700700700700380F003 -80F00380F003C0F003C0F003C0F003C0F003C07007C07007C03807C0180BC00E13C003E3 -C0000380000380000380000700300700780600780E00700C002018001070000FC000121F -7E9D17>I<70F8F8F8700000000000000000000070F8F8F87005147C930D>I<70F8F8F870 -0000000000000000000070F0F8F878080808101010202040051D7C930D>I<7FFFFFE0FF -FFFFF00000000000000000000000000000000000000000000000000000000000000000FF -FFFFF07FFFFFE01C0C7D9023>61 D<000100000003800000038000000380000007C00000 -07C0000007C0000009E0000009E0000009E0000010F0000010F0000010F0000020780000 -2078000020780000403C0000403C0000403C0000801E0000801E0000FFFE0001000F0001 -000F0001000F00020007800200078002000780040003C00E0003C01F0007E0FFC03FFE1F -207F9F22>65 DI<000FC0400070 -30C001C009C0038005C0070003C00E0001C01E0000C01C0000C03C0000C07C0000407C00 -004078000040F8000000F8000000F8000000F8000000F8000000F8000000F8000000F800 -0000F8000000780000007C0000407C0000403C0000401C0000401E0000800E0000800700 -01000380020001C0040000703800000FC0001A217D9F21>IIII<000FE0200078186000E004E00380 -02E0070001E00F0000E01E0000601E0000603C0000603C0000207C00002078000020F800 -0000F8000000F8000000F8000000F8000000F8000000F8000000F8007FFCF80003E07800 -01E07C0001E03C0001E03C0001E01E0001E01E0001E00F0001E0070001E0038002E000E0 -046000781820000FE0001E217D9F24>II -I<0FFFC0007C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C -00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C00203C -00F83C00F83C00F83C00F0380040780040700030E0000F800012207E9E17>IIIII<001F800000F0F00001C0380007801E000F000F00 -0E0007001E0007803C0003C03C0003C07C0003E0780001E0780001E0F80001F0F80001F0 -F80001F0F80001F0F80001F0F80001F0F80001F0F80001F0F80001F0780001E07C0003E0 -7C0003E03C0003C03C0003C01E0007800E0007000F000F0007801E0001C0380000F0F000 -001F80001C217D9F23>II<001F -800000F0F00001C0380007801E000F000F000E0007001E0007803C0003C03C0003C07C00 -03E07C0003E0780001E0F80001F0F80001F0F80001F0F80001F0F80001F0F80001F0F800 -01F0F80001F0F80001F0780001E0780001E07C0003E03C0003C03C0F03C01E1087800E20 -C7000F20CF0007A0FE0001E0F80000F0F010001FF0100000701000007830000038700000 -3FF000003FE000001FE000000FC0000007801C297D9F23>II<07E0800C1980100780300380600180600180E001 -80E00080E00080E00080F00000F000007800007F00003FF0001FFC000FFE0003FF00001F -800007800003C00003C00001C08001C08001C08001C08001C0C00180C00380E00300F006 -00CE0C0081F80012217D9F19>I<7FFFFFE0780F01E0600F0060400F0020400F0020C00F -0030800F0010800F0010800F0010800F0010000F0000000F0000000F0000000F0000000F -0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F -0000000F0000000F0000000F0000000F0000000F0000001F800007FFFE001C1F7E9E21> -IIII<7FF83FF80FE00FC007C0070003C0020001E0040001F00C0000F0080000781000007C -1000003C2000003E4000001E4000000F8000000F8000000780000003C0000007E0000005 -E0000009F0000018F8000010780000207C0000603C0000401E0000801F0001800F000100 -0780020007C0070003C01F8007E0FFE01FFE1F1F7F9E22>II91 -D<080410082010201040204020804080408040B85CFC7EFC7E7C3E381C0F0E7B9F17>I< -FEFE06060606060606060606060606060606060606060606060606060606060606060606 -06060606060606FEFE072D7FA10D>I<1FE000303000781800781C00300E00000E00000E -00000E0000FE00078E001E0E00380E00780E00F00E10F00E10F00E10F01E10781E103867 -200F83C014147E9317>97 D<0E0000FE00000E00000E00000E00000E00000E00000E0000 -0E00000E00000E00000E00000E3E000EC3800F01C00F00E00E00E00E00700E00700E0078 -0E00780E00780E00780E00780E00780E00700E00700E00E00F00E00D01C00CC300083E00 -15207F9F19>I<03F80E0C1C1E381E380C70007000F000F000F000F000F000F000700070 -00380138011C020E0C03F010147E9314>I<000380003F80000380000380000380000380 -00038000038000038000038000038000038003E380061B801C0780380380380380700380 -700380F00380F00380F00380F00380F00380F003807003807003803803803807801C0780 -0E1B8003E3F815207E9F19>I<03F0000E1C001C0E00380700380700700700700380F003 -80F00380FFFF80F00000F00000F000007000007000003800801800800C010007060001F8 -0011147F9314>I<007C00C6018F038F07060700070007000700070007000700FFF00700 -070007000700070007000700070007000700070007000700070007000700070007007FF0 -1020809F0E>I<0000E003E3300E3C301C1C30380E00780F00780F00780F00780F00780F -00380E001C1C001E380033E0002000002000003000003000003FFE001FFF800FFFC03001 -E0600070C00030C00030C00030C000306000603000C01C038003FC00141F7F9417>I<0E -0000FE00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E -3E000E43000E81800F01C00F01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E -01C00E01C00E01C00E01C00E01C00E01C00E01C0FFE7FC16207F9F19>I<1C003E003E00 -3E001C000000000000000000000000000E007E000E000E000E000E000E000E000E000E00 -0E000E000E000E000E000E000E000E000E00FFC00A1F809E0C>I<00E001F001F001F000 -E0000000000000000000000000007007F000F00070007000700070007000700070007000 -700070007000700070007000700070007000700070007000706070F060F0C061803F000C -28829E0E>I<0E0000FE00000E00000E00000E00000E00000E00000E00000E00000E0000 -0E00000E00000E0FF00E03C00E03000E02000E04000E08000E10000E30000E70000EF800 -0F38000E1C000E1E000E0E000E07000E07800E03800E03C00E03E0FFCFF815207F9F18> -I<0E00FE000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E -000E000E000E000E000E000E000E000E000E000E000E000E000E00FFE00B20809F0C>I< -0E1F01F000FE618618000E81C81C000F00F00E000F00F00E000E00E00E000E00E00E000E -00E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00 -E00E000E00E00E000E00E00E000E00E00E000E00E00E00FFE7FE7FE023147F9326>I<0E -3E00FE43000E81800F01C00F01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E -01C00E01C00E01C00E01C00E01C00E01C00E01C0FFE7FC16147F9319>I<01F800070E00 -1C03803801C03801C07000E07000E0F000F0F000F0F000F0F000F0F000F0F000F07000E0 -7000E03801C03801C01C0380070E0001F80014147F9317>I<0E3E00FEC3800F01C00F00 -E00E00E00E00F00E00700E00780E00780E00780E00780E00780E00780E00700E00F00E00 -E00F01E00F01C00EC3000E3E000E00000E00000E00000E00000E00000E00000E00000E00 -00FFE000151D7F9319>I<03E0800619801C05803C0780380380780380700380F00380F0 -0380F00380F00380F00380F003807003807803803803803807801C0B800E138003E38000 -0380000380000380000380000380000380000380000380003FF8151D7E9318>I<0E78FE -8C0F1E0F1E0F0C0E000E000E000E000E000E000E000E000E000E000E000E000E000E00FF -E00F147F9312>I<1F9030704030C010C010C010E00078007F803FE00FF0007080388018 -8018C018C018E030D0608F800D147E9312>I<020002000200060006000E000E003E00FF -F80E000E000E000E000E000E000E000E000E000E000E000E080E080E080E080E08061003 -1001E00D1C7F9B12>I<0E01C0FE1FC00E01C00E01C00E01C00E01C00E01C00E01C00E01 -C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E03C00603C0030DC001F1FC1614 -7F9319>II< -FF9FE1FC3C0780701C0300601C0380200E0380400E0380400E03C0400707C0800704C080 -0704E080038861000388710003C8730001D0320001D03A0000F03C0000E01C0000E01C00 -00601800004008001E147F9321>I<7FC3FC0F01E00701C007018003810001C20000E400 -00EC00007800003800003C00007C00004E000087000107000303800201C00601E01E01E0 -FF07FE1714809318>II<3FFF380E -200E201C40384078407000E001E001C00380078007010E011E011C0338027006700EFFFE -10147F9314>III -E /Fi 18 122 df<000003800000000007C00000000007C0000000000FE0000000000FE0 -000000000FE0000000001FF0000000001FF0000000003FF8000000003FF8000000003FF8 -0000000073FC0000000073FC00000000F3FE00000000E1FE00000000E1FE00000001C0FF -00000001C0FF00000003C0FF80000003807F80000007807FC0000007003FC0000007003F -C000000E003FE000000E001FE000001E001FF000001C000FF000001FFFFFF000003FFFFF -F800003FFFFFF80000780007FC0000700003FC0000700003FC0000E00001FE0000E00001 -FE0001E00001FF0001C00000FF0001C00000FF00FFFE001FFFFEFFFE001FFFFEFFFE001F -FFFE2F297EA834>65 D77 D82 D<007F806003FFF0E007FFF9E0 -0F807FE01F001FE03E0007E07C0003E07C0001E0FC0001E0FC0001E0FC0000E0FE0000E0 -FE0000E0FF000000FFC000007FFE00007FFFE0003FFFFC001FFFFE000FFFFF8007FFFFC0 -03FFFFE000FFFFE00007FFF000007FF000000FF8000007F8000003F8600001F8E00001F8 -E00001F8E00001F8F00001F0F00001F0F80003F0FC0003E0FF0007C0FFE01F80F3FFFF00 -E0FFFE00C01FF0001D297CA826>I<001FF80000FFFE0003F01F0007E03F800FC03F801F -803F803F801F007F800E007F0000007F000000FF000000FF000000FF000000FF000000FF -000000FF000000FF0000007F0000007F0000007F8000003F8001C01F8001C00FC0038007 -E0070003F01E0000FFFC00001FE0001A1B7E9A1F>99 D<00003FF80000003FF80000003F -F800000003F800000003F800000003F800000003F800000003F800000003F800000003F8 -00000003F800000003F800000003F800000003F800000003F800001FE3F80000FFFBF800 -03F03FF80007E00FF8000FC007F8001F8003F8003F8003F8007F0003F8007F0003F8007F -0003F800FF0003F800FF0003F800FF0003F800FF0003F800FF0003F800FF0003F800FF00 -03F8007F0003F8007F0003F8007F0003F8003F8003F8001F8003F8000F8007F80007C00F -F80003F03BFF8000FFF3FF80003FC3FF80212A7EA926>I<003FE00001FFF80003F07E00 -07C01F000F801F801F800F803F800FC07F000FC07F0007C07F0007E0FF0007E0FF0007E0 -FFFFFFE0FFFFFFE0FF000000FF000000FF0000007F0000007F0000007F0000003F8000E0 -1F8000E00FC001C007E0038003F81F0000FFFE00001FF0001B1B7E9A20>I<0007F0003F -FC00FE3E01F87F03F87F03F07F07F07F07F03E07F00007F00007F00007F00007F00007F0 -0007F000FFFFC0FFFFC0FFFFC007F00007F00007F00007F00007F00007F00007F00007F0 -0007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F0 -0007F0007FFF807FFF807FFF80182A7EA915>I104 D108 DII<003FE00001FFFC0003F07E000FC0 -1F801F800FC03F800FE03F0007E07F0007F07F0007F07F0007F0FF0007F8FF0007F8FF00 -07F8FF0007F8FF0007F8FF0007F8FF0007F8FF0007F87F0007F07F0007F03F800FE03F80 -0FE01F800FC00FC01F8007F07F0001FFFC00003FE0001D1B7E9A22>I114 D<03FE300FFFF01E03F03800F0700070F00070F00070F80070FC -0000FFE0007FFE007FFF803FFFE01FFFF007FFF800FFF80003FC0000FC60007CE0003CF0 -003CF00038F80038FC0070FF01E0F7FFC0C1FF00161B7E9A1B>I<007000007000007000 -00700000F00000F00000F00001F00003F00003F00007F0001FFFF0FFFFF0FFFFF007F000 -07F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F000 -07F03807F03807F03807F03807F03807F03803F03803F87001F86000FFC0001F8015267F -A51B>II121 D E -end -%%EndProlog -%%BeginSetup -%%Feature: *Resolution 300dpi -TeXDict begin - -%%EndSetup -%%Page: 1 1 -1 0 bop 424 311 a Fi(Another)23 b(Mo)r(dule)f(System)g(for)i(Sc)n(heme) -825 407 y Fh(Jonathan)16 b(Rees)542 463 y(3)f(Jan)o(uary)g(1993)f(\(up) -q(dated)i(15)e(Jan)o(uary)h(1994\))295 614 y(This)e(memo)g(describ)q -(es)h(a)f(mo)q(dule)h(system)e(for)g(the)h(Sc)o(heme)h(programming)e -(lan-)224 670 y(guage.)19 b(The)13 b(mo)q(dule)h(system)e(is)h(unique)i -(in)e(the)g(exten)o(t)g(to)f(whic)o(h)i(it)f(supp)q(orts)f(b)q(oth)224 -727 y(static)k(linking)i(and)f(rapid)g(turnaround)f(during)h(program)e -(dev)o(elopmen)o(t.)24 b(The)16 b(de-)224 783 y(sign)g(w)o(as)e -(in\015uenced)k(b)o(y)d(Standard)h(ML)f(mo)q(dules[4])g(and)h(b)o(y)f -(the)g(mo)q(dule)i(system)224 840 y(for)h(Sc)o(heme)g(Xero)o(x[3)o(].) -29 b(It)18 b(has)g(also)g(b)q(een)h(shap)q(ed)g(b)o(y)f(the)g(needs)h -(of)f(Sc)o(heme)g(48,)224 896 y(a)i(virtual-mac)o(hine-based)i(Sc)o -(heme)f(implemen)o(tation)g(designed)g(to)e(run)i(b)q(oth)f(on)224 -953 y(w)o(orkstations)g(and)h(on)f(relativ)o(ely)i(small)g(\(less)f -(than)g(1)f(Mb)o(yte\))g(em)o(b)q(edded)i(con-)224 1009 -y(trollers.)295 1065 y(Except)10 b(where)g(noted,)h(ev)o(erything)g -(describ)q(ed)h(here)f(is)f(implemen)o(ted)i(in)f(Sc)o(heme)g(48,)224 -1122 y(and)k(exercised)i(b)o(y)e(the)g(Sc)o(heme)h(48)e(implemen)o -(tation)j(and)e(a)g(few)g(application)i(pro-)224 1178 -y(grams.)295 1235 y(Unlik)o(e)g(the)e(Common)f(Lisp)j(pac)o(k)m(age)e -(system,)g(the)g(mo)q(dule)i(system)e(describ)q(ed)224 -1291 y(here)22 b(con)o(trols)g(the)f(mapping)i(of)e(names)h(to)f -(denotations,)i(not)e(the)h(mapping)g(of)224 1348 y(strings)15 -b(to)g(sym)o(b)q(ols.)224 1468 y Fg(In)n(tro)r(duction)224 -1553 y Fh(The)h(mo)q(dule)h(system)e(supp)q(orts)g(the)h(structured)f -(division)j(of)d(a)g(corpus)h(of)f(Sc)o(heme)224 1610 -y(soft)o(w)o(are)10 b(in)o(to)i(a)g(set)f(of)h(mo)q(dules.)20 -b(Eac)o(h)12 b(mo)q(dule)h(has)e(its)h(o)o(wn)g(isolated)h(namespace,) -224 1666 y(with)21 b(visibilit)o(y)i(of)d(bindings)i(con)o(trolled)f(b) -o(y)f(mo)q(dule)i(descriptions)f(written)g(in)g(a)224 -1723 y(sp)q(ecial)c Ff(c)n(on\014gur)n(ation)f(language.)295 -1779 y Fh(A)i(mo)q(dule)h(ma)o(y)e(b)q(e)i(instan)o(tiated)f(m)o -(ultiple)i(times,)e(pro)q(ducing)h(sev)o(eral)f Ff(p)n(ack-)224 -1836 y(ages)p Fh(,)c(just)f(as)h(a)f(lam)o(b)q(da-expression)j(can)e(b) -q(e)g(instan)o(tiated)g(m)o(ultiple)i(times)e(to)g(pro-)224 -1892 y(duce)20 b(sev)o(eral)e(di\013eren)o(t)h(pro)q(cedures.)31 -b(Since)21 b(single)f(instan)o(tiation)f(is)g(the)g(normal)224 -1949 y(case,)12 b(I)g(will)h(defer)f(discussion)h(of)e(m)o(ultiple)j -(instan)o(tiation)e(un)o(til)g(a)f(later)h(section.)19 -b(F)l(or)224 2005 y(no)o(w)c(y)o(ou)h(can)g(think)g(of)g(a)f(pac)o(k)m -(age)h(as)f(simply)j(a)d(mo)q(dule's)i(in)o(ternal)f(en)o(vironmen)o(t) -224 2061 y(mapping)g(names)f(to)g(denotations.)295 2118 -y(A)d(mo)q(dule)h(exp)q(orts)f(bindings)i(b)o(y)e(pro)o(viding)h(views) -g(on)o(to)e(the)h(underlying)i(pac)o(k-)224 2174 y(age.)19 -b(Suc)o(h)13 b(a)f(view)h(is)h(called)g(a)e Ff(structur)n(e)h -Fh(\(terminology)f(from)g(Standard)h(ML\).)f(One)224 -2231 y(mo)q(dule)17 b(ma)o(y)f(pro)o(vide)g(sev)o(eral)g(di\013eren)o -(t)g(views.)23 b(A)16 b(structure)g(is)g(just)g(a)g(subset)g(of)224 -2287 y(the)22 b(pac)o(k)m(age's)f(bindings.)40 b(The)22 -b(particular)g(set)f(of)g(names)g(whose)h(bindings)h(are)224 -2344 y(exp)q(orted)16 b(is)f(the)h(structure's)e Ff(interfac)n(e)p -Fh(.)295 2400 y(A)21 b(mo)q(dule)h(imp)q(orts)g(bindings)h(from)d -(other)h(mo)q(dules)i(b)o(y)e(either)h Ff(op)n(ening)e -Fh(or)224 2457 y Ff(ac)n(c)n(essing)9 b Fh(some)h(structures)h(that)f -(are)g(built)i(on)f(other)f(pac)o(k)m(ages.)18 b(When)11 -b(a)g(structure)960 2581 y(1)p eop -%%Page: 2 2 -2 1 bop 224 311 a Fh(is)11 b(op)q(ened,)h(all)f(of)f(its)g(exp)q(orted) -h(bindings)h(are)e(visible)i(in)g(the)e(clien)o(t)h(pac)o(k)m(age.)19 -b(On)10 b(the)224 368 y(other)15 b(hand,)h(bindings)i(from)d(an)g -(accessed)h(structure)g(require)g(explicitly)j(quali\014ed)224 -424 y(references)d(written)f(with)h(the)f Fe(structure-ref)e -Fh(op)q(erator.)295 481 y(F)l(or)h(example:)320 557 y -Fe(\(define-structure)21 b(foo)j(\(export)f(a)g(c)h(cons\))367 -613 y(\(open)g(scheme\))367 670 y(\(begin)f(\(define)g(a)h(1\))534 -726 y(\(define)f(\(b)h(x\))f(\(+)h(a)g(x\)\))534 782 -y(\(define)f(\(c)h(y\))f(\(*)h(\(b)g(a\))f(y\)\)\)\))320 -878 y(\(define-structure)e(bar)j(\(export)f(d\))367 935 -y(\(open)h(scheme)f(foo\))367 991 y(\(begin)g(\(define)g(\(d)h(w\))f -(\(+)h(a)g(\(c)f(w\)\)\)\)\))224 1067 y Fh(This)d(con\014guration)f -(de\014nes)h(t)o(w)o(o)d(structures,)i Fe(foo)f Fh(and)i -Fe(bar)p Fh(.)30 b Fe(foo)18 b Fh(is)i(a)e(view)i(on)224 -1123 y(a)c(pac)o(k)m(age)h(in)g(whic)o(h)h(the)f Fe(scheme)e -Fh(structure's)h(bindings)j(\(including)g Fe(define)c -Fh(and)224 1180 y Fe(+)p Fh(\))21 b(are)g(visible,)j(together)c(with)i -(bindings)h(for)d Fe(a)p Fh(,)i Fe(b)p Fh(,)h(and)e Fe(c)p -Fh(.)37 b Fe(foo)p Fh('s)21 b(in)o(terface)g(is)224 1236 -y Fe(\(export)i(a)h(c)g(cons\))p Fh(,)13 b(so)i(of)f(the)h(bindings)i -(in)f(its)f(underlying)i(pac)o(k)m(age,)d Fe(foo)h Fh(only)224 -1293 y(exp)q(orts)20 b(those)f(three.)33 b(Similarly)l(,)23 -b(structure)c Fe(bar)g Fh(consists)h(of)f(the)h(binding)i(of)d -Fe(d)224 1349 y Fh(from)13 b(a)f(pac)o(k)m(age)i(in)f(whic)o(h)h(b)q -(oth)g Fe(scheme)p Fh('s)e(and)h Fe(foo)p Fh('s)f(bindings)j(are)e -(visible.)21 b Fe(foo)p Fh('s)224 1406 y(binding)13 b(of)d -Fe(cons)g Fh(is)h(imp)q(orted)h(from)e(the)h(Sc)o(heme)g(structure)f -(and)h(then)g(re-exp)q(orted.)295 1462 y(A)22 b(mo)q(dule's)g(b)q(o)q -(dy)l(,)i(the)e(part)f(follo)o(wing)h Fe(begin)f Fh(in)i(the)f(ab)q(o)o -(v)o(e)f(example,)j(is)224 1519 y(ev)m(aluated)c(in)g(an)f(isolated)h -(lexical)h(scop)q(e)e(completely)h(sp)q(eci\014ed)i(b)o(y)c(the)i(pac)o -(k)m(age)224 1575 y(de\014nition's)d Fe(open)d Fh(and)i -Fe(access)e Fh(clauses.)21 b(In)16 b(particular,)g(the)f(binding)i(of)e -(the)g(syn-)224 1631 y(tactic)h(op)q(erator)e Fe(define-structure)f -Fh(is)j(not)f(visible)i(unless)g(it)e(comes)g(from)g(some)224 -1688 y(op)q(ened)i(structure.)j(Similarly)l(,)d(bindings)g(from)e(the)h -Fe(scheme)e Fh(structure)h(aren't)g(vis-)224 1744 y(ible)22 -b(unless)g(they)f(b)q(ecome)g(so)f(b)o(y)h Fe(scheme)f -Fh(\(or)f(an)i(equiv)m(alen)o(t)h(structure\))e(b)q(eing)224 -1801 y(op)q(ened.)224 1919 y Fg(The)f(con\014guration)f(language)224 -2005 y Fh(The)e(con\014guration)g(language)f(consists)h(of)f(top-lev)o -(el)i(de\014ning)g(forms)e(for)f(mo)q(dules)224 2061 -y(and)i(in)o(terfaces.)k(Its)15 b(syn)o(tax)f(is)i(giv)o(en)g(in)g -(\014gure)f(1.)295 2118 y(A)c Fe(define-structure)d Fh(form)i(in)o(tro) -q(duces)i(a)e(binding)j(of)d(a)h(name)g(to)f(a)g(structure.)224 -2174 y(A)i(structure)g(is)h(a)f(view)g(on)g(an)h(underlying)h(pac)o(k)m -(age)e(whic)o(h)h(is)f(created)h(according)f(to)224 2231 -y(the)i(clauses)h(of)f(the)g Fe(define-structure)e Fh(form.)19 -b(Eac)o(h)14 b(structure)g(has)g(an)g(in)o(terface)224 -2287 y(that)j(sp)q(eci\014es)j(whic)o(h)e(bindings)i(in)f(the)e -(structure's)h(underlying)h(pac)o(k)m(age)f(can)g(b)q(e)224 -2344 y(seen)e(via)f(that)g(structure)g(in)h(other)f(pac)o(k)m(ages.)295 -2400 y(An)c Fe(open)g Fh(clause)i(sp)q(eci\014es)g(whic)o(h)f -(structures)f(will)i(b)q(e)g(op)q(ened)f(up)g(for)f(use)h(inside)224 -2457 y(the)18 b(new)f(pac)o(k)m(age.)26 b(A)o(t)17 b(least)g(one)h(pac) -o(k)m(age)f(m)o(ust)g(b)q(e)h(sp)q(eci\014ed)h(or)e(else)h(it)g(will)h -(b)q(e)960 2581 y(2)p eop -%%Page: 3 3 -3 2 bop 224 355 a Fd(h)p Fh(con\014guration)p Fd(i)15 -b(\000)-7 b(!)15 b(h)p Fh(de\014nition)p Fd(i)845 339 -y Fc(\003)224 411 y Fd(h)p Fh(de\014nition)p Fd(i)i(\000)-8 -b(!)31 b Fe(\(define-structure)22 b Fd(h)p Fh(name)p -Fd(i)h(h)p Fh(in)o(terface)p Fd(i)g(h)p Fh(clause)p Fd(i)1543 -395 y Fc(\003)1562 411 y Fe(\))522 468 y Fd(j)30 b Fe -(\(define-structures)21 b(\(\()p Fd(h)p Fh(name)p Fd(i)i(h)p -Fh(in)o(terface)p Fd(i)p Fe(\))1460 451 y Fc(\003)1480 -468 y Fe(\))g Fd(h)p Fh(clause)p Fd(i)1682 451 y Fc(\003)1701 -468 y Fe(\))522 524 y Fd(j)30 b Fe(\(define-interface)22 -b Fd(h)p Fh(name)p Fd(i)h(h)p Fh(in)o(terface)p Fd(i)p -Fe(\))522 581 y Fd(j)30 b Fe(\(define-syntax)22 b Fd(h)p -Fh(name)p Fd(i)h(h)p Fh(transformer-sp)q(ec)p Fd(i)o -Fe(\))224 637 y Fd(h)p Fh(clause)p Fd(i)16 b(\000)-8 -b(!)31 b Fe(\(open)23 b Fd(h)p Fh(name)p Fd(i)782 621 -y Fc(\003)801 637 y Fe(\))454 694 y Fd(j)30 b Fe(\(access)23 -b Fd(h)p Fh(name)p Fd(i)829 677 y Fc(\003)849 694 y Fe(\))454 -750 y Fd(j)30 b Fe(\(begin)23 b Fd(h)p Fh(program)p Fd(i)n -Fe(\))454 807 y Fd(j)30 b Fe(\(files)23 b Fd(h)p Fh(\014lesp)q(ec)p -Fd(i)842 790 y Fc(\003)862 807 y Fe(\))454 863 y Fd(j)30 -b Fe(\(optimize)23 b Fd(h)p Fh(optimize-sp)q(ec)p Fd(i)1040 -847 y Fc(\003)1060 863 y Fe(\))454 920 y Fd(j)30 b Fe(\(for-syntax)23 -b Fd(h)p Fh(clause)p Fd(i)938 903 y Fc(\003)958 920 y -Fe(\))224 976 y Fd(h)p Fh(in)o(terface)p Fd(i)15 b(\000)-7 -b(!)31 b Fe(\(export)22 b Fd(h)p Fh(item)p Fd(i)862 960 -y Fc(\003)882 976 y Fe(\))505 1032 y Fd(j)30 b(h)p Fh(name)p -Fd(i)505 1089 y(j)g Fe(\(compound-interface)21 b Fd(h)p -Fh(in)o(terface)p Fd(i)1229 1072 y Fc(\003)1249 1089 -y Fe(\))224 1145 y Fd(h)p Fh(item)p Fd(i)15 b(\000)-7 -b(!)31 b(h)p Fh(name)p Fd(i)e(j)h Fe(\()p Fd(h)p Fh(name)p -Fd(i)23 b(h)p Fh(t)o(yp)q(e)p Fd(i)p Fe(\))h Fd(j)47 -b Fe(\(\()p Fd(h)p Fh(name)p Fd(i)1290 1129 y Fc(\003)1310 -1145 y Fe(\))24 b Fd(h)p Fh(t)o(yp)q(e)p Fd(i)o Fe(\))594 -1293 y Fh(Figure)15 b(1:)20 b(The)15 b(con\014guration)h(language.)224 -1428 y(imp)q(ossible)k(to)e(write)g(an)o(y)f(useful)j(programs)c -(inside)k(the)e(pac)o(k)m(age,)h(since)g Fe(define)p -Fh(,)224 1485 y Fe(lambda)p Fh(,)12 b Fe(cons)p Fh(,)h -Fe(structure-ref)p Fh(,)e(etc.)h(will)j(b)q(e)e(una)o(v)m(ailable.)22 -b(T)o(ypical)13 b(pac)o(k)m(ages)g(to)224 1541 y(list)h(in)g(the)f -Fe(open)f Fh(clause)i(are)e Fe(scheme)p Fh(,)g(whic)o(h)i(exp)q(orts)f -(all)h(bindings)g(appropriate)f(to)224 1598 y(Revised)376 -1581 y Fb(5)413 1598 y Fh(Sc)o(heme,)i(and)g Fe(structure-refs)p -Fh(,)e(whic)o(h)j(exp)q(orts)f(the)g Fe(structure-ref)224 -1654 y Fh(op)q(erator)h(\(see)g(b)q(elo)o(w\).)25 b(F)l(or)16 -b(building)j(structures)d(that)g(exp)q(ort)g(structures,)g(there)224 -1711 y(is)22 b(a)e Fe(defpackage)g Fh(pac)o(k)m(age)h(that)f(exp)q -(orts)h(the)g(op)q(erators)f(of)g(the)h(con\014guration)224 -1767 y(language.)29 b(Man)o(y)17 b(other)g(structures,)h(suc)o(h)h(as)e -(record)h(and)g(hash)g(table)h(facilities,)224 1823 y(are)c(also)g(a)o -(v)m(ailable)i(in)f(the)f(Sc)o(heme)h(48)f(implemen)o(tation.)295 -1880 y(An)e Fe(access)f Fh(clause)i(sp)q(eci\014es)h(whic)o(h)f -(bindings)h(of)e(names)g(to)f(structures)h(will)i(b)q(e)224 -1936 y(visible)e(inside)f(the)e(pac)o(k)m(age)h(b)q(o)q(dy)g(for)e(use) -i(in)g Fe(structure-ref)d Fh(forms.)18 b Fe(structure-)224 -1993 y(ref)d Fh(has)g(the)g(follo)o(wing)h(syn)o(tax:)315 -2084 y Fd(h)p Fh(expression)p Fd(i)f(\000)-7 b(!)31 b -Fe(\(structure-ref)22 b Fd(h)p Fh(struct-name)p Fd(i)h(h)p -Fh(name)p Fd(i)o Fe(\))224 2174 y Fh(The)14 b Fd(h)p -Fh(struct-name)p Fd(i)f Fh(m)o(ust)g(b)q(e)h(the)g(name)f(of)g(an)h -Fe(access)p Fh(ed)f(structure,)g(and)h Fd(h)p Fh(name)p -Fd(i)224 2231 y Fh(m)o(ust)20 b(b)q(e)i(something)f(that)f(the)h -(structure)f(exp)q(orts.)36 b(Only)22 b(structures)f(listed)h(in)224 -2287 y(an)17 b Fe(access)f Fh(clause)i(are)e(v)m(alid)j(in)f(a)e -Fe(structure-ref)p Fh(.)23 b(If)17 b(a)g(pac)o(k)m(age)g(accesses)g(an) -o(y)224 2344 y(structures,)g(it)g(should)h(probably)g(op)q(en)g(the)f -Fe(structure-refs)e Fh(structure)i(so)f(that)224 2400 -y(the)f Fe(structure-ref)f Fh(op)q(erator)g(itself)i(will)h(b)q(e)f(a)o -(v)m(ailable.)295 2457 y(The)g(pac)o(k)m(age's)g(b)q(o)q(dy)h(is)g(sp)q -(eci\014ed)i(b)o(y)d Fe(begin)g Fh(and/or)f Fe(files)h -Fh(clauses.)24 b Fe(begin)960 2581 y Fh(3)p eop -%%Page: 4 4 -4 3 bop 224 311 a Fh(and)15 b Fe(files)e Fh(ha)o(v)o(e)h(the)g(same)g -(seman)o(tics,)h(except)f(that)g(for)g Fe(begin)f Fh(the)h(text)g(is)h -(giv)o(en)224 368 y(directly)j(in)g(the)f(pac)o(k)m(age)g -(de\014nition,)i(while)g(for)d Fe(files)g Fh(the)h(text)g(is)g(stored)g -(some-)224 424 y(where)k(in)h(the)g(\014le)g(system.)37 -b(The)21 b(b)q(o)q(dy)h(consists)f(of)g(a)f(Sc)o(heme)i(program,)f -(that)224 481 y(is,)g(a)e(sequence)i(of)e(de\014nitions)i(and)e -(expressions)i(to)e(b)q(e)h(ev)m(aluated)g(in)g(order.)33 -b(In)224 537 y(practice,)14 b(I)h(alw)o(a)o(ys)e(use)h -Fe(files)f Fh(in)h(preference)h(to)e Fe(begin)p Fh(;)g -Fe(begin)g Fh(exists)h(mainly)h(for)224 594 y(exp)q(ository)g(purp)q -(oses.)295 650 y(A)g(name's)g(imp)q(orted)g(binding)j(ma)o(y)c(b)q(e)i -(lexically)i(o)o(v)o(erridden)d(or)g Ff(shadowe)n(d)h -Fh(b)o(y)224 707 y(simply)h(de\014ning)g(the)e(name)h(using)g(a)f -(de\014ning)i(form)d(suc)o(h)i(as)f Fe(define)g Fh(or)g -Fe(define-)224 763 y(syntax)p Fh(.)30 b(This)20 b(will)g(create)f(a)f -(new)i(binding)g(without)f(ha)o(ving)g(an)o(y)g(e\013ect)g(on)f(the)224 -819 y(binding)25 b(in)e(the)g(op)q(ened)h(pac)o(k)m(age.)43 -b(F)l(or)22 b(example,)j(one)e(can)f(do)h Fe(\(define)g(car)224 -876 y('chevy\))13 b Fh(without)h(a\013ecting)g(the)g(binding)h(of)f -(the)g(name)g Fe(car)f Fh(in)i(the)f Fe(scheme)e Fh(pac)o(k-)224 -932 y(age.)295 989 y(Assignmen)o(ts)17 b(\(using)h Fe(set!)p -Fh(\))e(to)h(imp)q(orted)h(and)f(unde\014ned)i(v)m(ariables)g(are)e -(not)224 1045 y(allo)o(w)o(ed.)22 b(In)17 b(order)f(to)f -Fe(set!)g Fh(a)h(top-lev)o(el)h(v)m(ariable,)g(the)f(pac)o(k)m(age)f(b) -q(o)q(dy)i(m)o(ust)e(con-)224 1102 y(tain)20 b(a)g Fe(define)f -Fh(form)g(de\014ning)i(that)e(v)m(ariable.)35 b(Applied)22 -b(to)e(bindings)h(from)e(the)224 1158 y Fe(scheme)12 -b Fh(structure,)h(this)g(restriction)g(is)h(compatible)g(with)f(the)g -(requiremen)o(ts)g(of)f(the)224 1215 y(Revised)376 1198 -y Fb(5)413 1215 y Fh(Sc)o(heme)k(rep)q(ort.)295 1271 -y(It)k(is)i(an)e(error)g(for)g(t)o(w)o(o)f(of)i(a)f(pac)o(k)m(age's)g -(op)q(ened)i(structures)e(to)g(exp)q(ort)h(t)o(w)o(o)224 -1328 y(di\013eren)o(t)14 b(bindings)i(for)e(the)g(same)g(name.)19 -b(Ho)o(w)o(ev)o(er,)13 b(the)h(curren)o(t)g(implemen)o(tation)224 -1384 y(do)q(es)h(not)f(c)o(hec)o(k)g(for)g(this)h(situation;)f(a)g -(name's)g(binding)j(is)d(alw)o(a)o(ys)g(tak)o(en)g(from)f(the)224 -1440 y(structure)18 b(that)g(is)h(listed)g(\014rst)f(within)h(the)g -Fe(open)e Fh(clause.)30 b(This)19 b(ma)o(y)f(b)q(e)h(\014xed)g(in)224 -1497 y(the)c(future.)295 1553 y(File)i(names)e(in)i(a)f -Fe(files)f Fh(clause)i(can)f(b)q(e)g(sym)o(b)q(ols,)g(strings,)g(or)f -(lists)i(\(Maclisp-)224 1610 y(st)o(yle)g(\\namelists"\).)24 -b(A)16 b(\\)p Fe(.scm)p Fh(")g(\014le)h(t)o(yp)q(e)g(su\016x)g(is)g -(assumed.)24 b(Sym)o(b)q(ols)17 b(are)f(con-)224 1666 -y(v)o(erted)f(to)e(\014le)j(names)e(b)o(y)h(con)o(v)o(erting)f(to)g -(upp)q(er)i(or)e(lo)o(w)o(er)g(case)g(as)h(appropriate)f(for)224 -1723 y(the)19 b(host)f(op)q(erating)h(system.)29 b(A)19 -b(namelist)h(is)f(an)f(op)q(erating-system-indep)q(eden)o(t)224 -1779 y(w)o(a)o(y)11 b(to)f(sp)q(ecify)j(a)e(\014le)i(obtained)f(from)f -(a)g(sub)q(directory)l(.)20 b(F)l(or)10 b(example,)j(the)f(namelist)224 -1836 y Fe(\(rts)23 b(record\))15 b Fh(sp)q(eci\014es)i(the)e(\014le)h -Fe(record.scm)e Fh(in)i(the)f Fe(rts)g Fh(sub)q(directory)l(.)295 -1892 y(If)i(the)g Fe(define-structure)d Fh(form)i(w)o(as)g(itself)i -(obtained)g(from)e(a)g(\014le,)i(then)f(\014le)224 1949 -y(names)c(in)g Fe(files)f Fh(clauses)i(are)f(in)o(terpreted)g(relativ)o -(e)g(to)f(the)h(directory)g(in)h(whic)o(h)f(the)224 2005 -y(\014le)h(con)o(taining)g(the)f Fe(define-structure)e -Fh(form)h(w)o(as)g(found.)20 b(Y)l(ou)13 b(can't)f(at)g(presen)o(t)224 -2061 y(put)j(an)h(absolute)f(path)g(name)g(in)h(the)g -Fe(files)e Fh(list.)224 2183 y Fg(In)n(terfaces)224 2269 -y Fh(An)i(in)o(terface)f(can)h(b)q(e)g(though)o(t)f(of)g(as)g(the)g(t)o -(yp)q(e)g(of)g(a)g(structure.)21 b(In)16 b(its)f(basic)h(form)224 -2325 y(it)g(is)f(just)g(a)g(list)h(of)f(v)m(ariable)i(names,)e(written) -g Fe(\(export)23 b Ff(name)h Fa(:)8 b(:)g(:)n Fe(\))p -Fh(.)20 b(Ho)o(w)o(ev)o(er,)14 b(in)224 2382 y(place)i(of)f(a)h(name)f -(one)g(ma)o(y)g(write)h Fe(\()p Ff(name)23 b(typ)n(e)p -Fe(\))p Fh(,)15 b(indicating)i(the)f(t)o(yp)q(e)f(of)g -Ff(name)p Fh('s)224 2438 y(binding.)31 b(Curren)o(tly)18 -b(the)g(t)o(yp)q(e)h(\014eld)g(is)g(ignored,)g(except)f(that)g(exp)q -(orted)g(macros)960 2581 y(4)p eop -%%Page: 5 5 -5 4 bop 224 311 a Fh(m)o(ust)15 b(b)q(e)h(indicated)h(with)e(t)o(yp)q -(e)g Fe(:syntax)p Fh(.)295 368 y(In)o(terfaces)g(ma)o(y)f(b)q(e)i -(either)g(anon)o(ymous,)e(as)h(in)h(the)f(example)h(in)g(the)g(in)o -(tro)q(duc-)224 424 y(tion,)d(or)e(they)h(ma)o(y)f(b)q(e)i(giv)o(en)f -(names)g(b)o(y)g(a)f Fe(define-interface)f Fh(form,)h(for)h(example)320 -518 y Fe(\(define-interface)21 b(foo-interface)h(\(export)h(a)h(c)g -(cons\)\))320 575 y(\(define-structure)d(foo)j(foo-interface)e -Fa(:)8 b(:)g(:)n Fe(\))224 668 y Fh(In)k(principle,)i(in)o(terfaces)d -(needn't)h(ev)o(er)f(b)q(e)g(named.)19 b(If)11 b(an)g(in)o(terface)h -(had)f(to)f(b)q(e)i(giv)o(en)224 725 y(at)17 b(the)g(p)q(oin)o(t)h(of)e -(a)h(structure's)g(use)g(as)g(w)o(ell)h(as)f(at)f(the)h(p)q(oin)o(t)h -(of)f(its)g(de\014nition,)i(it)224 781 y(w)o(ould)h(b)q(e)h(imp)q -(ortan)o(t)e(to)g(name)h(in)o(terfaces)g(in)h(order)e(to)h(a)o(v)o(oid) -f(ha)o(ving)h(to)f(write)224 838 y(them)13 b(out)f(t)o(wice,)h(with)g -(risk)g(of)g(mismatc)o(h)f(should)i(the)f(in)o(terface)g(ev)o(er)f(c)o -(hange.)19 b(But)224 894 y(they)c(don't.)295 951 y(Still,)h(there)g -(are)e(sev)o(eral)i(reasons)f(to)f(use)i Fe(define-interface)p -Fh(:)280 1044 y(1.)22 b(It)c(is)h(imp)q(ortan)o(t)f(to)g(separate)f -(the)i(in)o(terface)f(de\014nition)j(from)c(the)i(pac)o(k)m(age)338 -1101 y(de\014nitions)h(when)f(there)f(are)g(m)o(ultiple)i(distinct)g -(structures)e(that)f(ha)o(v)o(e)h(the)338 1157 y(same)g(in)o(terface)h -(|)h(that)e(is,)i(m)o(ultiple)g(implemen)o(tations)h(of)d(the)h(same)f -(ab-)338 1214 y(straction.)280 1308 y(2.)k(It)17 b(is)g(conceptually)h -(cleaner,)g(and)f(useful)h(for)e(do)q(cumen)o(tation)h(purp)q(oses,)g -(to)338 1364 y(separate)f(a)h(mo)q(dule's)h(sp)q(eci\014cation)h(\(in)o -(terface\))e(from)f(its)h(implemen)o(tation)338 1421 -y(\(pac)o(k)m(age\).)280 1514 y(3.)22 b(My)15 b(exp)q(erience)i(is)e -(that)g(con\014gurations)g(that)f(are)h(separated)g(in)o(to)g(in)o -(terface)338 1571 y(de\014nitions)i(and)f(pac)o(k)m(age)f -(de\014nitions)j(are)d(easier)h(to)f(read;)g(the)h(long)g(lists)g(of) -338 1627 y(exp)q(orted)f(bindings)i(just)e(get)g(in)h(the)f(w)o(a)o(y)g -(most)f(of)h(the)g(time.)295 1721 y(The)g Fe(compound-interface)d -Fh(op)q(erator)i(forms)g(an)g(in)o(terface)h(that)f(is)i(the)e(union) -224 1778 y(of)h(t)o(w)o(o)f(or)g(more)h(comp)q(onen)o(t)h(in)o -(terfaces.)k(F)l(or)14 b(example,)320 1871 y Fe(\(define-interface)21 -b(bar-interface)367 1928 y(\(compound-interface)h(foo-interface)g -(\(export)h(mumble\)\)\))224 2022 y Fh(de\014nes)15 b -Fe(bar-interface)c Fh(to)i(b)q(e)h Fe(foo-interface)e -Fh(with)i(the)f(name)h Fe(mumble)e Fh(added.)224 2143 -y Fg(Macros)224 2229 y Fh(Hygienic)20 b(macros,)e(as)g(describ)q(ed)i -(in)f([1)o(,)f(2],)g(are)g(implemen)o(ted.)31 b(Structures)18 -b(ma)o(y)224 2286 y(exp)q(ort)e(macros;)g(auxiliary)i(names)e(in)o(tro) -q(duced)h(in)o(to)g(the)f(expansion)h(are)f(resolv)o(ed)224 -2342 y(in)g(the)f(en)o(vironmen)o(t)h(of)f(the)g(macro's)f -(de\014nition.)295 2398 y(F)l(or)23 b(example,)k(the)d -Fe(scheme)f Fh(structure's)g Fe(delay)g Fh(macro)h(is)g(de\014ned)i(b)o -(y)d(the)224 2455 y(rewrite)15 b(rule)960 2581 y(5)p -eop -%%Page: 6 6 -6 5 bop 320 311 a Fe(\(delay)23 b Ff(exp)p Fe(\))47 b -Fh(=)-8 b Fd(\))49 b Fe(\(make-promise)23 b(\(lambda)f(\(\))i -Ff(exp)p Fe(\)\))p Fh(.)224 405 y(The)16 b(v)m(ariable)g -Fe(make-promise)e Fh(is)i(de\014ned)g(in)g(the)g Fe(scheme)e -Fh(structure's)h(underlying)224 462 y(pac)o(k)m(age,)j(but)g(is)g(not)f -(exp)q(orted.)28 b(A)18 b(use)g(of)f(the)h Fe(delay)f -Fh(macro,)g(ho)o(w)o(ev)o(er,)g(alw)o(a)o(ys)224 518 -y(accesses)f(the)g(correct)f(de\014nition)j(of)d Fe(make-promise)p -Fh(.)20 b(Similarly)l(,)e(the)e Fe(case)f Fh(macro)224 -575 y(expands)i(in)o(to)g(uses)g(of)f Fe(cond)p Fh(,)g -Fe(eqv?)p Fh(,)g(and)h(so)f(on.)25 b(These)17 b(names)f(are)h(exp)q -(orted)g(b)o(y)224 631 y Fe(scheme)p Fh(,)e(but)h(their)h(correct)e -(bindings)j(will)g(b)q(e)e(found)h(ev)o(en)f(if)g(they)g(are)g(shado)o -(w)o(ed)224 687 y(b)o(y)f(de\014nitions)i(in)f(the)g(clien)o(t)g(pac)o -(k)m(age.)224 809 y Fg(Higher-order)h(mo)r(dules)224 -895 y Fh(There)g(are)f Fe(define-module)e Fh(and)j Fe(define)e -Fh(forms)g(for)h(de\014ning)i(mo)q(dules)f(that)f(are)224 -951 y(in)o(tended)g(to)d(b)q(e)i(instan)o(tiated)f(m)o(ultiple)i -(times.)k(But)14 b(these)h(are)f(prett)o(y)f(kludgey)i(|)224 -1008 y(for)i(example,)h(compiled)g(co)q(de)g(isn't)f(shared)g(b)q(et)o -(w)o(een)h(the)f(instan)o(tiations)g(|)g(so)g(I)224 1064 -y(w)o(on't)d(describ)q(e)i(them)f(y)o(et.)k(If)c(y)o(ou)f(m)o(ust)g -(kno)o(w,)g(\014gure)h(it)g(out)f(from)g(the)h(follo)o(wing)224 -1121 y(grammar.)315 1215 y Fd(h)p Fh(de\014nition)p Fd(i)h(\000)-7 -b(!)31 b Fe(\(define-module)22 b(\()p Fd(h)p Fh(name)p -Fd(i)h Fe(\()p Fd(h)p Fh(name)p Fd(i)g(h)p Fh(in)o(terface)p -Fd(i)p Fe(\))1621 1198 y Fc(\003)1640 1215 y Fe(\))704 -1271 y Fd(h)p Fh(de\014nition)p Fd(i)926 1255 y Fc(\003)704 -1327 y Fd(h)p Fh(name)p Fd(i)o Fe(\))610 1384 y Fd(j)30 -b Fe(\(define)23 b Fd(h)p Fh(name)p Fd(i)g Fe(\()p Fd(h)p -Fh(name)p Fd(i)h(h)p Fh(name)p Fd(i)1340 1367 y Fc(\003)1360 -1384 y Fe(\)\))224 1506 y Fg(Compiling)17 b(and)i(linking)224 -1591 y Fh(Sc)o(heme)f(48)e(has)h(a)g(static)f(link)o(er)i(that)f(pro)q -(duces)g(stand-alone)h(heap)f(images)g(from)224 1648 -y(mo)q(dule)k(descriptions.)35 b(One)20 b(sp)q(eci\014es)i(a)d -(particular)h(pro)q(cedure)h(in)f(a)g(particular)224 -1704 y(structure)c(to)f(b)q(e)i(the)f(image's)f(startup)g(pro)q(cedure) -i(\(en)o(try)e(p)q(oin)o(t\),)h(and)g(the)g(link)o(er)224 -1761 y(traces)g(dep)q(endency)i(links)f(as)f(giv)o(en)g(b)o(y)g -Fe(open)f Fh(and)h Fe(access)f Fh(clauses)i(to)e(determine)224 -1817 y(the)g(comp)q(osition)h(of)f(the)h(heap)f(image.)295 -1874 y(There)i(is)g(not)g(curren)o(tly)g(an)o(y)g(pro)o(vision)h(for)e -(separate)g(compilation;)j(the)e(only)224 1930 y(input)j(to)f(the)g -(static)g(link)o(er)h(is)g(source)f(co)q(de.)32 b(Ho)o(w)o(ev)o(er,)19 -b(it)h(will)g(not)f(b)q(e)h(di\016cult)224 1987 y(to)15 -b(implemen)o(t)i(separate)f(compilation.)23 b(The)16 -b(unit)h(of)e(compilation)i(is)f(one)g(mo)q(dule)224 -2043 y(\(not)j(one)g(\014le\).)32 b(An)o(y)19 b(op)q(ened)h(or)f -(accessed)g(structures)g(from)g(whic)o(h)h(macros)e(are)224 -2100 y(obtained)13 b(m)o(ust)f(b)q(e)i(pro)q(cessed)f(to)f(the)h(exten) -o(t)f(of)g(extracting)g(its)h(macro)f(de\014nitions.)224 -2156 y(The)18 b(compiler)g(kno)o(ws)f(from)g(the)g(in)o(terface)h(of)f -(an)g(op)q(ened)i(or)e(accessed)h(structure)224 2212 -y(whic)o(h)24 b(of)e(its)h(exp)q(orts)f(are)g(macros.)42 -b(Except)23 b(for)f(macros,)h(a)f(mo)q(dule)i(ma)o(y)e(b)q(e)224 -2269 y(compiled)e(without)e(an)o(y)g(kno)o(wledge)h(of)e(the)i -(implemen)o(tation)g(of)f(its)g(op)q(ened)h(and)224 2325 -y(accessed)h(structures.)31 b(Ho)o(w)o(ev)o(er,)19 b(in)o(ter-mo)q -(dule)h(optimization)g(will)h(b)q(e)f(a)o(v)m(ailable)224 -2382 y(as)15 b(an)g(option.)960 2581 y(6)p eop -%%Page: 7 7 -7 6 bop 295 311 a Fh(The)17 b(main)g(di\016cult)o(y)h(with)f(separate)g -(compilation)h(is)f(resolution)h(of)e(auxiliary)224 368 -y(bindings)25 b(in)o(tro)q(duced)e(in)o(to)g(macro)f(expansions.)43 -b(The)22 b(mo)q(dule)i(compiler)g(m)o(ust)224 424 y(transmit)15 -b(to)f(the)h(loader)g(or)g(link)o(er)h(the)f(searc)o(h)f(path)h(b)o(y)g -(whic)o(h)h(suc)o(h)f(bindings)i(are)224 481 y(to)h(b)q(e)i(resolv)o -(ed.)31 b(In)19 b(the)g(case)f(of)h(the)g Fe(delay)f -Fh(macro's)f(auxiliary)j Fe(make-promise)224 537 y Fh(\(see)g(example)g -(ab)q(o)o(v)o(e\),)g(the)g(loader)g(or)f(link)o(er)i(needs)f(to)f(kno)o -(w)h(that)f(the)g(desired)224 594 y(binding)h(of)d Fe(make-promise)e -Fh(is)j(the)g(one)f(apparen)o(t)g(in)i Fe(delay)p Fh('s)d(de\014ning)j -(pac)o(k)m(age,)224 650 y(not)c(in)h(the)f(pac)o(k)m(age)g(b)q(eing)i -(loaded)f(or)f(link)o(ed.)295 707 y([I)g(need)h(to)f(describ)q(e)h -(structure)f(rei\014cation.])224 828 y Fg(Seman)n(tics)i(of)i -(con\014guration)g(m)n(utation)224 914 y Fh(During)c(program)f(dev)o -(elopmen)o(t)h(it)g(is)h(often)e(desirable)i(to)e(mak)o(e)h(c)o(hanges) -f(to)g(pac)o(k-)224 971 y(ages)k(and)h(in)o(terfaces.)31 -b(In)20 b(static)e(languages)h(it)g(ma)o(y)f(b)q(e)i(necessary)f(to)f -(recompile)224 1027 y(and)d(re-link)g(a)f(program)f(in)j(order)e(for)f -(suc)o(h)i(c)o(hanges)f(to)g(b)q(e)g(re\015ected)h(in)g(a)f(running)224 -1083 y(system.)35 b(Ev)o(en)20 b(in)i(in)o(teractiv)o(e)e(Common)g -(Lisp)h(implemen)o(tations,)i(a)d(c)o(hange)g(to)224 -1140 y(a)c(pac)o(k)m(age's)g(exp)q(orts)g(often)f(requires)i(reloading) -g(clien)o(ts)h(that)d(ha)o(v)o(e)h(already)g(men-)224 -1196 y(tioned)i(names)f(whose)g(bindings)i(c)o(hange.)25 -b(Once)18 b Fe(read)f Fh(resolv)o(es)g(a)g(use)g(of)g(a)f(name)224 -1253 y(to)i(a)g(sym)o(b)q(ol,)g(that)g(resolution)h(is)g(\014xed,)g(so) -f(a)f(c)o(hange)i(in)g(the)f(w)o(a)o(y)f(that)h(a)f(name)224 -1309 y(resolv)o(es)e(to)f(a)g(sym)o(b)q(ol)h(can)f(only)h(b)q(e)h -(re\015ected)f(b)o(y)f(re-)p Fe(read)p Fh(ing)h(all)g(suc)o(h)g -(references.)295 1366 y(The)g(Sc)o(heme)h(48)e(dev)o(elopmen)o(t)i(en)o -(vironmen)o(t)f(supp)q(orts)g(rapid)h(turnaround)f(in)224 -1422 y(mo)q(dular)j(program)f(dev)o(elopmen)o(t)i(b)o(y)e(allo)o(wing)i -(m)o(utations)e(to)g(a)h(program's)e(con-)224 1479 y(\014guration,)f -(and)g(giving)g(a)g(clear)g(seman)o(tics)g(to)f(suc)o(h)h(m)o -(utations.)k(The)c(rule)h(is)f(that)224 1535 y(v)m(ariable)23 -b(bindings)f(in)g(a)f(running)h(program)e(are)h(alw)o(a)o(ys)f(resolv)o -(ed)i(according)f(to)224 1592 y(curren)o(t)c(structure)g(and)g(in)o -(terface)h(bindings,)h(ev)o(en)e(when)h(these)f(bindings)i(c)o(hange) -224 1648 y(as)12 b(a)g(result)h(of)f(edits)h(to)f(the)h -(con\014guration.)19 b(F)l(or)12 b(example,)h(consider)h(the)e(follo)o -(wing:)320 1742 y Fe(\(define-interface)21 b(foo-interface)h(\(export)h -(a)h(c\)\))320 1798 y(\(define-structure)d(foo)j(foo-interface)367 -1855 y(\(open)g(scheme\))367 1911 y(\(begin)f(\(define)g(a)h(1\))534 -1968 y(\(define)f(\(b)h(x\))f(\(+)h(a)g(x\)\))534 2024 -y(\(define)f(\(c)h(y\))f(\(*)h(\(b)g(a\))f(y\)\)\)\))320 -2081 y(\(define-structure)e(bar)j(\(export)f(d\))367 -2137 y(\(open)h(scheme)f(foo\))367 2193 y(\(begin)g(\(define)g(\(d)h -(w\))f(\(+)h(\(b)g(w\))f(a\)\)\)\))224 2287 y Fh(This)18 -b(program)e(has)i(a)f(bug.)26 b(The)18 b(v)m(ariable)g -Fe(b)p Fh(,)g(whic)o(h)g(is)g(free)f(in)h(the)g(de\014nition)h(of)224 -2344 y Fe(d)p Fh(,)i(has)f(no)g(binding)i(in)f Fe(bar)p -Fh('s)e(pac)o(k)m(age.)35 b(Supp)q(ose)21 b(that)f Fe(b)g -Fh(w)o(as)f(supp)q(osed)i(to)f(b)q(e)224 2400 y(exp)q(orted)f(b)o(y)f -Fe(foo)p Fh(,)h(but)f(w)o(as)g(omitted)g(from)g Fe(foo-interface)e -Fh(b)o(y)i(mistak)o(e.)30 b(It)18 b(is)224 2457 y(not)f(necessary)h(to) -e(re-pro)q(cess)i Fe(bar)f Fh(or)g(an)o(y)g(of)g Fe(foo)p -Fh('s)f(other)h(clien)o(ts)i(at)e(this)g(p)q(oin)o(t.)960 -2581 y(7)p eop -%%Page: 8 8 -8 7 bop 224 311 a Fh(One)17 b(need)f(only)h(c)o(hange)f -Fe(foo-interface)e Fh(and)i(inform)g(the)f(dev)o(elopmen)o(t)i(system) -224 368 y(of)d(that)g(one)h(c)o(hange)f(\(using,)h(sa)o(y)l(,)f(an)g -(appropriate)h(Emacs)f(command\),)g(and)g Fe(foo)p Fh('s)224 -424 y(binding)j(of)e Fe(b)g Fh(will)i(b)q(e)f(found)f(when)h(pro)q -(cedure)g Fe(d)f Fh(is)h(called.)295 481 y(Similarly)l(,)e(it)e(is)f -(also)h(p)q(ossible)h(to)e(replace)h(a)f(structure;)h(clien)o(ts)h(of)e -(the)h(old)g(struc-)224 537 y(ture)g(will)i(b)q(e)e(mo)q(di\014ed)h(so) -f(that)f(they)h(see)g(bindings)i(from)d(the)h(new)g(one.)19 -b(Shado)o(wing)224 594 y(is)e(also)g(supp)q(orted)g(in)h(the)f(same)f -(w)o(a)o(y)l(.)24 b(Supp)q(ose)17 b(that)f(a)h(clien)o(t)h(pac)o(k)m -(age)f Fa(C)i Fh(op)q(ens)224 650 y(a)f(structure)f Fe(foo)h -Fh(that)f(exp)q(orts)g(a)h(name)f Fe(x)p Fh(,)h(and)g -Fe(foo)p Fh('s)f(implemen)o(tation)i(obtains)224 707 -y(the)d(binding)i(of)e Fe(x)f Fh(as)h(an)g(imp)q(ort)g(from)f(some)h -(other)f(structure)h Fe(bar)p Fh(.)22 b(Then)16 b Fa(C)j -Fh(will)224 763 y(see)f(the)g(binding)i(from)d Fe(bar)p -Fh(.)28 b(If)18 b(one)g(then)g(alters)g Fe(foo)f Fh(so)h(that)f(it)h -(shado)o(ws)f Fe(bar)p Fh('s)224 819 y(binding)e(of)d -Fe(x)g Fh(with)h(a)f(de\014nition)i(of)e(its)h(o)o(wn,)f(then)h(pro)q -(cedures)g(in)h Fa(C)h Fh(that)d(reference)224 876 y -Fe(x)19 b Fh(will)h(automatically)f(see)g Fe(foo)p Fh('s)f -(de\014nition)j(instead)e(of)f(the)h(one)g(from)f Fe(bar)g -Fh(that)224 932 y(they)d(sa)o(w)g(earlier.)295 989 y(This)c(seman)o -(tics)f(migh)o(t)g(app)q(ear)g(to)g(require)h(a)f(large)g(amoun)o(t)g -(of)f(computation)i(on)224 1045 y(ev)o(ery)j(v)m(ariable)i(reference:)k -(The)14 b(sp)q(eci\014ed)i(b)q(eha)o(vior)f(requires)f(scanning)h(the)f -(pac)o(k-)224 1102 y(age's)g(list)h(of)f(op)q(ened)i(structures,)e -(examining)i(their)f(in)o(terfaces,)f(on)h(ev)o(ery)f(v)m(ariable)224 -1158 y(reference,)h(not)f(just)g(at)f(compile)j(time.)k(Ho)o(w)o(ev)o -(er,)13 b(the)h(dev)o(elopmen)o(t)h(en)o(vironmen)o(t)224 -1215 y(uses)h(cac)o(hing)g(with)f(cac)o(he)h(in)o(v)m(alidation)h(to)e -(mak)o(e)f(v)m(ariable)j(references)f(fast.)224 1336 -y Fg(Command)h(pro)r(cessor)h(supp)r(ort)224 1422 y Fh(While)f(it)e(is) -g(p)q(ossible)i(to)e(use)g(the)g(Sc)o(heme)h(48)e(static)h(link)o(er)h -(for)f(program)e(dev)o(elop-)224 1479 y(men)o(t,)i(it)h(is)g(far)e -(more)h(con)o(v)o(enien)o(t)h(to)f(use)h(the)f(dev)o(elopmen)o(t)h(en)o -(vironmen)o(t,)g(whic)o(h)224 1535 y(supp)q(orts)21 b(rapid)g -(turnaround)f(for)g(program)f(c)o(hanges.)36 b(The)21 -b(programmer)e(in)o(ter-)224 1592 y(acts)13 b(with)i(the)e(dev)o -(elopmen)o(t)i(en)o(vironmen)o(t)f(through)f(a)h Ff(c)n(ommand)h(pr)n -(o)n(c)n(essor)p Fh(.)j(The)224 1648 y(command)d(pro)q(cessor)h(is)f -(lik)o(e)i(the)e(usual)i(Lisp)f(read-ev)m(al-prin)o(t)h(lo)q(op)f(in)g -(that)f(it)g(ac-)224 1704 y(cepts)k(Sc)o(heme)h(forms)e(to)g(ev)m -(aluate.)31 b(Ho)o(w)o(ev)o(er,)18 b(all)i(meta-lev)o(el)g(op)q -(erations,)f(suc)o(h)224 1761 y(as)e(exiting)h(the)f(Sc)o(heme)h -(system)f(or)g(requests)g(for)f(trace)h(output,)g(are)g(handled)i(b)o -(y)224 1817 y Ff(c)n(ommands,)f Fh(whic)o(h)h(are)e(lexically)j -(distinguished)g(from)d(Sc)o(heme)h(forms.)27 b(This)18 -b(ar-)224 1874 y(rangemen)o(t)11 b(is)h(b)q(orro)o(w)o(ed)e(from)h(the) -g(Sym)o(b)q(olics)i(Lisp)f(Mac)o(hine)g(system,)f(and)h(is)g(rem-)224 -1930 y(iniscen)o(t)19 b(of)d(non-Lisp)j(debuggers.)25 -b(Commands)17 b(are)g(a)f(little)j(easier)e(to)g(t)o(yp)q(e)g(than)224 -1987 y(Sc)o(heme)j(forms)f(\(no)g(paren)o(theses,)h(so)f(y)o(ou)g -(don't)g(ha)o(v)o(e)g(to)f(shift\),)i(but)g(more)f(im-)224 -2043 y(p)q(ortan)o(tly)l(,)14 b(making)h(them)f(distinct)h(from)f(Sc)o -(heme)h(forms)f(ensures)g(that)g(programs')224 2100 y(namespaces)f -(aren't)g(clutterred)g(with)g(inappropriate)h(bindings.)21 -b(Equiv)m(alen)o(tly)l(,)15 b(the)224 2156 y(command)h(set)h(is)g(a)o -(v)m(ailable)h(for)e(use)g(regardless)h(of)f(what)g(bindings)i(happ)q -(en)g(to)e(b)q(e)224 2213 y(visible)j(in)e(the)f(curren)o(t)g(program.) -22 b(This)16 b(is)h(esp)q(ecially)i(imp)q(ortan)o(t)c(in)i(conjunction) -224 2269 y(with)e(the)f(mo)q(dule)h(system,)e(whic)o(h)i(puts)f(strict) -g(con)o(trols)g(on)g(visibilit)o(y)i(of)e(bindings.)295 -2325 y(The)h(Sc)o(heme)h(48)e(command)h(pro)q(cessor)g(supp)q(orts)g -(the)g(mo)q(dule)i(system)d(with)i(a)224 2382 y(v)m(ariet)o(y)h(of)e -(sp)q(ecial)k(commands.)j(F)l(or)16 b(commands)g(that)g(require)h -(structure)f(names,)224 2438 y(these)h(names)f(are)g(resolv)o(ed)h(in)g -(a)f(designated)h(con\014guration)g(pac)o(k)m(age)f(that)g(is)h(dis-) -960 2581 y(8)p eop -%%Page: 9 9 -9 8 bop 224 311 a Fh(tinct)21 b(from)f(the)h(curren)o(t)f(pac)o(k)m -(age)h(for)f(ev)m(aluating)h(Sc)o(heme)h(forms)d(giv)o(en)i(to)f(the) -224 368 y(command)f(pro)q(cessor.)31 b(The)20 b(command)f(pro)q(cessor) -f(in)o(terprets)i(Sc)o(heme)f(forms)g(in)224 424 y(a)d(particular)h -(curren)o(t)f(pac)o(k)m(age,)g(and)g(there)h(are)e(commands)h(that)g -(mo)o(v)o(e)f(the)i(com-)224 481 y(mand)e(pro)q(cessor)g(b)q(et)o(w)o -(een)h(di\013eren)o(t)f(pac)o(k)m(ages.)295 537 y(Commands)h(are)h(in)o -(tro)q(duced)h(b)o(y)e(a)h(comma)f(\()p Fe(,)p Fh(\))h(and)g(end)g(at)f -(the)h(end)h(of)e(line.)224 594 y(The)f(command)f(pro)q(cessor's)f -(prompt)h(consists)h(of)f(the)g(name)g(of)g(the)g(curren)o(t)g(pac)o -(k-)224 650 y(age)h(follo)o(w)o(ed)g(b)o(y)h(a)e(greater-than)h(\()p -Fe(>)p Fh(\).)338 756 y Fe(,config)338 831 y Fh(The)e -Fe(,config)f Fh(command)h(sets)f(the)i(command)e(pro)q(cessor's)h -(curren)o(t)g(pac)o(k)m(age)338 888 y(to)j(b)q(e)h(the)g(curren)o(t)g -(con\014guration)g(pac)o(k)m(age.)25 b(F)l(orms)16 b(en)o(tered)h(at)f -(this)h(p)q(oin)o(t)338 944 y(are)22 b(in)o(terpreted)h(as)g(b)q(eing)h -(con\014guration)e(language)h(forms,)h(not)e(Sc)o(heme)338 -1001 y(forms.)338 1095 y Fe(,config)h Ff(c)n(ommand)338 -1170 y Fh(This)14 b(form)e(of)h(the)g Fe(,config)f Fh(command)h -(executes)h(another)e(command)h(in)h(the)338 1226 y(curren)o(t)h -(con\014guration)g(pac)o(k)m(age.)20 b(F)l(or)15 b(example,)433 -1320 y Fe(,config)23 b(,load)g(foo.scm)338 1414 y Fh(in)o(terprets)18 -b(con\014guration)g(language)h(forms)e(from)h(the)g(\014le)h -Fe(foo.scm)e Fh(in)i(the)338 1470 y(curren)o(t)c(con\014guration)g(pac) -o(k)m(age.)338 1564 y Fe(,in)23 b Ff(struct-name)338 -1639 y Fh(The)14 b Fe(,in)f Fh(command)g(mo)o(v)o(es)g(the)g(command)h -(pro)q(cessor)f(to)g(a)g(sp)q(eci\014ed)j(struc-)338 -1696 y(ture's)e(underlying)k(pac)o(k)m(age.)h(F)l(or)c(example:)433 -1790 y Fe(user>)23 b(,config)433 1846 y(config>)g(\(define-structure)f -(foo)h(\(export)g(a\))672 1902 y(\(open)g(scheme\)\))433 -1959 y(config>)g(,in)h(foo)433 2015 y(foo>)g(\(define)e(a)i(13\))433 -2072 y(foo>)g(a)433 2128 y(13)338 2222 y Fh(In)11 b(this)g(example)g -(the)g(command)f(pro)q(cessor)h(starts)e(in)j(a)e(pac)o(k)m(age)g -(called)i Fe(user)p Fh(,)338 2279 y(but)19 b(the)h Fe(,config)e -Fh(command)h(mo)o(v)o(es)f(it)i(in)o(to)f(the)g(con\014guration)h(pac)o -(k)m(age,)338 2335 y(whic)o(h)e(has)f(the)h(name)f Fe(config)p -Fh(.)26 b(The)17 b Fe(define-structure)e Fh(form)i(binds,)i(in)338 -2391 y Fe(config)p Fh(,)j(the)g(name)g Fe(foo)g Fh(to)f(a)h(structure)f -(that)h(exp)q(orts)f Fe(a)p Fh(.)40 b(Finally)l(,)25 -b(the)960 2581 y(9)p eop -%%Page: 10 10 -10 9 bop 338 311 a Fh(command)13 b Fe(,in)23 b(foo)13 -b Fh(mo)o(v)o(es)f(the)h(command)g(pro)q(cessor)g(in)o(to)g(structure)f -Fe(foo)p Fh('s)338 368 y(underlying)17 b(pac)o(k)m(age.)338 -443 y(A)11 b(pac)o(k)m(age's)f(b)q(o)q(dy)h(isn't)g(executed)h(\(ev)m -(aluated\))f(un)o(til)g(the)g(pac)o(k)m(age)g(is)g Ff(lo)n(ade)n(d)p -Fh(,)338 499 y(whic)o(h)16 b(is)g(accomplished)h(b)o(y)e(the)g -Fe(,load-package)e Fh(command.)338 593 y Fe(,in)23 b -Ff(struct-name)i(c)n(ommand)338 668 y Fh(This)e(form)e(of)h(the)g -Fe(,in)g Fh(command)g(executes)h(a)f(single)h(command)f(in)h(the)338 -725 y(sp)q(eci\014ed)f(pac)o(k)m(age)e(without)h(mo)o(ving)f(the)g -(command)g(pro)q(cessor)g(in)o(to)g(that)338 781 y(pac)o(k)m(age.)g -(Example:)433 875 y Fe(,in)k(mumble)f(\(cons)g(1)h(2\))433 -932 y(,in)g(mumble)f(,trace)g(foo)338 1025 y(,user)g -Fh([)p Ff(c)n(ommand)p Fh(])338 1100 y(This)d(is)h(similar)g(to)e(the)i -Fe(,config)e Fh(and)h Fe(,in)f Fh(commands.)34 b(It)20 -b(mo)o(v)o(es)g(to)f(or)338 1157 y(executes)14 b(a)f(command)g(in)h -(the)g(user)f(pac)o(k)m(age)g(\(whic)o(h)h(is)g(the)g(default)g(pac)o -(k)m(age)338 1213 y(when)h(the)h(Sc)o(heme)g(48)e(command)h(pro)q -(cessor)g(starts\).)338 1307 y Fe(,for-syntax)22 b Fh([)p -Ff(c)n(ommand)p Fh(])338 1382 y(This)e(is)h(similar)g(to)e(the)i -Fe(,config)e Fh(and)h Fe(,in)f Fh(commands.)34 b(It)20 -b(mo)o(v)o(es)g(to)f(or)338 1439 y(executes)h(a)f(command)g(in)i(the)e -(curren)o(t)h(pac)o(k)m(age's)f(\\pac)o(k)m(age)g(for)g(syn)o(tax,")338 -1495 y(whic)o(h)e(is)g(the)f(pac)o(k)m(age)g(in)h(whic)o(h)g(the)g -(forms)e Fa(f)22 b Fh(in)17 b Fe(\(define-syntax)22 b -Ff(name)338 1552 y Fa(f)5 b Fe(\))15 b Fh(are)g(ev)m(aluated.)338 -1645 y Fe(,load-package)22 b Ff(struct-name)338 1721 -y Fh(The)d Fe(,load-package)e Fh(command)h(ensures)i(that)e(the)g(sp)q -(eci\014ed)j(structure's)338 1777 y(underlying)g(pac)o(k)m(age's)d -(program)g(has)h(b)q(een)h(loaded.)32 b(This)20 b(consists)f(of)f -(\(1\))338 1834 y(recursiv)o(ely)13 b(ensuring)g(that)e(the)h(pac)o(k)m -(ages)f(of)h(an)o(y)f(op)q(ened)i(or)e(accessed)i(struc-)338 -1890 y(tures)f(are)g(loaded,)i(follo)o(w)o(ed)e(b)o(y)h(\(2\))e -(executing)j(the)e(pac)o(k)m(age's)g(b)q(o)q(dy)h(as)g(sp)q(ec-)338 -1946 y(i\014ed)j(b)o(y)f(its)h(de\014nition's)g Fe(begin)f -Fh(and)g Fe(files)g Fh(forms.)338 2040 y Fe(,reload-package)22 -b Ff(struct-name)338 2115 y Fh(This)f(command)f(re-executes)h(the)g -(structure's)f(pac)o(k)m(age's)g(program.)34 b(It)21 -b(is)338 2172 y(most)g(useful)i(if)g(the)f(program)e(comes)i(from)g(a)f -(\014le)i(or)f(\014les,)i(when)f(it)f(will)338 2228 y(up)q(date)16 -b(the)f(pac)o(k)m(age's)g(bindings)i(after)d(m)o(utations)h(to)f(its)i -(source)f(\014le.)338 2322 y Fe(,load)23 b Ff(\014lesp)n(e)n(c)f -Fa(:)8 b(:)g(:)338 2397 y Fh(The)22 b Fe(,load)f Fh(command)g(executes) -i(forms)e(from)g(the)h(sp)q(eci\014ed)i(\014le)e(or)g(\014les)338 -2454 y(in)16 b(the)g(curren)o(t)g(pac)o(k)m(age.)22 b -Fe(,load)h Ff(\014lesp)n(e)n(c)14 b Fh(is)i(similar)h(to)f -Fe(\(load)23 b(")p Ff(\014lesp)n(e)n(c)n Fe("\))949 2581 -y Fh(10)p eop -%%Page: 11 11 -11 10 bop 338 311 a Fh(except)18 b(that)e(the)h(name)h -Fe(load)e Fh(needn't)i(b)q(e)g(b)q(ound)g(in)g(the)f(curren)o(t)h(pac)o -(k)m(age)338 368 y(to)c(Sc)o(heme's)i Fe(load)e Fh(pro)q(cedure.)338 -457 y Fe(,structure)22 b Ff(name)i(interfac)n(e)338 530 -y Fh(The)15 b Fe(,structure)e Fh(command)h(de\014nes)i -Ff(name)e Fh(in)h(the)g(con\014guration)g(pac)o(k)m(age)338 -587 y(to)c(b)q(e)i(a)e(structure)h(with)g(in)o(terface)g -Ff(interfac)n(e)f Fh(based)h(on)g(the)g(curren)o(t)g(pac)o(k)m(age.)338 -676 y Fe(,open)23 b Ff(struct-name)717 660 y Fc(\003)338 -749 y Fh(The)13 b Fe(,open)g Fh(command)g(op)q(ens)h(a)f(new)h -(structure)f(in)h(the)f(curren)o(t)h(pac)o(k)m(age,)f(as)338 -806 y(if)i(the)h(pac)o(k)m(age's)e(de\014nition's)j Fe(open)e -Fh(clause)h(had)f(listed)i Ff(struct-name)p Fh(.)224 -926 y Fg(Con\014guration)i(pac)n(k)m(ages)224 1011 y -Fh(It)c(is)h(p)q(ossible)h(to)e(set)g(up)h(m)o(ultiple)h -(con\014guration)e(pac)o(k)m(ages.)20 b(The)15 b(default)h(con\014g-) -224 1068 y(uration)f(pac)o(k)m(age)h(op)q(ens)f(the)h(follo)o(wing)g -(structures:)292 1151 y Fd(\017)23 b Fe(module-system)p -Fh(,)11 b(whic)o(h)j(exp)q(orts)f Fe(define-structure)d -Fh(and)k(the)f(other)f(con-)338 1208 y(\014guration)i(language)g(k)o -(eyw)o(ords,)e(as)i(w)o(ell)h(as)e(standard)h(t)o(yp)q(es)f(and)h(t)o -(yp)q(e)g(con-)338 1264 y(structors)g(\()p Fe(:syntax)p -Fh(,)f Fe(:value)p Fh(,)h Fe(proc)p Fh(,)h(etc.\).)292 -1354 y Fd(\017)23 b Fe(built-in-structures)p Fh(,)18 -b(whic)o(h)j(exp)q(orts)f(structures)f(that)g(are)h(built)i(in)o(to)338 -1410 y(the)10 b(initial)i(Sc)o(heme)f(48)f(image;)h(these)g(include)h -Fe(scheme)p Fh(,)e Fe(tables)p Fh(,)g(and)g Fe(records)p -Fh(.)292 1500 y Fd(\017)23 b Fe(more-structures)p Fh(,)12 -b(whic)o(h)j(exp)q(orts)g(additional)g(structures)g(that)e(are)h(a)o(v) -m(ail-)338 1556 y(able)f(in)g(the)f(dev)o(elopmen)o(t)h(en)o(vironmen)o -(t;)g(these)f(include)j Fe(sort)p Fh(,)d Fe(random)p -Fh(,)f(and)338 1613 y Fe(threads)p Fh(.)224 1696 y(Note)k(that)f(it)i -(do)q(es)f(not)g(op)q(en)h Fe(scheme)p Fh(.)295 1752 -y(Y)l(ou)d(can)f(de\014ne)i(other)e(con\014guration)h(pac)o(k)m(ages)f -(b)o(y)h(simply)h(making)e(a)h(pac)o(k)m(age)224 1809 -y(that)k(op)q(ens)i Fe(module-system)d Fh(and,)j(optionally)l(,)h -Fe(built-in-structures)p Fh(,)15 b Fe(more-)224 1865 -y(structures)p Fh(,)f(or)g(other)h(structures)g(that)f(exp)q(ort)h -(structures)g(and)h(in)o(terfaces.)295 1922 y(F)l(or)e(example:)320 -2005 y Fe(>)23 b(,config)g(\(define-structure)f(foo)h(\(export)g(\))606 -2061 y(\(open)g(module-system)749 2118 y(built-in-structures)749 -2174 y(more-structures\)\))320 2231 y(>)g(,in)h(foo)320 -2287 y(foo>)f(\(define-structure)e(x)j(\(export)f(a)h(b\))487 -2344 y(\(open)f(scheme\))487 2400 y(\(files)g(x\)\))320 -2457 y(foo>)949 2581 y Fh(11)p eop -%%Page: 12 12 -12 11 bop 338 311 a Fe(,config-package-is)21 b Ff(struct-name)338 -384 y Fh(The)f Fe(,config-package-is)d Fh(command)i(designates)h(a)g -(new)f(con\014guration)338 441 y(pac)o(k)m(age)10 b(for)f(use)i(b)o(y)f -(the)g Fe(,config)f Fh(command)h(and)h(resolution)g(of)e -Ff(struct-name)q Fh(s)338 497 y(for)14 b(other)h(commands)g(suc)o(h)h -(as)f Fe(,in)f Fh(and)i Fe(,open)p Fh(.)224 617 y Fg(Discussion)224 -702 y Fh(This)j(mo)q(dule)f(system)g(w)o(as)f(not)g(designed)i(as)f -(the)f(b)q(e-all)j(and)e(end-all)h(of)f(Sc)o(heme)224 -759 y(mo)q(dule)e(systems;)e(it)g(w)o(as)g(only)h(in)o(tended)h(to)e -(help)i(Ric)o(hard)f(Kelsey)h(and)f(me)f(to)g(or-)224 -815 y(ganize)i(the)f(Sc)o(heme)h(48)f(system.)20 b(Not)14 -b(only)i(do)q(es)g(the)f(mo)q(dule)h(system)f(help)i(a)o(v)o(oid)224 -872 y(name)c(clashes)g(b)o(y)g(k)o(eeping)h(di\013eren)o(t)f -(subsystems)f(in)i(di\013eren)o(t)f(namespaces,)g(it)g(has)224 -928 y(also)j(help)q(ed)h(us)f(to)f(tigh)o(ten)g(up)h(and)g(generalize)h -(Sc)o(heme)f(48's)e(in)o(ternal)j(in)o(terfaces.)224 -985 y(Sc)o(heme)c(48)e(is)h(un)o(usual)g(among)f(Lisp)i(implemen)o -(tations)g(in)g(admitting)f(man)o(y)f(di\013er-)224 1041 -y(en)o(t)16 b(p)q(ossible)i(mo)q(des)f(of)e(op)q(eration.)24 -b(Examples)16 b(of)g(suc)o(h)h(m)o(ultiple)h(mo)q(des)e(include)224 -1098 y(the)f(follo)o(wing:)292 1180 y Fd(\017)23 b Fh(Linking)17 -b(can)e(b)q(e)h(either)g(static)f(or)g(dynamic.)292 1269 -y Fd(\017)23 b Fh(The)h(dev)o(elopmen)o(t)h(en)o(vironmen)o(t)g -(\(compiler,)i(debugger,)g(and)e(command)338 1325 y(pro)q(cessor\))18 -b(can)h(run)g(either)g(in)h(the)e(same)h(address)g(space)g(as)f(the)h -(program)338 1382 y(b)q(eing)c(dev)o(elop)q(ed)h(or)e(in)h(a)f -(di\013eren)o(t)h(address)f(space.)20 b(The)15 b(en)o(vironmen)o(t)f -(and)338 1438 y(user)g(program)e(ma)o(y)h(ev)o(en)i(run)f(on)f -(di\013eren)o(t)h(pro)q(cessors)g(under)g(di\013eren)o(t)g(op-)338 -1495 y(erating)h(systems[5)o(].)292 1584 y Fd(\017)23 -b Fh(The)18 b(virtual)g(mac)o(hine)h(can)f(b)q(e)h(supp)q(orted)f(b)o -(y)g(either)g(of)g(t)o(w)o(o)e(implemen)o(ta-)338 1640 -y(tions)f(of)g(its)g(implemen)o(tation)i(language,)e(Presc)o(heme.)224 -1723 y(The)e(mo)q(dule)g(system)f(has)g(b)q(een)h(helpful)i(in)e -(organizing)g(these)f(m)o(ultiple)i(mo)q(des.)19 b(By)224 -1779 y(forcing)g(us)f(to)g(write)g(do)o(wn)g(in)o(terfaces)h(and)g(mo)q -(dule)g(dep)q(endencies,)j(the)c(mo)q(dule)224 1836 y(system)12 -b(helps)i(us)e(to)g(k)o(eep)h(the)f(system)g(clean,)h(or)f(at)g(least)g -(to)g(k)o(eep)h(us)f(honest)h(ab)q(out)224 1892 y(ho)o(w)i(clean)h(or)f -(not)g(it)g(is.)295 1949 y(The)f(need)h(to)f(mak)o(e)g(structures)g -(and)g(in)o(terfaces)h(second-class)g(instead)g(of)f(\014rst-)224 -2005 y(class)19 b(results)f(from)g(the)g(requiremen)o(ts)h(of)e(static) -h(program)f(analysis:)27 b(it)18 b(m)o(ust)g(b)q(e)224 -2061 y(p)q(ossible)h(for)c(the)i(compiler)h(and)f(link)o(er)h(to)e -(expand)h(macros)f(and)g(resolv)o(e)h(v)m(ariable)224 -2118 y(bindings)12 b(b)q(efore)f(the)f(program)f(is)i(executed.)19 -b(Structures)11 b(could)g(b)q(e)g(made)f(\014rst-class)224 -2174 y(\(as)15 b(in)i(FX[6)o(]\))e(if)i(a)e(t)o(yp)q(e)h(system)g(w)o -(ere)g(added)g(to)f(Sc)o(heme)i(and)f(the)g(de\014nitions)i(of)224 -2231 y(exp)q(orted)d(macros)e(w)o(ere)h(de\014ned)i(in)f(in)o(terfaces) -f(instead)h(of)f(in)h(mo)q(dule)g(b)q(o)q(dies,)g(but)224 -2287 y(ev)o(en)h(in)g(that)e(case)h(t)o(yp)q(es)h(and)f(in)o(terfaces)g -(w)o(ould)h(remain)g(second-class.)295 2344 y(The)e(prohibition)i(on)e -(assignmen)o(t)f(to)h(imp)q(orted)g(bindings)i(mak)o(es)e(substitution) -224 2400 y(a)g(v)m(alid)i(optimization)f(when)f(a)g(mo)q(dule)h(is)g -(compiled)h(as)d(a)h(blo)q(c)o(k.)20 b(The)15 b(blo)q(c)o(k)g(com-)224 -2457 y(piler)f(\014rst)f(scans)g(the)g(en)o(tire)g(mo)q(dule)h(b)q(o)q -(dy)l(,)g(noting)f(whic)o(h)h(v)m(ariables)g(are)e(assigned.)949 -2581 y(12)p eop -%%Page: 13 13 -13 12 bop 224 311 a Fh(Those)14 b(that)g(aren't)f(assigned)i(\(only)g -Fe(define)p Fh(d\))e(ma)o(y)h(b)q(e)g(assumed)h(nev)o(er)f(assigned,) -224 368 y(ev)o(en)k(if)g(they)f(are)g(exp)q(orted.)27 -b(The)17 b(optimizer)i(can)e(then)h(p)q(erform)f(a)g(v)o(ery)g(simple-) -224 424 y(minded)h(analysis)f(to)e(determine)j(automatically)e(that)g -(some)g(pro)q(cedures)h(can)f(and)224 481 y(should)g(ha)o(v)o(e)f -(their)h(calls)g(compiled)h(in)f(line.)295 537 y(The)g(programming)g -(st)o(yle)h(encouraged)g(b)o(y)f(the)h(mo)q(dule)g(system)f(is)h -(consisten)o(t)224 594 y(with)e(the)g(unextended)h(Sc)o(heme)f -(language.)20 b(Because)15 b(mo)q(dule)h(system)e(features)h(do)224 -650 y(not)g(generally)i(sho)o(w)e(up)h(within)h(mo)q(dule)f(b)q(o)q -(dies,)h(an)f(individual)i(mo)q(dule)f(ma)o(y)e(b)q(e)224 -707 y(understo)q(o)q(d)f(b)o(y)f(someone)g(who)g(is)g(not)g(familiar)h -(with)f(the)g(mo)q(dule)i(system.)j(This)c(is)224 763 -y(a)i(great)e(aid)j(to)e(co)q(de)h(presen)o(tation)g(and)g(p)q -(ortabilit)o(y)l(.)22 b(If)16 b(a)g(few)f(simple)i(conditions)224 -819 y(are)k(met)f(\(no)g(name)h(con\015icts)h(b)q(et)o(w)o(een)f(pac)o -(k)m(ages,)h(no)e(use)h(of)g Fe(structure-ref)p Fh(,)224 -876 y(and)g(use)g(of)g Fe(files)f Fh(in)h(preference)h(to)e -Fe(begin)p Fh(\),)h(then)g(a)g(m)o(ulti-mo)q(dule)i(program)224 -932 y(can)f(b)q(e)h(loaded)g(in)o(to)f(a)f(Sc)o(heme)i(implemen)o -(tation)g(that)e(do)q(es)i(not)e(supp)q(ort)h(the)224 -989 y(mo)q(dule)17 b(system.)23 b(The)16 b(Sc)o(heme)h(48)e(static)h -(link)o(er)h(satis\014es)g(these)f(conditions,)h(and)224 -1045 y(can)e(therefore)f(run)h(in)h(other)e(Sc)o(heme)h(implemen)o -(tations.)21 b(Sc)o(heme)16 b(48's)d(b)q(o)q(otstrap)224 -1102 y(pro)q(cess,)h(whic)o(h)g(is)f(based)h(on)f(the)g(static)g(link)o -(er,)i(is)f(therefore)e(nonincestuous.)21 b(This)224 -1158 y(con)o(trasts)d(with)i(most)f(other)g(in)o(tegrated)g -(programming)g(en)o(vironmen)o(ts,)h(suc)o(h)g(as)224 -1215 y(Smalltalk-80,)d(where)g(the)g(system)f(can)g(only)h(b)q(e)g -(built)h(using)f(an)g(existing)g(v)o(ersion)224 1271 -y(of)e(the)g(system)g(itself.)295 1328 y(Lik)o(e)d(ML)f(mo)q(dules,)h -(but)g(unlik)o(e)g(Sc)o(heme)g(Xero)o(x)f(mo)q(dules,)h(this)g(mo)q -(dule)g(system)224 1384 y(is)f(comp)q(ositional.)19 b(That)10 -b(is,)h(structures)f(are)g(constructed)h(b)o(y)f(single)i(syn)o(tactic) -e(units)224 1440 y(that)i(comp)q(ose)h(existing)h(structures)e(with)h -(a)g(b)q(o)q(dy)g(of)g(co)q(de.)19 b(In)14 b(Sc)o(heme)f(Xero)o(x,)f -(the)224 1497 y(set)21 b(of)g(mo)q(dules)h(that)f(can)g(con)o(tribute)g -(to)g(an)g(in)o(terface)g(is)h(op)q(en-ended)h(|)f(an)o(y)224 -1553 y(mo)q(dule)f(can)f(con)o(tribute)g(bindings)i(to)d(an)o(y)g(in)o -(terface)h(whose)g(name)g(is)g(in)g(scop)q(e.)224 1610 -y(The)c(mo)q(dule)g(system)g(implemen)o(tation)g(is)g(a)f(cross-bar)g -(that)g(c)o(hannels)i(de\014nitions)224 1666 y(from)e(mo)q(dules)h(to)f -(in)o(terfaces.)21 b(The)16 b(mo)q(dule)h(system)e(describ)q(ed)i(here) -f(has)f(simpler)224 1723 y(seman)o(tics)g(and)f(mak)o(es)g(dep)q -(endencies)j(easier)e(to)f(trace.)19 b(It)14 b(also)g(allo)o(ws)h(for)f -(higher-)224 1779 y(order)h(mo)q(dules,)h(whic)o(h)g(Sc)o(heme)g(Xero)o -(x)f(considers)h(unimp)q(ortan)o(t.)224 1922 y Fi(References)247 -2024 y Fh([1])22 b(William)c(Clinger)g(and)e(Jonathan)h(Rees.)25 -b(Macros)15 b(that)h(w)o(ork.)23 b Ff(Principles)16 b(of)318 -2080 y(Pr)n(o)n(gr)n(amming)f(L)n(anguages)p Fh(,)f(Jan)o(uary)h(1991.) -247 2174 y([2])22 b(William)12 b(Clinger)g(and)f(Jonathan)f(Rees)i -(\(editors\).)g(Revised)1370 2158 y Fb(4)1402 2174 y -Fh(rep)q(ort)f(on)f(the)h(al-)318 2231 y(gorithmic)g(language)h(Sc)o -(heme.)i Ff(LISP)d(Pointers)g Fh(IV\(3\):1{55,)e(July-Septem)o(b)q(er) -318 2287 y(1991.)247 2381 y([3])22 b(P)o(a)o(v)o(el)17 -b(Curtis)h(and)g(James)g(Rauen.)29 b(A)18 b(mo)q(dule)h(system)f(for)f -(Sc)o(heme.)29 b Ff(A)o(CM)318 2437 y(Confer)n(enc)n(e)14 -b(on)i(Lisp)f(and)i(F)m(unctional)e(Pr)n(o)n(gr)n(amming,)f -Fh(pages)h(13{19,)e(1990.)949 2581 y(13)p eop -%%Page: 14 14 -14 13 bop 247 311 a Fh([4])22 b(Da)o(vid)11 b(MacQueen.)k(Mo)q(dules)e -(for)e(Standard)h(ML.)i Ff(A)o(CM)e(Confer)n(enc)n(e)f(on)i(Lisp)318 -368 y(and)j(F)m(unctional)f(Pr)n(o)n(gr)n(amming,)f Fh(1984.)247 -462 y([5])22 b(Jonathan)16 b(Rees)h(and)f(Bruce)h(Donald.)23 -b(Program)14 b(mobile)k(rob)q(ots)d(in)i(Sc)o(heme.)318 -518 y Ff(International)e(Confer)n(enc)n(e)f(on)i(R)n(ob)n(otics)g(and)g -(A)o(utomation,)f Fh(IEEE,)g(1992.)247 612 y([6])22 b(Mark)10 -b(A.)h(Sheldon)h(and)g(Da)o(vid)f(K.)g(Gi\013ord.)i(Static)e(dep)q -(enden)o(t)i(t)o(yp)q(es)e(for)g(\014rst-)318 668 y(class)i(mo)q -(dules.)18 b Ff(A)o(CM)13 b(Confer)n(enc)n(e)f(on)i(Lisp)g(and)g(F)m -(unctional)f(Pr)n(o)n(gr)n(amming,)318 725 y Fh(pages)i(20{29,)e(1990.) -949 2581 y(14)p eop -%%Trailer -end -userdict /end-hook known{end-hook}if -%%EOF diff --git a/doc/module.tex b/doc/module.tex deleted file mode 100644 index 212d948..0000000 --- a/doc/module.tex +++ /dev/null @@ -1,728 +0,0 @@ -\documentstyle[11pt]{article} - -\include{code} -\include{latex-stuff} - -\newcommand{\goesto}{\hbox{$\longrightarrow$}} -\newcommand{\alt}{$\vert$} -\newcommand{\arbno}[1]{{{#1}$^*$}} -\newcommand{\hack}{Scheme~48} - -\begin{document} - -\begin{center} -{\Large\bf Another Module System for Scheme} - -\vspace{2ex} -Jonathan Rees \\ -3 January 1993 (updated 15 January 1994) -\end{center} - -\vspace{3ex} - -This memo describes a module system for the Scheme programming -language. The module system is unique in the extent to which it -supports both static linking and rapid turnaround during program -development. The design was influenced by Standard ML -modules\cite{MacQueen:Modules} and by the module system for Scheme -Xerox\cite{Curtis-Rauen:Modules}. It has also been shaped by the -needs of \hack{}, a virtual-machine-based Scheme implementation -designed to run both on workstations and on relatively small (less -than 1 Mbyte) embedded controllers. - -Except where noted, everything described here is implemented in -\hack{}, and exercised by the \hack{} implementation and a few -application programs. - -Unlike the Common Lisp package system, the module system described -here controls the mapping of names to denotations, not the -mapping of strings to symbols. - - -\subsection*{Introduction} - -The module system supports the structured division of a corpus of -Scheme software into a set of modules. Each module has its own -isolated namespace, with visibility of bindings controlled by module -descriptions written in a special {\em configuration language.} - -A module may be instantiated multiple times, producing several {\em -packages}, just as a lambda-expression can be instantiated multiple -times to produce several different procedures. Since single -instantiation is the normal case, I will defer discussion of multiple -instantiation until a later section. For now you can think of a -package as simply a module's internal environment mapping names to -denotations. - -A module exports bindings by providing views onto the underlying -package. Such a view is called a {\em structure} (terminology from -Standard ML). One module may provide several different views. A -structure is just a subset of the package's bindings. The particular -set of names whose bindings are exported is the structure's {\em -interface}. - -A module imports bindings from other modules by either {\em opening} -or {\em accessing} some structures that are built on other packages. -When a structure is opened, all of its exported bindings are visible -in the client package. On the other hand, bindings from an accessed -structure require explicitly qualified references written with the -{\tt structure-ref} operator. - -For example: -\begin{code} - (define-structure foo (export a c cons) - (open scheme) - (begin (define a 1) - (define (b x) (+ a x)) - (define (c y) (* (b a) y)))) -\codeskip - (define-structure bar (export d) - (open scheme foo) - (begin (define (d w) (+ a (c w))))) -\end{code} -This configuration defines two structures, {\tt foo} and {\tt bar}. -{\tt foo} is a view on a package in which the {\tt scheme} structure's -bindings (including {\tt define} and {\tt +}) are visible, together -with bindings for {\tt a}, {\tt b}, -and {\tt c}. {\tt foo}'s interface is {\tt (export a c cons)}, so of -the bindings in its underlying package, {\tt foo} only exports those -three. Similarly, structure {\tt bar} consists of the binding of {\tt -d} from a package in which both {\tt scheme}'s and {\tt foo}'s -bindings are visible. {\tt foo}'s binding of {\tt cons} is imported -from the Scheme structure and then re-exported. - -A module's body, the part following {\tt begin} in the above example, -is evaluated in an isolated lexical scope completely specified by the -package definition's {\tt open} and {\tt access} clauses. In -particular, the binding of the syntactic operator {\tt define-structure} -is not visible unless it comes from some opened structure. Similarly, -bindings from the {\tt scheme} structure aren't visible unless they -become so by {\tt scheme} (or an equivalent structure) being opened. - - -\subsection*{The configuration language} - -The configuration language consists of top-level defining forms for -modules and interfaces. Its syntax is given in figure~1. - -\setbox0\hbox{\goesto} -\newcommand{\altz}{\hbox to 1\wd0{\hfil\alt}} - -%%%%% Put the figure inside a box ? - -\begin{figure} -%\begin{frameit} -\begin{tabbing} - \syn{configuration} \=\goesto{}~\arbno{\syn{definition}} \\ - \syn{definition} \=\goesto{}~ - \tt(define-structure \syn{name} \syn{interface} - \arbno{\syn{clause}}) \\ - \>\altz{}~ \tt(define-structures (\arbno{(\syn{name} \syn{interface})}) - \arbno{\syn{clause}}) \\ - \>\altz{}~ \tt(define-interface \syn{name} \syn{interface}) \\ - \>\altz{}~ \tt(define-syntax \syn{name} \syn{transformer-spec}) \\ - \syn{clause} \=\goesto{}~ \tt(open \arbno{\syn{name}}) \\ - \>\altz{}~ \tt(access \arbno{\syn{name}}) \\ - \>\altz{}~ \tt(begin \syn{program}) \\ - \>\altz{}~ \tt(files \arbno{\syn{filespec}}) \\ - \>\altz{}~ \tt(optimize \arbno{\syn{optimize-spec}}) \\ - \>\altz{}~ \tt(for-syntax \arbno{\syn{clause}}) \\ - \syn{interface} \=\goesto{}~ \tt(export \arbno{\syn{item}}) \\ - \>\altz{}~ \syn{name} \\ - \>\altz{}~ \tt(compound-interface \arbno{\syn{interface}}) \\ - \syn{item} \=\goesto{}~ \syn{name}~ - \alt{}~ \tt(\syn{name} \syn{type}) - \alt{}~ \tt((\arbno{\syn{name}}) \syn{type}) -\end{tabbing} -\caption{The configuration language.} -%\end{frameit} -\end{figure} - - -A {\tt define-structure} form introduces a binding of a name to a -structure. A structure is a view on an underlying package which is -created according to the clauses of the {\tt define-structure} form. -Each structure has an interface that specifies which bindings in the -structure's underlying package can be seen via that structure in other -packages. - -An {\tt open} clause specifies which structures will be opened up for -use inside the new package. At least one package must be specified or -else it will be impossible to write any useful programs inside the -package, since {\tt define}, {\tt lambda}, {\tt cons}, {\tt -structure-ref}, etc.\ will be unavailable. Typical packages to list -in the {\tt open} clause are {\tt scheme}, which exports all bindings -appropriate to Revised$^5$ Scheme, and {\tt structure-refs}, which -exports the {\tt structure-ref} operator (see below). For building -structures that export structures, there is a {\tt defpackage} package -that exports the operators of the configuration language. Many other -structures, such as record and hash table facilities, are also -available in the \hack{} implementation. - -An {\tt access} clause specifies which bindings of names to structures -will be visible inside the package body for use in {\tt structure-ref} -forms. {\tt structure-\ok{}ref} has the following syntax: -\begin{tabbing} -\qquad \syn{expression} \goesto{}~ - \tt(structure-ref \syn{struct-name} \syn{name}) -\end{tabbing} -The \syn{struct-name} must be the name of an {\tt access}ed structure, -and \syn{name} must be something that the structure exports. Only -structures listed in an {\tt access} clause are valid in a {\tt -structure-ref}. If a package accesses any structures, it should -probably open the {\tt structure-refs} structure so that the {\tt -structure-ref} operator itself will be available. - -The package's body is specified by {\tt begin} and/or {\tt files} -clauses. {\tt begin} and {\tt files} have the same semantics, except -that for {\tt begin} the text is given directly in the package -definition, while for {\tt files} the text is stored somewhere in the -file system. The body consists of a Scheme program, that is, a -sequence of definitions and expressions to be evaluated in order. In -practice, I always use {\tt files} in preference to {\tt begin}; {\tt -begin} exists mainly for expository purposes. - -A name's imported binding may be lexically overridden or {\em shadowed} -by simply defining the name using a defining form such as {\tt define} -or {\tt define-\ok{}syntax}. This will create a new binding without having -any effect on the binding in the opened package. For example, one can -do {\tt(define car 'chevy)} without affecting the binding of the name -{\tt car} in the {\tt scheme} package. - -Assignments (using {\tt set!})\ to imported and undefined variables -are not allowed. In order to {\tt set!}\ a top-level variable, the -package body must contain a {\tt define} form defining that variable. -Applied to bindings from the {\tt scheme} structure, this restriction -is compatible with the requirements of the Revised$^5$ Scheme report. - -It is an error for two of a package's opened structures to export two -different bindings for the same name. However, the current -implementation does not check for this situation; a name's binding is -always taken from the structure that is listed first within the {\tt -open} clause. This may be fixed in the future. - -File names in a {\tt files} clause can be symbols, strings, or lists -(Maclisp-style ``namelists''). A ``{\tt.scm}'' file type suffix is -assumed. Symbols are converted to file names by converting to upper -or lower case as appropriate for the host operating system. A -namelist is an operating-system-indepedent way to specify a file -obtained from a subdirectory. For example, the namelist {\tt(rts -record)} specifies the file {\tt record.scm} in the {\tt rts} -subdirectory. - -If the {\tt define-structure} form was itself obtained from a file, -then file names in {\tt files} clauses are interpreted relative to the -directory in which the file containing the {\tt define-structure} form -was found. You can't at present put an absolute path name in the {\tt -files} list. - - -\subsection*{Interfaces} - -An interface can be thought of as the type of a structure. In its -basic form it is just a list of variable names, written {\tt(export -\var{name} \etc)}. However, in place of -a name one may write {\tt(\var{name} \var{type})}, indicating the type -of \var{name}'s binding. Currently the type field is ignored, except -that exported macros must be indicated with type {\tt :syntax}. - -Interfaces may be either anonymous, as in the example in the -introduction, or they may be given names by a {\tt define-interface} -form, for example -\begin{code} - (define-interface foo-interface (export a c cons)) - (define-structure foo foo-interface \etc) -\end{code} -In principle, interfaces needn't ever be named. If an interface -had to be given at the point of a structure's use as well as at the -point of its definition, it would be important to name interfaces in -order to avoid having to write them out twice, with risk of mismatch -should the interface ever change. But they don't. - -Still, there are several reasons to use {\tt define-interface}: -\begin{enumerate} -\item It is important to separate the interface definition from the -package definitions when there are multiple distinct structures that -have the same interface --- that is, multiple implementations of the -same abstraction. - -\item It is conceptually cleaner, and useful for documentation -purposes, to separate a module's specification (interface) from its -implementation (package). - -\item My experience is that configurations that are separated into -interface definitions and package definitions are easier to read; the -long lists of exported bindings just get in the way most of the time. -\end{enumerate} - -The {\tt compound-interface} operator forms an interface that is the -union of two or more component interfaces. For example, -\begin{code} - (define-interface bar-interface - (compound-interface foo-interface (export mumble))) -\end{code} -defines {\tt bar-interface} to be {\tt foo-interface} with the name -{\tt mumble} added. - - -\subsection*{Macros} - -Hygienic macros, as described in -\cite{Clinger-Rees:Macros,Clinger-Rees:R4RS}, are implemented. -Structures may export macros; auxiliary names introduced into the -expansion are resolved in the environment of the macro's definition. - -For example, the {\tt scheme} structure's {\tt delay} macro -is defined by the rewrite rule -\begin{code} - (delay \var{exp}) \xform (make-promise (lambda () \var{exp}))\rm. -\end{code} -The variable {\tt make-promise} is defined in the {\tt scheme} -structure's underlying package, but is not exported. A use of the -{\tt delay} macro, however, always accesses the correct definition -of {\tt make-promise}. Similarly, the {\tt case} macro expands into -uses of {\tt cond}, {\tt eqv?}, and so on. These names are exported -by {\tt scheme}, but their correct bindings will be found even if they -are shadowed by definitions in the client package. - - -\subsection*{Higher-order modules} - -There are {\tt define-module} and {\tt define} forms for -defining modules that are intended to be instantiated multiple times. -But these are pretty kludgey --- for example, compiled code isn't -shared between the instantiations --- so I won't describe them yet. -If you must know, figure it out from the following grammar. -\begin{tabbing} -\qquad - \syn{definition} \=\goesto{}~ - \tt(d\=\tt{}efine-module (\syn{name} \arbno{(\syn{name} \syn{interface})}) \\ - \> \>\arbno{\syn{definition}} \\ - \> \>\syn{name}\tt) \\ - \>\altz{}~ \tt(define \syn{name} - (\syn{name} \arbno{\syn{name}})) -\end{tabbing} - - -\subsection*{Compiling and linking} - -\hack{} has a static linker that produces stand-alone heap images -from module descriptions. One specifies a particular procedure in a -particular structure to be the image's startup procedure (entry -point), and the linker traces dependency links as given by {\tt open} -and {\tt access} clauses to determine the composition of the heap -image. - -There is not currently any provision for separate compilation; the -only input to the static linker is source code. However, it will not -be difficult to implement separate compilation. The unit of -compilation is one module (not one file). Any opened or accessed -structures from which macros are obtained must be processed to the -extent of extracting its macro definitions. The compiler knows from -the interface of an opened or accessed structure which of its exports -are macros. Except for macros, a module may be compiled without any -knowledge of the implementation of its opened and accessed structures. -However, inter-module optimization will be available as an option. - -The main difficulty with separate compilation is resolution of -auxiliary bindings introduced into macro expansions. The module -compiler must transmit to the loader or linker the search path by -which such bindings are to be resolved. In the case of the {\tt delay} -macro's auxiliary {\tt make-promise} (see example above), the loader -or linker needs to know that the desired binding of {\tt make-promise} -is the one apparent in {\tt delay}'s defining package, not in the -package being loaded or linked. - -[I need to describe structure reification.] - - -\subsection*{Semantics of configuration mutation} - -During program development it is often desirable to make changes to -packages and interfaces. In static languages it may be necessary to -recompile and re-link a program in order for such changes to be -reflected in a running system. Even in interactive Common Lisp -implementations, a change to a package's exports often requires -reloading clients that have already mentioned names whose bindings -change. Once {\tt read} resolves a use of a name to a symbol, that -resolution is fixed, so a change in the way that a name resolves to a -symbol can only be reflected by re-{\tt read}ing all such references. - -The \hack{} development environment supports rapid turnaround in -modular program development by allowing mutations to a program's -configuration, and giving a clear semantics to such mutations. The -rule is that variable bindings in a running program are always -resolved according to current structure and interface bindings, even -when these bindings change as a result of edits to the configuration. -For example, consider the following: -\begin{code} - (define-interface foo-interface (export a c)) - (define-structure foo foo-interface - (open scheme) - (begin (define a 1) - (define (b x) (+ a x)) - (define (c y) (* (b a) y)))) - (define-structure bar (export d) - (open scheme foo) - (begin (define (d w) (+ (b w) a)))) -\end{code} -This program has a bug. The variable {\tt b}, which is free in the -definition of {\tt d}, has no binding in {\tt bar}'s package. Suppose -that {\tt b} was supposed to be exported by {\tt foo}, but was omitted -from {\tt foo-interface} by mistake. It is not necessary to -re-process {\tt bar} or any of {\tt foo}'s other clients at this point. -One need only change {\tt foo-interface} and inform the development -system of that one change (using, say, an appropriate Emacs command), -and {\tt foo}'s binding of {\tt b} will be found when procedure {\tt -d} is called. - -Similarly, it is also possible to replace a structure; clients of the -old structure will be modified so that they see bindings from the new -one. Shadowing is also supported in the same way. Suppose that a -client package $C$ opens a structure {\tt foo} that exports a name -{\tt x}, and {\tt foo}'s implementation obtains the binding of {\tt x} -as an import from some other structure {\tt bar}. Then $C$ will see -the binding from {\tt bar}. If one then alters {\tt foo} so that it -shadows {\tt bar}'s binding of {\tt x} with a definition of its own, -then procedures in $C$ that reference {\tt x} will automatically see -{\tt foo}'s definition instead of the one from {\tt bar} that they saw -earlier. - -This semantics might appear to require a large amount of computation -on every variable reference: The specified behavior requires scanning -the package's list of opened structures, examining their interfaces, -on every variable reference, not just at compile time. However, the -development environment uses caching with cache invalidation to make -variable references fast. - - -\subsection*{Command processor support} - -While it is possible to use the \hack{} static linker for program -development, it is far more convenient to use the development -environment, which supports rapid turnaround for program changes. The -programmer interacts with the development environment through a {\em -command processor}. The command processor is like the usual Lisp -read-eval-print loop in that it accepts Scheme forms to evaluate. -However, all meta-level operations, such as exiting the Scheme system -or requests for trace output, are handled by {\em commands,} which are -lexically distinguished from Scheme forms. This arrangement is -borrowed from the Symbolics Lisp Machine system, and is reminiscent of -non-Lisp debuggers. Commands are a little easier to type than Scheme -forms (no parentheses, so you don't have to shift), but more -importantly, making them distinct from Scheme forms ensures that -programs' namespaces aren't clutterred with inappropriate bindings. -Equivalently, the command set is available for use regardless of what -bindings happen to be visible in the current program. This is -especially important in conjunction with the module system, which puts -strict controls on visibility of bindings. - -The \hack{} command processor supports the module system with a -variety of special commands. For commands that require structure -names, these names are resolved in a designated configuration package -that is distinct from the current package for evaluating Scheme forms -given to the command processor. The command processor interprets -Scheme forms in a particular current package, and there are commands -that move the command processor between different packages. - -Commands are introduced by a comma ({\tt,}) and end at the end of -line. The command processor's prompt consists of the name of the -current package followed by a greater-than ({\tt>}). - -\begin{list}{}{}{} - -\item -\begin{code} -,config -\end{code} - The {\tt,config} command sets the command processor's current - package to be the current configuration package. Forms entered at - this point are interpreted as being configuration language forms, - not Scheme forms. - -\item -\begin{code} -,config \var{command} -\end{code} - This form of the {\tt,config} command executes another command in - the current configuration package. For example, -\begin{code} - ,config ,load foo.scm -\end{code} - interprets configuration language forms from the file {\tt - foo.scm} in the current configuration package. - -\item -\begin{code} -,in \var{struct-name} -\end{code} - The {\tt ,in} command moves the command processor to a specified - structure's underlying package. For example: -\begin{code} - user> ,config - config> (define-structure foo (export a) - (open scheme)) - config> ,in foo - foo> (define a 13) - foo> a - 13 -\end{code} - In this example the command processor starts in a package called - {\tt user}, but the {\tt ,config} command moves it into the - configuration package, which has the name {\tt config}. The {\tt - define-structure} form binds, in {\tt config}, the name {\tt foo} to - a structure that exports {\tt a}. Finally, the command {\tt ,in - foo} moves the command processor into structure {\tt foo}'s - underlying package. - - A package's body isn't executed (evaluated) until the package is - {\em loaded}, which is accomplished by the {\tt ,load-package} - command. - -\item -\begin{code} -,in \var{struct-name} \var{command} -\end{code} - This form of the {\tt,in} command executes a single command in the - specified package without moving the command processor into that - package. Example: -\begin{code} - ,in mumble (cons 1 2) - ,in mumble ,trace foo -\end{code} - -\item -\begin{code} -,user $[$\var{command}$]$ -\end{code} - This is similar to the {\tt ,config} and {\tt ,in} commands. It - moves to or executes a command in the user package (which is the - default package when the \hack{} command processor starts). - -\item -\begin{code} -,for-syntax $[$\var{command}$]$ -\end{code} - This is similar to the {\tt ,config} and {\tt ,in} commands. It - moves to or executes a command in the current package's ``package - for syntax,'' which is the package in which the forms $f$ in - {\tt (define-syntax \var{name} $f$)} are evaluated. - -\item -\begin{code} -,load-package \var{struct-name} -\end{code} - The {\tt,load-package} command ensures that the specified structure's - underlying package's program has been loaded. This - consists of (1) recursively ensuring that the packages of any - opened or accessed structures are loaded, followed by (2) - executing the package's body as specified by its definition's {\tt - begin} and {\tt files} forms. - -\item -\begin{code} -,reload-package \var{struct-name} -\end{code} - This command re-executes the structure's package's program. It - is most useful if the program comes from a file or files, when - it will update the package's bindings after mutations to its - source file. - -\item -\begin{code} -,load \var{filespec} \etc -\end{code} - The {\tt,load} command executes forms from the specified file or - files in the current package. {\tt,load \var{filespec}} is similar - to {\tt(load "\var{filespec}")} - except that the name {\tt load} needn't be bound in the current - package to Scheme's {\tt load} procedure. - -\item -\begin{code} -,structure \var{name} \var{interface} -\end{code} - The {\tt,structure} command defines \var{name} in the - configuration package to be a structure with interface - \var{interface} based on the current package. - -\item -\begin{code} -,open \arbno{\var{struct-name}} -\end{code} - The {\tt,open} command opens a new structure in the current - package, as if the package's definition's {\tt open} clause - had listed \var{struct-name}. - -\end{list} - - - -\subsection*{Configuration packages} - -It is possible to set up multiple configuration packages. The default -configuration package opens the following structures: -\begin{itemize} -\item {\tt module-system}, which exports {\tt define-structure} and the - other configuration language keywords, as well as standard types - and type constructors ({\tt :syntax}, {\tt :value}, {\tt proc}, etc.). -\item {\tt built-in-structures}, which exports structures that are - built into the initial \hack{} image; these include {\tt - scheme}, {\tt tables}, and {\tt records}. -\item {\tt more-structures}, which exports additional structures that - are available in the development environment; these include - {\tt sort}, {\tt random}, and {\tt threads}. -\end{itemize} -Note that it does not open {\tt scheme}. - -You can define other configuration packages by simply making a package -that opens {\tt module-system} and, optionally, {\tt -built-in-\ok{}structures}, {\tt more-\ok{}structures}, or other structures that -export structures and interfaces. - -For example: -\begin{code} - > ,config (define-structure foo (export ) - (open module-system - built-in-structures - more-structures)) - > ,in foo - foo> (define-structure x (export a b) - (open scheme) - (files x)) - foo> -\end{code} - -\begin{list}{}{}{} -\item -\begin{code} -,config-package-is \var{struct-name} -\end{code} - The {\tt,config-package-is} command designates a new configuration - package for use by the {\tt,config} command and resolution of - \var{struct-name}s for other commands such as {\tt,in} and - {\tt,open}. -\end{list} - - - -\subsection*{Discussion} - -This module system was not designed as the be-all and end-all of -Scheme module systems; it was only intended to help Richard Kelsey and -me to organize the \hack{} system. Not only does the module system -help avoid name clashes by keeping different subsystems in different -namespaces, it has also helped us to tighten up and generalize -\hack{}'s internal interfaces. \hack{} is unusual among Lisp -implementations in admitting many different possible modes of -operation. Examples of such multiple modes include the following: -\begin{itemize} - \item Linking can be either static or dynamic. - - \item The development environment (compiler, debugger, and command - processor) can run either in the same address space as the program - being developed or in a different address space. The environment and - user program may even run on different processors under different - operating systems\cite{Rees-Donald:Program}. - - \item The virtual machine can be supported by either - of two implementations of its implementation language, Prescheme. -\end{itemize} -The module system has been helpful in organizing these multiple modes. -By forcing us to write down interfaces and module dependencies, the -module system helps us to keep the system clean, or at least to keep -us honest about how clean or not it is. - -The need to make structures and interfaces second-class instead of -first-class results from the requirements of static program analysis: -it must be possible for the compiler and linker to expand macros and -resolve variable bindings before the program is executed. Structures -could be made first-class (as in FX\cite{Sheldon-Gifford:Static}) if a -type system were added to Scheme and the definitions of exported -macros were defined in interfaces instead of in module bodies, but -even in that case types and interfaces would remain second-class. - -The prohibition on assignment to imported bindings makes substitution -a valid optimization when a module is compiled as a block. The block -compiler first scans the entire module body, noting which variables -are assigned. Those that aren't assigned (only {\tt define}d) may be -assumed never assigned, even if they are exported. The optimizer can -then perform a very simple-minded analysis to determine automatically -that some procedures can and should have their calls compiled in line. - -The programming style encouraged by the module system is consistent -with the unextended Scheme language. Because module system features -do not generally show up within module bodies, an individual module -may be understood by someone who is not familiar with the module -system. This is a great aid to code presentation and portability. If -a few simple conditions are met (no name conflicts between packages, -no use of {\tt structure-ref}, and use of {\tt files} in preference to -{\tt begin}), then a multi-module program can be loaded into a Scheme -implementation that does not support the module system. The \hack{} -static linker satisfies these conditions, and can therefore run in -other Scheme implementations. \hack{}'s bootstrap process, which is -based on the static linker, is therefore nonincestuous. This -contrasts with most other integrated programming environments, such as -Smalltalk-80, where the system can only be built using an existing -version of the system itself. - -Like ML modules, but unlike Scheme Xerox modules, this module system -is compositional. That is, structures are constructed by single -syntactic units that compose existing structures with a body of code. -In Scheme Xerox, the set of modules that can contribute to an -interface is open-ended --- any module can contribute bindings to any -interface whose name is in scope. The module system implementation is -a cross-bar that channels definitions from modules to interfaces. The -module system described here has simpler semantics and makes -dependencies easier to trace. It also allows for higher-order -modules, which Scheme Xerox considers unimportant. - -%[Discuss use of module system in the \hack{} implementation? Maybe -%give an extended excerpt from \hack{}'s configuration files?] -% -%[Discuss or flush OPTIMIZE clause.] -% -%[Future work: ideas for anonymous structures and more of a module -%calculus; dealing with name conflicts; interface subtraction.] - - -\begin{thebibliography}{10} - -\bibitem{Clinger-Rees:Macros} -William Clinger and Jonathan~Rees. -\newblock Macros that work. -\newblock {\em Principles of Programming Languages}, January 1991. - -\bibitem{Clinger-Rees:R4RS} -William Clinger and Jonathan~Rees (editors). -\newblock Revised${}^4$ report on the algorithmic language {S}cheme. -\newblock {\em LISP Pointers} IV(3):1--55, July-September 1991. - -\bibitem{Curtis-Rauen:Modules} -Pavel Curtis and James Rauen. -\newblock A module system for Scheme. -\newblock {\em ACM Conference on Lisp and Functional Programming,} -pages 13--19, 1990. - -\bibitem{MacQueen:Modules} -David MacQueen. -\newblock Modules for Standard ML. -\newblock {\em ACM Conference on Lisp and Functional Programming,} -1984. - -\bibitem{Rees-Donald:Program} -Jonathan Rees and Bruce Donald. -\newblock Program mobile robots in Scheme. -\newblock {\em International Conference on Robotics and -Automation,} IEEE, 1992. - -\bibitem{Sheldon-Gifford:Static} -Mark A.~Sheldon and David K.~Gifford. -\newblock Static dependent types for first-class modules. -\newblock {\em ACM Conference on Lisp and Functional Programming,} -pages 20--29, 1990. - -\end{thebibliography} - - -\end{document} diff --git a/doc/no-leaf-env.txt b/doc/no-leaf-env.txt deleted file mode 100644 index 87a6967..0000000 --- a/doc/no-leaf-env.txt +++ /dev/null @@ -1,175 +0,0 @@ -Return-Path: -Date: Mon, 14 Jun 93 14:34:40 -0400 -To: jar@cs.cornell.edu -Subject: environments for leaf procedures -From: kelsey@flora.ccs.neu.edu -Sender: kelsey@ccs.neu.edu - - -I merged the no-leaf-environments code back into the system, and this -time it may be worth it. Loading pp.scm sped up by 2%, even though -the compiler is doing more work. Benchmark times (in seconds): - - old new speedup -quicksort 1.48 1.39 6% -towers 1.05 1.05 0% -matrix-multiply 3.32 3.10 7% -matrix-multiply2 1.94 1.80 7% - -Local variable names are screwed up: - - > (define (f x) (let ((y 4)) (+ x y))) - > (f 'a) - - Error: exception - (+ 'a 4) - 1> ,debug - '#{Continuation (pc 13) f} - - [0] 4 - [1: y] 'a - inspect: - -There is probably a simple fix for this. - -Here is the diff: - -% diff comp.scm comp.scm.save -26d25 -< (define $compiling-leaf (make-fluid 'no)) -28,33d26 -< (define (note-not-leaf!) -< (set-fluid! $compiling-leaf 'no)) -< -< (define (compiling-leaf?) -< (eq? 'yes (fluid $compiling-leaf))) -< -63,82c56,66 -< (deliver-value (if (env-ref? den) -< (local-variable den cenv depth #f) -< (instruction-with-variable op/global exp den #f)) -< cont))) -< -< (define (local-variable den cenv depth set?) -< (let ((back (env-ref-back den cenv)) -< (over (env-ref-over den))) -< (if (and (compiling-leaf?) -< (= back 0)) -< (instruction (if set? op/stack-set! op/stack-ref) -< (+ (- over 1) depth)) -< (let ((back (if (compiling-leaf?) (- back 1) back))) -< (if set? -< (instruction op/set-local! back over) -< (case back -< ((0) (instruction op/local0 over)) ;+++ -< ((1) (instruction op/local1 over)) ;+++ -< ((2) (instruction op/local2 over)) ;+++ -< (else (instruction op/local back over)))))))) ---- -> (if (env-ref? den) -> (let ((back (env-ref-back den cenv)) -> (over (env-ref-over den))) -> (deliver-value (case back -> ((0) (instruction op/local0 over)) ;+++ -> ((1) (instruction op/local1 over)) ;+++ -> ((2) (instruction op/local2 over)) ;+++ -> (else (instruction op/local back over))) -> cont)) -> (deliver-value (instruction-with-variable op/global exp den #f) -> cont)))) -143,145c127,132 -< (if (env-ref? den) -< (local-variable den cenv depth #t) -< (instruction-with-variable op/set-global! name den #t))) ---- -> (cond ((env-ref? den) -> (instruction op/set-local! -> (env-ref-back den cenv) -> (env-ref-over den))) -> (else -> (instruction-with-variable op/set-global! name den #t)))) -203d189 -< (note-not-leaf!) ; this isn't strictly necessary, but it keeps things simpler -222,231c208,215 -< (cond ((return-cont? cont) -< code) -< (else -< (note-not-leaf!) ; this isn't strictly necessary, but it keeps things simpler -< (sequentially (instruction-with-offset&byte op/make-cont -< (segment-size code) -< depth) -< (note-source-code (cont-source-info cont) -< code) -< (cont-segment cont))))) ---- -> (if (return-cont? cont) -> code -> (sequentially (instruction-with-offset&byte op/make-cont -> (segment-size code) -> depth) -> (note-source-code (cont-source-info cont) -> code) -> (cont-segment cont)))) -264d247 -< (note-not-leaf!) -280,315c263,284 -< (let-fluids $compiling-leaf 'maybe -< (lambda () -< (let ((code (really-compile-lambda-code formals body cenv name))) -< (if (eq? (fluid $compiling-leaf) 'maybe) -< (let-fluids $compiling-leaf 'yes -< (lambda () -< (really-compile-lambda-code formals body cenv name))) -< code))))) -< -< (define (really-compile-lambda-code formals body cenv name) -< (let* ((nargs (number-of-required-args formals)) -< (vars (normalize-formals formals)) -< (cenv (if (null? formals) -< cenv ;+++ -< (bind-vars vars cenv)))) -< (sequentially -< (cond ((n-ary? formals) -< (sequentially -< (instruction op/make-rest-list nargs) -< (instruction op/push) -< (if (compiling-leaf?) -< empty-segment -< (instruction op/make-env (+ nargs 1))))) -< ((null? formals) -< (note-not-leaf!) ; no point if no variables -< empty-segment) -< ((compiling-leaf?) -< empty-segment) -< (else -< (instruction op/make-env nargs))) -< (note-environment -< vars -< (compile-body body -< cenv -< 0 -< (return-cont name)))))) ---- -> (if (null? formals) -> (compile-body body ;+++ Don't make null environment -> cenv -> 0 -> (return-cont name)) -> (sequentially -> (let ((nargs (number-of-required-args formals))) -> (if (n-ary? formals) -> (sequentially -> (instruction op/make-rest-list nargs) -> (instruction op/push) -> (instruction op/make-env (+ nargs 1))) -> (instruction op/make-env nargs))) -> (let* ((vars (normalize-formals formals)) -> (cenv (bind-vars vars cenv))) -> (note-environment -> vars -> (compile-body body -> cenv -> 0 -> (return-cont name))))))) -> - diff --git a/doc/package.txt b/doc/package.txt deleted file mode 100644 index 0532411..0000000 --- a/doc/package.txt +++ /dev/null @@ -1,81 +0,0 @@ --- this file is probably obsolete -- - -The package system interface. Much too complicated. - -Signatures - - make-simple-signature - make-compound-signature - signature? - signature-ref - signature-walk - -Structures - - make-structure - structure? - structure-signature - structure-package - structure-name - -Packages - - make-package - make-simple-package ;start.scm - -Lookup and definition operations - - package-lookup - package-lookup-type ;comp.scm - package-find-location ;rts/env.scm - package-lookup-location ;segment.scm - probe-package - package-check-assigned - package-check-variable - - package-define! - package-define-type! ;hmm. - package-ensure-defined! - -Things needed by the form/file/package scanner - - for-each-definition ;for integrate-all-primitives! - package-accesses ;for scan-package - package-clauses ;for scan-package - package-file-name ;for scan-package - package-opens ;for scan-package - package-evaluator ;for define-syntax - package-for-syntax ;for define-syntax - -Miscellaneous - - $note-undefined ;eval.scm - noting-undefined-variables ;eval.scm, etc. - package-uid ;eval.scm - set-shadow-action! ;eval.scm - verify-later! ;for the define-structures macro - reset-packages-state! ;Makefile - for linker - initialize-reified-package! ;for reification - transform-for-structure-ref ;for reification ? - -Inessential (for package mutation, programming environment) - - check-structure - package-integrate? ;env/debug.scm - set-package-integrate?! ;env/debug.scm - package-loaded? ;env/load-package.scm - set-package-loaded?! ;env/load-package.scm - package-name ;env/command.scm - package-name-table ;env/debuginfo.scm - package-open! ;env/debug.scm - package-system-sentinel ;env/command.scm - package-unstable? ;env/pacman.scm - package? ;env/command.scm - undefined-variables ;env/debug.scm - -Location names (also inessential) - - flush-location-names - location-name - location-name-table - location-package-name diff --git a/doc/scsh-src-roadmap.txt b/doc/scsh-src-roadmap.txt deleted file mode 100644 index c69e0ef..0000000 --- a/doc/scsh-src-roadmap.txt +++ /dev/null @@ -1,83 +0,0 @@ -The current scsh release is structured as follows. - -Scsh is packaged up inside a standard S48 file tree. -The main directory contains a copy of Scheme 48 0.36. -However... we've made a few small mods to this copy of -0.36, so do not try to compile scsh with an off-the-shelf -0.39 or a newer release just yet. - -In order for scsh's ports to be handled correctly by GC, -we have installed a call-out in the 0.36 vm's gc code that -is activated after every gc (it's post_gc_fdports()). This -means that you *must* use our 0.36 vm. There is machinery -in the latest releases of S48 that makes this hackery unnecessary, -so we intend to drop this constraint in the future. - -For this reason, the scsh vm is called "scshvm" not scheme48vm, -since it is not quite the same thing. - -* S48 -We intend to port scsh to the current release of S48. The -major difficulty here is that S48 now has threads and all -i/o is non-blocking. This greatly complicates the Unix services -scsh provides, since the details of the Unix system architecture do -not get along well with threads. We'll have to completely rewrite our i/o -subsystem, for example. For now, we use 0.36. - -* DOC -The doc/ directory contains the scsh manual and a paper about scsh. -The paper is also available as MIT LCS and University of Hong Kong -tech reports; a revised version is due to appear in *Lisp and Symbolic -Computation*. - -* CIG -Scsh uses a lot of foreign-function calls to interface to the Unix -system calls and other support routines. It uses a package called "cig" -(C Interface Generator) to do this. The code for cig lives in the -cig/ subdirectory. Cig is a system that processes a .scm file containing -(DEFINE-FOREIGN ...) forms, producing a C file of stub interfaces. The -C code manages the handoff to the C routine you were calling, converting -between Scheme and C representations, handling argument passing protocols, -nary function conventions, multiple-value return protocols, and so forth. -The C stub file is then compiled and linked in with the S48 vm (statically -or dynamically), and away you go. - -There is a draft manual for cig in cig/doc, but be warned that it is -incomplete and out of date. - -Although scsh uses cig-generated C stub files, we ship the source tree -with these files already generated, so you should not have to process -Scheme code with cig to make scsh unless you go and change the -DEFINE-FOREIGN forms in the scsh source. - -* SCSH -The source for scsh proper lives in the scsh/ directory. This directory -contains -- the system-independent code - -- the regexp/ subdirectory, containing Henry Spencer's regexp pattern - matching library. - -- A subdirectory for each type of system supported by scsh, - e.g. sparc-sunos/, i386-linux/, hppa-hpux/, and so forth. - These directories contain system-dependent code, such as - definitions of the actual numeric values of the Unix errno codes - (errno.h), operations that extend the stdio library, and so forth. - -- A symlink to one of the system-specific subdirectories. - This symlink is made when the top-level configure decides the system - for which we are building scsh. For example, if we are building scsh for - Sparcstations, then the scsh directory has the following symlink: - machine -> sparc-sunos/ - The machine dependant files are: - errno.scm - fdflags.scm - load-scsh.scm - packages.scm - signals.scm - stdio_dep.c - -The source code follows a convention that if a file foo.scm contains -some DEFINE-FOREIGN forms, then the stub C file produced by cig is -called foo.c, and any related support C code written by a human goes -in foo1.c. diff --git a/doc/summary.tex b/doc/summary.tex deleted file mode 100644 index 17c8555..0000000 --- a/doc/summary.tex +++ /dev/null @@ -1,83 +0,0 @@ -\documentstyle[11pt]{article} - -\pagestyle{empty} -\setlength{\textheight}{9in} -\setlength{\footheight}{0.0in} -\setlength{\topmargin}{0in} - -%Defaults from art10.sty: -%\textwidth 345pt \columnsep 10pt \columnseprule 0pt -%\oddsidemargin 63pt - -\advance\textwidth by 0.5in -\advance\oddsidemargin by -0.25in - - -\begin{document} - -\vspace*{-0.3in} - -\begin{center} -{\large\bf Scheme 48} \\ -\vspace{1ex} -Richard Kelsey ({\tt kelsey@corwin.ccs.northeastern.edu}) \\ -Jonathan Rees ({\tt jar@cs.cornell.edu}) \\ -June 1992 -\end{center} - -\vspace{1ex} - -Scheme 48 is an implementation of the Scheme programming language based -on a virtual machine architecture. The following is an overview of -the project. - -\paragraph{Goals} - -\begin{itemize} -\setlength{\itemsep}{0pt} -\item Straightforward, minimal implementation. -\item Flexible experimental apparatus for research in programming - language design and implementation. -\item Easy to make changes to internal data representations, memory - management, and compilation strategy. -\item High reliability. -\item Fast and complete enough to be a good - development environment for Scheme programs. -\end{itemize} - - -\paragraph{Virtual machine} - -The virtual machine executes a simple byte-code instruction set -similar to the target of the Scheme 311 compiler [Clinger, LFP 1984]. -The interpreter for the virtual instruction set is itself written in -PreScheme, a systems programming dialect of Scheme. A PreScheme -compiler applies intensive source-to-source rewrites to the -interpreter source code and emits low-level C code. When the output -is then compiled by an optimizing C compiler such as gcc, the result -is a very efficient and portable emulator. - -\paragraph{Run-time system} - -The virtual machine is initialized from a specified memory image -containing byte-compiled Scheme code and data. Images (including -small stand-alone applications) are built either by a linker or by -writing out the state of an executing program. A standard memory -image contains a Scheme run-time library ({\tt append}, {\tt read}, -{\tt write}, etc.), a compiler from Scheme to the virtual instruction -set, and a command processor and debugger. In this way Scheme 48 can -be configured to look like a conventional Lisp interpreter. - -In addition to the Scheme run-time library and development -environment, library software includes support for multitasking, -modules (packages), hygienic macros (as described in the Revised$^4$ -Scheme report), records, and exception handling. - -\paragraph{Applications} - -The Scheme 48 system is being used at several sites for research in -memory management, embedded systems, multiprocessing, and computer -system verification. Scheme 48 was chosen as the platform for these -projects because of its internal tractability and flexibility. - -\end{document} diff --git a/doc/threads.txt b/doc/threads.txt deleted file mode 100644 index b9fca46..0000000 --- a/doc/threads.txt +++ /dev/null @@ -1,113 +0,0 @@ - - Threads - - -The following are exported by the THREADS structure. - -(WITH-MULTITASKING thunk) - Initializes for multitasking, then starts up a thread for the execution - of . That thread and all others created will run in the dynamic - context of the call to with-multitasking. The call to with-multitasking - finally returns only when the scheduler runs out of things to do. - -(SPAWN thunk) => thread - Create and schedule a new thread that will execute . - -(MAKE-LOCK) => lock -(WITH-LOCK lock thunk) => whatever returns -(OBTAIN-LOCK lock) -(RELEASE-LOCK lock) - Locks are semaphores. - -(MAKE-CONDVAR) => condvar -(CONDVAR-REF condvar) => value of condvar -(CONDVAR-SET! condvar value) - Condition variables. Attempts to reference a condition variable before - it has been set cause the referencing thread to block. Setting a - condition variable to two different values is an error. - -(RELINQUISH-TIMESLICE) - Let other threads run for a while. - -ONE-SECOND - The number of time units in one second. - -(SLEEP time) - Sleep for