From 420afe81f45a7ad351dfc2275e9e663642d3cb44 Mon Sep 17 00:00:00 2001 From: cvs2svn Date: Fri, 17 Apr 1987 08:02:28 +0000 Subject: [PATCH] This commit was manufactured by cvs2svn to create branch 'unlabeled-1.1.1'. --- v7/src/compiler/back/asmmac.scm | 105 - v7/src/compiler/back/lapgn1.scm | 301 --- v7/src/compiler/back/regmap.scm | 534 ----- v7/src/compiler/back/symtab.scm | 81 - v7/src/compiler/back/syntax.scm | 199 -- v7/src/compiler/base/cfg1.scm | 541 ----- v7/src/compiler/base/ctypes.scm | 103 - v7/src/compiler/base/macros.scm | 251 --- v7/src/compiler/base/mvalue.scm | 81 - v7/src/compiler/base/object.scm | 130 -- v7/src/compiler/base/pmlook.scm | 92 - v7/src/compiler/base/sets.scm | 121 -- v7/src/compiler/base/utils.scm | 294 --- v7/src/compiler/machines/bobcat/assmd.scm | 58 - v7/src/compiler/machines/bobcat/coerce.scm | 82 - v7/src/compiler/machines/bobcat/decls.scm | 110 - v7/src/compiler/machines/bobcat/insmac.scm | 148 -- v7/src/compiler/machines/bobcat/instr1.scm | 394 ---- v7/src/compiler/machines/bobcat/instr2.scm | 340 ---- v7/src/compiler/machines/bobcat/instr3.scm | 361 ---- v7/src/compiler/machines/bobcat/lapgen.scm | 752 ------- v7/src/compiler/machines/bobcat/machin.scm | 207 -- .../compiler/machines/bobcat/make.scm-68040 | 147 -- v7/src/compiler/machines/spectrum/assmd.scm | 58 - v7/src/compiler/machines/spectrum/coerce.scm | 166 -- v7/src/compiler/machines/spectrum/lapgen.scm | 1041 ---------- v7/src/compiler/machines/spectrum/machin.scm | 183 -- v7/src/compiler/machines/spectrum/make.scm | 131 -- v7/src/compiler/rtlbase/rtlcfg.scm | 82 - v7/src/compiler/rtlbase/rtlreg.scm | 66 - v7/src/compiler/rtlbase/rtlty1.scm | 172 -- v7/src/compiler/rtlgen/rgcomb.scm | 548 ----- v7/src/compiler/rtlgen/rtlgen.scm | 479 ----- v7/src/compiler/rtlopt/ralloc.scm | 126 -- v7/src/compiler/rtlopt/rcse1.scm | 552 ----- v7/src/compiler/rtlopt/rcseep.scm | 108 - v7/src/compiler/rtlopt/rcseht.scm | 173 -- v7/src/compiler/rtlopt/rcserq.scm | 67 - v7/src/compiler/rtlopt/rcsesr.scm | 84 - v7/src/compiler/rtlopt/rlife.scm | 277 --- v7/src/microcode/array.c | 1153 ----------- v7/src/microcode/array.h | 187 -- v7/src/microcode/bchdmp.c | 102 - v7/src/microcode/bchgcc.h | 53 - v7/src/microcode/bchgcl.c | 251 --- v7/src/microcode/bchmmg.c | 677 ------- v7/src/microcode/bchpur.c | 64 - v7/src/microcode/bignum.c | 1101 ---------- v7/src/microcode/bignum.h | 178 -- v7/src/microcode/bintopsb.c | 838 -------- v7/src/microcode/bitstr.c | 850 -------- v7/src/microcode/bkpt.c | 103 - v7/src/microcode/bkpt.h | 101 - v7/src/microcode/boot.c | 586 ------ v7/src/microcode/breakup.c | 169 -- v7/src/microcode/char.c | 329 --- v7/src/microcode/config.h | 449 ----- v7/src/microcode/const.h | 170 -- v7/src/microcode/daemon.c | 178 -- v7/src/microcode/debug.c | 733 ------- v7/src/microcode/default.h | 295 --- v7/src/microcode/dmpwrld.c | 246 --- v7/src/microcode/dump.c | 85 - v7/src/microcode/errors.h | 128 -- v7/src/microcode/extern.c | 95 - v7/src/microcode/extern.h | 197 -- v7/src/microcode/fasdump.c | 338 ---- v7/src/microcode/fasl.h | 93 - v7/src/microcode/fasload.c | 650 ------ v7/src/microcode/fft.c | 674 ------- v7/src/microcode/fhooks.c | 319 --- v7/src/microcode/findprim.c | 711 ------- v7/src/microcode/fixnum.c | 243 --- v7/src/microcode/fixobj.h | 75 - v7/src/microcode/flonum.c | 301 --- v7/src/microcode/future.c | 357 ---- v7/src/microcode/futures.h | 194 -- v7/src/microcode/gc.h | 102 - v7/src/microcode/gccode.h | 358 ---- v7/src/microcode/gcloop.c | 150 -- v7/src/microcode/gctype.c | 187 -- v7/src/microcode/generic.c | 954 --------- v7/src/microcode/history.h | 146 -- v7/src/microcode/hooks.c | 692 ------- v7/src/microcode/hunk.c | 168 -- v7/src/microcode/image.c | 1197 ----------- v7/src/microcode/image.h | 48 - v7/src/microcode/intercom.c | 230 --- v7/src/microcode/intern.c | 283 --- v7/src/microcode/interp.c | 1780 ----------------- v7/src/microcode/interp.h | 407 ---- v7/src/microcode/list.c | 300 --- v7/src/microcode/load.c | 133 -- v7/src/microcode/locks.h | 47 - v7/src/microcode/lookup.h | 252 --- v7/src/microcode/memmag.c | 412 ---- v7/src/microcode/missing.c | 150 -- v7/src/microcode/mul.c | 81 - v7/src/microcode/object.h | 244 --- v7/src/microcode/pagesize.h | 25 - v7/src/microcode/ppband.c | 268 --- v7/src/microcode/prim.c | 293 --- v7/src/microcode/prim.h | 62 - v7/src/microcode/prims.h | 195 -- v7/src/microcode/primutl.c | 262 --- v7/src/microcode/pruxfs.c | 91 - v7/src/microcode/psbmap.h | 268 --- v7/src/microcode/psbtobin.c | 622 ------ v7/src/microcode/purify.c | 399 ---- v7/src/microcode/purutl.c | 301 --- v7/src/microcode/returns.h | 118 -- v7/src/microcode/sample.c | 215 -- v7/src/microcode/scheme.h | 90 - v7/src/microcode/scode.h | 189 -- v7/src/microcode/sdata.h | 412 ---- v7/src/microcode/stack.h | 335 ---- v7/src/microcode/step.c | 155 -- v7/src/microcode/storage.c | 241 --- v7/src/microcode/string.c | 495 ----- v7/src/microcode/sysprim.c | 188 -- v7/src/microcode/trap.h | 97 - v7/src/microcode/types.h | 111 - v7/src/microcode/unexec.c | 1052 ---------- v7/src/microcode/usrdef.h | 45 - v7/src/microcode/utabmd.scm | 857 -------- v7/src/microcode/utils.c | 1030 ---------- v7/src/microcode/vector.c | 280 --- v7/src/microcode/version.h | 54 - v7/src/microcode/winder.h | 51 - v7/src/microcode/wsize.c | 138 -- v7/src/microcode/xdebug.c | 227 --- v7/src/microcode/zones.h | 87 - v7/src/runtime/advice.scm | 469 ----- v7/src/runtime/bitstr.scm | 86 - v7/src/runtime/boot.scm | 142 -- v7/src/runtime/char.scm | 378 ---- v7/src/runtime/datime.scm | 120 -- v7/src/runtime/debug.scm | 545 ----- v7/src/runtime/emacs.scm | 170 -- v7/src/runtime/equals.scm | 92 - v7/src/runtime/error.scm | 512 ----- v7/src/runtime/events.scm | 97 - v7/src/runtime/format.scm | 351 ---- v7/src/runtime/gc.scm | 204 -- v7/src/runtime/gcstat.scm | 272 --- v7/src/runtime/gensym.scm | 71 - v7/src/runtime/hash.scm | 239 --- v7/src/runtime/histry.scm | 254 --- v7/src/runtime/input.scm | 546 ----- v7/src/runtime/intrpt.scm | 255 --- v7/src/runtime/io.scm | 205 -- v7/src/runtime/lambda.scm | 522 ----- v7/src/runtime/list.scm | 468 ----- v7/src/runtime/msort.scm | 102 - v7/src/runtime/numpar.scm | 282 --- v7/src/runtime/output.scm | 326 --- v7/src/runtime/parse.scm | 476 ----- v7/src/runtime/pathnm.scm | 247 --- v7/src/runtime/pp.scm | 465 ----- v7/src/runtime/qsort.scm | 95 - v7/src/runtime/rep.scm | 330 --- v7/src/runtime/scan.scm | 213 -- v7/src/runtime/scode.scm | 351 ---- v7/src/runtime/scomb.scm | 368 ---- v7/src/runtime/sdata.scm | 233 --- v7/src/runtime/sfile.scm | 68 - v7/src/runtime/stream.scm | 184 -- v7/src/runtime/string.scm | 424 ---- v7/src/runtime/syntax.scm | 1015 ---------- v7/src/runtime/sysclk.scm | 94 - v7/src/runtime/system.scm | 280 --- v7/src/runtime/unpars.scm | 304 --- v7/src/runtime/unsyn.scm | 485 ----- v7/src/runtime/unxpth.scm | 314 --- v7/src/runtime/utabs.scm | 349 ---- v7/src/runtime/vector.scm | 165 -- v7/src/runtime/where.scm | 258 --- v7/src/runtime/wind.scm | 99 - v7/src/sf/cgen.scm | 195 -- v7/src/sf/chtype.scm | 137 -- v7/src/sf/copy.scm | 277 --- v7/src/sf/emodel.scm | 59 - v7/src/sf/free.scm | 128 -- v7/src/sf/gconst.scm | 119 -- v7/src/sf/make.scm | 118 -- v7/src/sf/object.scm | 257 --- v7/src/sf/pardec.scm | 307 --- v7/src/sf/subst.scm | 515 ----- v7/src/sf/tables.scm | 89 - v7/src/sf/toplev.scm | 355 ---- v7/src/sf/usicon.scm | 60 - v7/src/sf/usiexp.scm | 307 --- v7/src/sf/xform.scm | 265 --- v8/src/microcode/bintopsb.c | 838 -------- v8/src/microcode/const.h | 170 -- v8/src/microcode/fasl.h | 93 - v8/src/microcode/fixobj.h | 75 - v8/src/microcode/gctype.c | 187 -- v8/src/microcode/interp.c | 1780 ----------------- v8/src/microcode/lookup.h | 252 --- v8/src/microcode/mul.c | 81 - v8/src/microcode/object.h | 244 --- v8/src/microcode/ppband.c | 268 --- v8/src/microcode/psbmap.h | 268 --- v8/src/microcode/psbtobin.c | 622 ------ v8/src/microcode/returns.h | 118 -- v8/src/microcode/trap.h | 97 - v8/src/microcode/types.h | 111 - v8/src/microcode/utabmd.scm | 857 -------- v8/src/microcode/version.h | 54 - v8/src/sf/make.scm | 118 -- v8/src/sf/toplev.scm | 355 ---- 212 files changed, 63893 deletions(-) delete mode 100644 v7/src/compiler/back/asmmac.scm delete mode 100644 v7/src/compiler/back/lapgn1.scm delete mode 100644 v7/src/compiler/back/regmap.scm delete mode 100644 v7/src/compiler/back/symtab.scm delete mode 100644 v7/src/compiler/back/syntax.scm delete mode 100644 v7/src/compiler/base/cfg1.scm delete mode 100644 v7/src/compiler/base/ctypes.scm delete mode 100644 v7/src/compiler/base/macros.scm delete mode 100644 v7/src/compiler/base/mvalue.scm delete mode 100644 v7/src/compiler/base/object.scm delete mode 100644 v7/src/compiler/base/pmlook.scm delete mode 100644 v7/src/compiler/base/sets.scm delete mode 100644 v7/src/compiler/base/utils.scm delete mode 100644 v7/src/compiler/machines/bobcat/assmd.scm delete mode 100644 v7/src/compiler/machines/bobcat/coerce.scm delete mode 100644 v7/src/compiler/machines/bobcat/decls.scm delete mode 100644 v7/src/compiler/machines/bobcat/insmac.scm delete mode 100644 v7/src/compiler/machines/bobcat/instr1.scm delete mode 100644 v7/src/compiler/machines/bobcat/instr2.scm delete mode 100644 v7/src/compiler/machines/bobcat/instr3.scm delete mode 100644 v7/src/compiler/machines/bobcat/lapgen.scm delete mode 100644 v7/src/compiler/machines/bobcat/machin.scm delete mode 100644 v7/src/compiler/machines/bobcat/make.scm-68040 delete mode 100644 v7/src/compiler/machines/spectrum/assmd.scm delete mode 100644 v7/src/compiler/machines/spectrum/coerce.scm delete mode 100644 v7/src/compiler/machines/spectrum/lapgen.scm delete mode 100644 v7/src/compiler/machines/spectrum/machin.scm delete mode 100644 v7/src/compiler/machines/spectrum/make.scm delete mode 100644 v7/src/compiler/rtlbase/rtlcfg.scm delete mode 100644 v7/src/compiler/rtlbase/rtlreg.scm delete mode 100644 v7/src/compiler/rtlbase/rtlty1.scm delete mode 100644 v7/src/compiler/rtlgen/rgcomb.scm delete mode 100644 v7/src/compiler/rtlgen/rtlgen.scm delete mode 100644 v7/src/compiler/rtlopt/ralloc.scm delete mode 100644 v7/src/compiler/rtlopt/rcse1.scm delete mode 100644 v7/src/compiler/rtlopt/rcseep.scm delete mode 100644 v7/src/compiler/rtlopt/rcseht.scm delete mode 100644 v7/src/compiler/rtlopt/rcserq.scm delete mode 100644 v7/src/compiler/rtlopt/rcsesr.scm delete mode 100644 v7/src/compiler/rtlopt/rlife.scm delete mode 100644 v7/src/microcode/array.c delete mode 100644 v7/src/microcode/array.h delete mode 100644 v7/src/microcode/bchdmp.c delete mode 100644 v7/src/microcode/bchgcc.h delete mode 100644 v7/src/microcode/bchgcl.c delete mode 100644 v7/src/microcode/bchmmg.c delete mode 100644 v7/src/microcode/bchpur.c delete mode 100644 v7/src/microcode/bignum.c delete mode 100644 v7/src/microcode/bignum.h delete mode 100644 v7/src/microcode/bintopsb.c delete mode 100644 v7/src/microcode/bitstr.c delete mode 100644 v7/src/microcode/bkpt.c delete mode 100644 v7/src/microcode/bkpt.h delete mode 100644 v7/src/microcode/boot.c delete mode 100644 v7/src/microcode/breakup.c delete mode 100644 v7/src/microcode/char.c delete mode 100644 v7/src/microcode/config.h delete mode 100644 v7/src/microcode/const.h delete mode 100644 v7/src/microcode/daemon.c delete mode 100644 v7/src/microcode/debug.c delete mode 100644 v7/src/microcode/default.h delete mode 100644 v7/src/microcode/dmpwrld.c delete mode 100644 v7/src/microcode/dump.c delete mode 100644 v7/src/microcode/errors.h delete mode 100644 v7/src/microcode/extern.c delete mode 100644 v7/src/microcode/extern.h delete mode 100644 v7/src/microcode/fasdump.c delete mode 100644 v7/src/microcode/fasl.h delete mode 100644 v7/src/microcode/fasload.c delete mode 100644 v7/src/microcode/fft.c delete mode 100644 v7/src/microcode/fhooks.c delete mode 100644 v7/src/microcode/findprim.c delete mode 100644 v7/src/microcode/fixnum.c delete mode 100644 v7/src/microcode/fixobj.h delete mode 100644 v7/src/microcode/flonum.c delete mode 100644 v7/src/microcode/future.c delete mode 100644 v7/src/microcode/futures.h delete mode 100644 v7/src/microcode/gc.h delete mode 100644 v7/src/microcode/gccode.h delete mode 100644 v7/src/microcode/gcloop.c delete mode 100644 v7/src/microcode/gctype.c delete mode 100644 v7/src/microcode/generic.c delete mode 100644 v7/src/microcode/history.h delete mode 100644 v7/src/microcode/hooks.c delete mode 100644 v7/src/microcode/hunk.c delete mode 100644 v7/src/microcode/image.c delete mode 100644 v7/src/microcode/image.h delete mode 100644 v7/src/microcode/intercom.c delete mode 100644 v7/src/microcode/intern.c delete mode 100644 v7/src/microcode/interp.c delete mode 100644 v7/src/microcode/interp.h delete mode 100644 v7/src/microcode/list.c delete mode 100644 v7/src/microcode/load.c delete mode 100644 v7/src/microcode/locks.h delete mode 100644 v7/src/microcode/lookup.h delete mode 100644 v7/src/microcode/memmag.c delete mode 100644 v7/src/microcode/missing.c delete mode 100644 v7/src/microcode/mul.c delete mode 100644 v7/src/microcode/object.h delete mode 100644 v7/src/microcode/pagesize.h delete mode 100644 v7/src/microcode/ppband.c delete mode 100644 v7/src/microcode/prim.c delete mode 100644 v7/src/microcode/prim.h delete mode 100644 v7/src/microcode/prims.h delete mode 100644 v7/src/microcode/primutl.c delete mode 100644 v7/src/microcode/pruxfs.c delete mode 100644 v7/src/microcode/psbmap.h delete mode 100644 v7/src/microcode/psbtobin.c delete mode 100644 v7/src/microcode/purify.c delete mode 100644 v7/src/microcode/purutl.c delete mode 100644 v7/src/microcode/returns.h delete mode 100644 v7/src/microcode/sample.c delete mode 100644 v7/src/microcode/scheme.h delete mode 100644 v7/src/microcode/scode.h delete mode 100644 v7/src/microcode/sdata.h delete mode 100644 v7/src/microcode/stack.h delete mode 100644 v7/src/microcode/step.c delete mode 100644 v7/src/microcode/storage.c delete mode 100644 v7/src/microcode/string.c delete mode 100644 v7/src/microcode/sysprim.c delete mode 100644 v7/src/microcode/trap.h delete mode 100644 v7/src/microcode/types.h delete mode 100644 v7/src/microcode/unexec.c delete mode 100644 v7/src/microcode/usrdef.h delete mode 100644 v7/src/microcode/utabmd.scm delete mode 100644 v7/src/microcode/utils.c delete mode 100644 v7/src/microcode/vector.c delete mode 100644 v7/src/microcode/version.h delete mode 100644 v7/src/microcode/winder.h delete mode 100644 v7/src/microcode/wsize.c delete mode 100644 v7/src/microcode/xdebug.c delete mode 100644 v7/src/microcode/zones.h delete mode 100644 v7/src/runtime/advice.scm delete mode 100644 v7/src/runtime/bitstr.scm delete mode 100644 v7/src/runtime/boot.scm delete mode 100644 v7/src/runtime/char.scm delete mode 100644 v7/src/runtime/datime.scm delete mode 100644 v7/src/runtime/debug.scm delete mode 100644 v7/src/runtime/emacs.scm delete mode 100644 v7/src/runtime/equals.scm delete mode 100644 v7/src/runtime/error.scm delete mode 100644 v7/src/runtime/events.scm delete mode 100644 v7/src/runtime/format.scm delete mode 100644 v7/src/runtime/gc.scm delete mode 100644 v7/src/runtime/gcstat.scm delete mode 100644 v7/src/runtime/gensym.scm delete mode 100644 v7/src/runtime/hash.scm delete mode 100644 v7/src/runtime/histry.scm delete mode 100644 v7/src/runtime/input.scm delete mode 100644 v7/src/runtime/intrpt.scm delete mode 100644 v7/src/runtime/io.scm delete mode 100644 v7/src/runtime/lambda.scm delete mode 100644 v7/src/runtime/list.scm delete mode 100644 v7/src/runtime/msort.scm delete mode 100644 v7/src/runtime/numpar.scm delete mode 100644 v7/src/runtime/output.scm delete mode 100644 v7/src/runtime/parse.scm delete mode 100644 v7/src/runtime/pathnm.scm delete mode 100644 v7/src/runtime/pp.scm delete mode 100644 v7/src/runtime/qsort.scm delete mode 100644 v7/src/runtime/rep.scm delete mode 100644 v7/src/runtime/scan.scm delete mode 100644 v7/src/runtime/scode.scm delete mode 100644 v7/src/runtime/scomb.scm delete mode 100644 v7/src/runtime/sdata.scm delete mode 100644 v7/src/runtime/sfile.scm delete mode 100644 v7/src/runtime/stream.scm delete mode 100644 v7/src/runtime/string.scm delete mode 100644 v7/src/runtime/syntax.scm delete mode 100644 v7/src/runtime/sysclk.scm delete mode 100644 v7/src/runtime/system.scm delete mode 100644 v7/src/runtime/unpars.scm delete mode 100644 v7/src/runtime/unsyn.scm delete mode 100644 v7/src/runtime/unxpth.scm delete mode 100644 v7/src/runtime/utabs.scm delete mode 100644 v7/src/runtime/vector.scm delete mode 100644 v7/src/runtime/where.scm delete mode 100644 v7/src/runtime/wind.scm delete mode 100644 v7/src/sf/cgen.scm delete mode 100644 v7/src/sf/chtype.scm delete mode 100644 v7/src/sf/copy.scm delete mode 100644 v7/src/sf/emodel.scm delete mode 100644 v7/src/sf/free.scm delete mode 100644 v7/src/sf/gconst.scm delete mode 100644 v7/src/sf/make.scm delete mode 100644 v7/src/sf/object.scm delete mode 100644 v7/src/sf/pardec.scm delete mode 100644 v7/src/sf/subst.scm delete mode 100644 v7/src/sf/tables.scm delete mode 100644 v7/src/sf/toplev.scm delete mode 100644 v7/src/sf/usicon.scm delete mode 100644 v7/src/sf/usiexp.scm delete mode 100644 v7/src/sf/xform.scm delete mode 100644 v8/src/microcode/bintopsb.c delete mode 100644 v8/src/microcode/const.h delete mode 100644 v8/src/microcode/fasl.h delete mode 100644 v8/src/microcode/fixobj.h delete mode 100644 v8/src/microcode/gctype.c delete mode 100644 v8/src/microcode/interp.c delete mode 100644 v8/src/microcode/lookup.h delete mode 100644 v8/src/microcode/mul.c delete mode 100644 v8/src/microcode/object.h delete mode 100644 v8/src/microcode/ppband.c delete mode 100644 v8/src/microcode/psbmap.h delete mode 100644 v8/src/microcode/psbtobin.c delete mode 100644 v8/src/microcode/returns.h delete mode 100644 v8/src/microcode/trap.h delete mode 100644 v8/src/microcode/types.h delete mode 100644 v8/src/microcode/utabmd.scm delete mode 100644 v8/src/microcode/version.h delete mode 100644 v8/src/sf/make.scm delete mode 100644 v8/src/sf/toplev.scm diff --git a/v7/src/compiler/back/asmmac.scm b/v7/src/compiler/back/asmmac.scm deleted file mode 100644 index ef75dd962..000000000 --- a/v7/src/compiler/back/asmmac.scm +++ /dev/null @@ -1,105 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/asmmac.scm,v 1.2 1987/03/19 00:49:46 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Assembler Syntax Macros - -(declare (usual-integrations)) - -(syntax-table-define assembler-syntax-table 'DEFINE-INSTRUCTION - (macro (keyword . rules) - `(ADD-INSTRUCTION! - ',keyword - ,(compile-database rules - (lambda (pattern actions) - (if (null? actions) - (error "DEFINE-INSTRUCTION: Too few forms") - (parse-word (car actions) (cdr actions)))))))) - -(define (compile-database cases procedure) - `(LIST - ,@(map (lambda (case) - (parse-rule (car case) (cdr case) - (lambda (pattern names transformer qualifier actions) - `(CONS ',pattern - ,(rule-result-expression names - transformer - qualifier - (procedure pattern - actions)))))) - cases))) - -;;;; Group Optimization - -(define optimize-group-syntax - (let () - (define (find-constant components) - (cond ((null? components) - '()) - ((car-constant? components) - (compact (car-constant-value components) - (cdr components))) - (else - (cons (car components) - (find-constant (cdr components)))))) - - (define (compact bit-string components) - (cond ((null? components) - (cons (make-constant bit-string) '())) - ((car-constant? components) - (compact (bit-string-append (car-constant-value components) - bit-string) - (cdr components))) - (else - (cons (make-constant bit-string) - (cons (car components) - (find-constant (cdr components))))))) - - (define-integrable (car-constant? expression) - (and (eq? (caar expression) 'QUOTE) - (bit-string? (cadar expression)))) - - (define-integrable (car-constant-value constant) - (cadar constant)) - - (define-integrable (make-constant bit-string) - `',bit-string) - - (lambda components - (let ((components (find-constant components))) - (cond ((null? components) - (error "OPTIMIZE-GROUP-SYNTAX: No components in group!")) - ((null? (cdr components)) - (car components)) - (else - `(OPTIMIZE-GROUP ,@components))))))) \ No newline at end of file diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm deleted file mode 100644 index 82c6691c6..000000000 --- a/v7/src/compiler/back/lapgn1.scm +++ /dev/null @@ -1,301 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.26 1987/03/19 00:50:04 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; LAP Code Generation - -(declare (usual-integrations)) - -(define *block-start-label*) -(define *code-object-label*) -(define *code-object-entry*) -(define *current-rnode*) -(define *dead-registers*) - -(define (generate-lap quotations procedures continuations receiver) - (with-new-node-marks - (lambda () - (fluid-let ((*next-constant* 0) - (*interned-constants* '()) - (*block-start-label* (generate-label)) - (*code-object-label*) - (*code-object-entry*)) - (for-each (lambda (quotation) - (cgen-entry quotation quotation-rtl-entry)) - quotations) - (for-each (lambda (procedure) - (cgen-entry procedure procedure-rtl-entry)) - procedures) - (for-each (lambda (continuation) - (cgen-entry continuation continuation-rtl-entry)) - continuations) - (receiver *interned-constants* *block-start-label*))))) - -(define (cgen-entry object extract-entry) - (set! *code-object-label* (code-object-label-initialize object)) - (let ((rnode (extract-entry object))) - (set! *code-object-entry* rnode) - (cgen-rnode rnode))) - -(define *cgen-rules* - '()) - -(define (add-statement-rule! pattern result-procedure) - (set! *cgen-rules* - (cons (cons pattern result-procedure) - *cgen-rules*)) - pattern) - -(define (cgen-rnode rnode) - (define (cgen-right-node edge) - (let ((next (edge-next-node edge))) - (if (and next (not (node-marked? next))) - (begin (if (node-previous>1? next) - (let ((snode (statement->snode '(NOOP)))) - (set-rnode-lap! snode - (clear-map-instructions - (rnode-register-map rnode))) - (node-mark! snode) - (edge-insert-snode! edge snode))) - (cgen-rnode next))))) - (node-mark! rnode) - ;; LOOP is for easy restart while debugging. - (let loop () - (let ((match-result (pattern-lookup *cgen-rules* (rnode-rtl rnode)))) - (if match-result - (fluid-let ((*current-rnode* rnode) - (*dead-registers* (rnode-dead-registers rnode)) - (*register-map* (rnode-input-register-map rnode)) - (*prefix-instructions* '()) - (*needed-registers* '())) - (let ((instructions (match-result))) - (set-rnode-lap! rnode - (append! *prefix-instructions* instructions))) - (delete-dead-registers!) - (set-rnode-register-map! rnode *register-map*)) - (begin (error "CGEN-RNODE: No matching rules" (rnode-rtl rnode)) - (loop))))) - (if (rtl-snode? rnode) - (cgen-right-node (snode-next-edge rnode)) - (begin (cgen-right-node (pnode-consequent-edge rnode)) - (cgen-right-node (pnode-alternative-edge rnode))))) - -(define (rnode-input-register-map rnode) - (if (or (eq? rnode *code-object-entry*) - (not (node-previous=1? rnode))) - (empty-register-map) - (let ((previous (node-previous-first rnode))) - (let ((map (rnode-register-map previous))) - (if (rtl-pnode? previous) - (delete-pseudo-registers - map - (regset->list - (regset-difference - (bblock-live-at-exit (node-bblock previous)) - (bblock-live-at-entry (node-bblock rnode)))) - (lambda (map aliases) map)) - map))))) - -;;;; Machine independent stuff - -(define *register-map*) -(define *prefix-instructions*) -(define *needed-registers*) - -(define-integrable (prefix-instructions! instructions) - (set! *prefix-instructions* (append! *prefix-instructions* instructions))) - -(define-integrable (need-register! register) - (set! *needed-registers* (cons register *needed-registers*))) - -(define (maybe-need-register! register) - (if register (need-register! register)) - register) - -(define-integrable (register-alias register type) - (maybe-need-register! (pseudo-register-alias *register-map* type register))) - -(define-integrable (register-alias-alternate register type) - (maybe-need-register! (machine-register-alias *register-map* type register))) - -(define-integrable (register-type? register type) - (or (not type) - (eq? (register-type register) type))) - -(define ((register-type-predicate type) register) - (register-type? register type)) - -(define-integrable (dead-register? register) - (memv register *dead-registers*)) - -(define (guarantee-machine-register! register type) - (if (and (machine-register? register) - (register-type? register type)) - register - (load-alias-register! register type))) - -(define (load-alias-register! register type) - (bind-allocator-values (load-alias-register *register-map* type - *needed-registers* register) - store-allocator-values!)) - -(define (allocate-alias-register! register type) - (bind-allocator-values (allocate-alias-register *register-map* type - *needed-registers* register) - (lambda (alias map instructions) - (store-allocator-values! alias - (delete-other-locations map alias) - instructions)))) - -(define (allocate-assignment-alias! target type) - (let ((target (allocate-alias-register! target type))) - (delete-dead-registers!) - target)) - -(define (allocate-temporary-register! type) - (bind-allocator-values (allocate-temporary-register *register-map* type - *needed-registers*) - store-allocator-values!)) - -(define (store-allocator-values! alias map instructions) - (need-register! alias) - (set! *register-map* map) - (prefix-instructions! instructions) - alias) - -(define (move-to-alias-register! source type target) - (reuse-pseudo-register-alias! source type - (lambda (reusable-alias) - (add-pseudo-register-alias! target reusable-alias)) - (lambda () - (allocate-alias-register! target type)))) - -(define (move-to-temporary-register! source type) - (reuse-pseudo-register-alias! source type - need-register! - (lambda () - (allocate-temporary-register! type)))) - -(define (reuse-pseudo-register-alias! source type if-reusable if-not) - ;; IF-NOT is assumed to return a machine register. - (let ((reusable-alias - (and (dead-register? source) - (register-alias source type)))) - (if reusable-alias - (begin (delete-dead-registers!) - (if-reusable reusable-alias) - (register-reference reusable-alias)) - (let ((alias (if (machine-register? source) - source - (register-alias source false)))) - (delete-dead-registers!) - (let ((target (if-not))) - (prefix-instructions! - (if alias - (register->register-transfer alias target) - (home->register-transfer source target))) - (register-reference target)))))) - -(define (add-pseudo-register-alias! register alias) - (set! *register-map* - (add-pseudo-register-alias *register-map* register alias)) - (need-register! alias)) - -(define (clear-map!) - (delete-dead-registers!) - (let ((instructions (clear-map))) - (set! *register-map* (empty-register-map)) - (set! *needed-registers* '()) - instructions)) - -(define-integrable (clear-map) - (clear-map-instructions *register-map*)) - -(define (clear-registers! . registers) - (if (null? registers) - '() - (let loop ((map *register-map*) (registers registers)) - (save-machine-register map (car registers) - (lambda (map instructions) - (let ((map (delete-machine-register map (car registers)))) - (if (null? (cdr registers)) - (begin (set! *register-map* map) - instructions) - (append! instructions (loop map (cdr registers)))))))))) - -(define (save-machine-register! register) - (let ((contents (machine-register-contents *register-map* register))) - (if contents - (save-pseudo-register! contents)))) - -(define (save-pseudo-register! register) - (if (not (dead-register? register)) - (save-pseudo-register *register-map* register - (lambda (map instructions) - (set! *register-map* map) - (prefix-instructions! instructions))))) - -(define (delete-machine-register! register) - (set! *register-map* (delete-machine-register *register-map* register)) - (set! *needed-registers* (eqv-set-delete *needed-registers* register))) - -(package (delete-pseudo-register! delete-dead-registers!) - (define-export (delete-pseudo-register! register) - (delete-pseudo-register *register-map* register delete-registers!)) - (define-export (delete-dead-registers!) - (delete-pseudo-registers *register-map* *dead-registers* delete-registers!) - (set! *dead-registers* '())) - (define (delete-registers! map aliases) - (set! *register-map* map) - (set! *needed-registers* (eqv-set-difference *needed-registers* aliases)))) - -(define *next-constant*) -(define *interned-constants*) - -(define (constant->label constant) - (let ((entry (assv constant *interned-constants*))) - (if entry - (cdr entry) - (let ((label - (string->symbol - (string-append "CONSTANT-" - (write-to-string *next-constant*))))) - (set! *next-constant* (1+ *next-constant*)) - (set! *interned-constants* - (cons (cons constant label) - *interned-constants*)) - label)))) - -(define-integrable (set-current-branches! consequent alternative) - (set-rtl-pnode-consequent-lap-generator! *current-rnode* consequent) - pattern) \ No newline at end of file diff --git a/v7/src/compiler/back/regmap.scm b/v7/src/compiler/back/regmap.scm deleted file mode 100644 index e413bde2c..000000000 --- a/v7/src/compiler/back/regmap.scm +++ /dev/null @@ -1,534 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/regmap.scm,v 1.87 1987/03/19 00:50:25 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Register Allocator - -(declare (usual-integrations)) - -#| - -The register allocator provides a mechanism for allocating and -deallocating machine registers. It manages the available machine -registers as a cache, by maintaining a ``map'' which records two kinds -of information: (1) a list of the machine registers which are not in -use; and (2) a mapping which is the association between the allocated -machine registers and the ``pseudo registers'' which they represent. - -An ``alias'' is a machine register which also holds the contents of a -pseudo register. Usually an alias is used for a short period of time, -as a store-in cache, and then eventually the contents of the alias is -written back out to the home it is associated with. Because of the -lifetime analysis, it is possible to identify those registers which -will no longer be referenced; these are deleted from the map when they -die, and thus do not need to be saved. - -A ``temporary'' is a machine register with no associated home. It -is used during the code generation of a single RTL instruction to -hold intermediate results. - -Each pseudo register that has at least one alias has an entry in the -map. While a home is entered in the map, it may have one or more -aliases added or deleted to its entry, but if the number of aliases -ever drops to zero, the entry is removed from the map. - -Each temporary has an entry in the map, with the difference being -that the entry has no pseudo register associated with it. Thus it -need never be written out. - -All registers, both machine and pseudo, are represented by -non-negative integers. Machine registers start at zero (inclusive) -and stop at NUMBER-OF-MACHINE-REGISTERS (exclusive). All others are -pseudo registers. Because they are integers, we can use MEMV on lists -of registers. - -AVAILABLE-MACHINE-REGISTERS should be a list of the registers which -the allocator is allowed to allocate, in the preferred order of -allocation. - -(SORT-MACHINE-REGISTERS REGISTERS) should reorder a list of machine -registers into some interesting sorting order if that is desired. - -(PSEUDO-REGISTER=? X Y) is true iff X and Y are the ``same'' register. -Normally, two pseudo registers are the same if their -REGISTER-RENUMBERs are equal. - -|# - -(define empty-register-map) -(define bind-allocator-values) - -(define load-alias-register) -(define allocate-alias-register) -(define allocate-temporary-register) -(define add-pseudo-register-alias) - -(define machine-register-contents) -(define pseudo-register-aliases) - -(define machine-register-alias) -(define pseudo-register-alias) - -(define save-machine-register) -(define save-pseudo-register) - -(define delete-machine-register) -(define delete-pseudo-register) - -(define delete-pseudo-registers) -(define delete-other-locations) - -(define coerce-map-instructions) -(define clear-map-instructions) - -(define register-allocator-package - (make-environment - -;;;; Register Map - -(define-integrable make-register-map cons) -(define-integrable map-entries car) -(define-integrable map-registers cdr) - -(define-export (empty-register-map) - (make-register-map '() available-machine-registers)) - -(define-integrable (map-entries:search map procedure) - (set-search (map-entries map) procedure)) - -(define (map-entries:find-home map pseudo-register) - (map-entries:search map - (lambda (entry) - (let ((home (map-entry-home entry))) - (and home - (pseudo-register=? home pseudo-register) - entry))))) - -(define (map-entries:find-alias map register) - (map-entries:search map - (lambda (entry) - ;; **** Kludge -- depends on fact that machine registers are - ;; fixnums, and thus EQ? works on them. - (and (memq register (map-entry-aliases entry)) - entry)))) - -(define-integrable (map-entries:add map entry) - (cons entry (map-entries map))) - -(define-integrable (map-entries:delete map entry) - (eq-set-delete (map-entries map) entry)) - -(define-integrable (map-entries:delete* map entries) - (eq-set-difference (map-entries map) entries)) - -(define-integrable (map-entries:replace map old new) - (eq-set-substitute (map-entries map) old new)) - -(define-integrable (map-registers:add map register) - (sort-machine-registers (cons register (map-registers map)))) - -(define-integrable (map-registers:add* map registers) - (sort-machine-registers (append registers (map-registers map)))) - -(define-integrable (map-registers:delete map register) - (eqv-set-delete (map-registers map) register)) - -;;;; Map Entry - -(define-integrable (make-map-entry home saved-into-home? aliases) - ;; HOME may be false, indicating that this is a temporary register. - ;; SAVED-INTO-HOME? must be true when HOME is false. ALIASES must - ;; be a non-null list of registers. - (vector home saved-into-home? aliases)) - -(define-integrable (map-entry-home entry) - (vector-ref entry 0)) - -(define-integrable (map-entry-saved-into-home? entry) - (vector-ref entry 1)) - -(define-integrable (map-entry-aliases entry) - (vector-ref entry 2)) - -(define-integrable (map-entry:any-alias entry) - (car (map-entry-aliases entry))) - -(define (map-entry:add-alias entry alias) - (make-map-entry (map-entry-home entry) - (map-entry-saved-into-home? entry) - (cons alias (map-entry-aliases entry)))) - -(define (map-entry:delete-alias entry alias) - (make-map-entry (map-entry-home entry) - (map-entry-saved-into-home? entry) - (eq-set-delete (map-entry-aliases entry) alias))) - -(define (map-entry=? entry entry*) - (and (map-entry-home entry) - (map-entry-home entry*) - (pseudo-register=? (map-entry-home entry) - (map-entry-home entry*)))) - -;;;; Map Constructors - -;;; These constructors are responsible for maintaining consistency -;;; between the map entries and available registers. - -(define (register-map:add-home map home alias) - (make-register-map (map-entries:add map - (make-map-entry home true (list alias))) - (map-registers:delete map alias))) - -(define (register-map:add-alias map entry alias) - (make-register-map (map-entries:replace map entry - (map-entry:add-alias entry alias)) - (map-registers:delete map alias))) - -(define (register-map:save-entry map entry) - (make-register-map - (map-entries:replace map entry - (make-map-entry (map-entry-home entry) - true - (map-entry-aliases entry))) - (map-registers map))) - -(define (register-map:delete-entry map entry) - (make-register-map (map-entries:delete map entry) - (map-registers:add* map (map-entry-aliases entry)))) - -(define (register-map:delete-entries regmap entries) - (make-register-map (map-entries:delete* regmap entries) - (map-registers:add* regmap - (apply append - (map map-entry-aliases - entries))))) - -(define (register-map:delete-alias map entry alias) - (make-register-map (if (null? (cdr (map-entry-aliases entry))) - (map-entries:delete map entry) - (map-entries:replace map entry - (map-entry:delete-alias entry - alias))) - (map-registers:add map alias))) - -(define (register-map:delete-other-aliases map entry alias) - (make-register-map (map-entries:replace map entry - (let ((home (map-entry-home entry))) - (make-map-entry home (not home) - (list alias)))) - (map-registers:add* map - ;; **** Kludge -- again, EQ? is - ;; assumed to work on machine regs. - (delq alias - (map-entry-aliases entry))))) - -;;;; Register Allocator - -(define (make-free-register map type needed-registers) - (define (reallocate-alias entry) - (let ((alias (find-alias entry))) - (and alias - (delete-alias entry alias '())))) - - (define (find-alias entry) - (list-search-positive (map-entry-aliases entry) - (lambda (alias) - (and (register-type? alias type) - (not (memv alias needed-registers)))))) - - (define (delete-alias entry alias instructions) - (allocator-values alias - (register-map:delete-alias map entry alias) - instructions)) - - (or - ;; First see if there is an unused register of the given type. - (let ((register (list-search-positive (map-registers map) - (register-type-predicate type)))) - (and register - (allocator-values register map '()))) - ;; There are no free registers available, so must reallocate one. - ;; First look for a temporary register that is no longer needed. - (map-entries:search map - (lambda (entry) - (and (not (map-entry-home entry)) - (reallocate-alias entry)))) - ;; Then look for a register which contains the same thing as - ;; another register. - (map-entries:search map - (lambda (entry) - (and (not (null? (cdr (map-entry-aliases entry)))) - (reallocate-alias entry)))) - ;; Look for a non-temporary which has been saved into its home. - (map-entries:search map - (lambda (entry) - (and (map-entry-home entry) - (map-entry-saved-into-home? entry) - (reallocate-alias entry)))) - ;; Finally, save out a non-temporary and reallocate its register. - (map-entries:search map - (lambda (entry) - (and (map-entry-home entry) - (not (map-entry-saved-into-home? entry)) - (let ((alias (find-alias entry))) - (and alias - (delete-alias entry alias - (save-into-home-instruction entry))))))) - ;; Reaching this point indicates all registers are allocated. - (error "MAKE-FREE-REGISTER: Unable to allocate register"))) - -;;;; Allocator Operations - -(let () - -(define-export (load-alias-register map type needed-registers home) - ;; Finds or makes an alias register for HOME, and loads HOME's - ;; contents into that register. - (let ((entry (map-entries:find-home map home))) - (or (use-existing-alias map entry type) - (bind-allocator-values (make-free-register map type needed-registers) - (lambda (alias map instructions) - (if entry - ;; MAKE-FREE-REGISTER will not flush ENTRY because it - ;; has no aliases of the appropriate TYPE. - (allocator-values - alias - (register-map:add-alias map entry alias) - (append! instructions - (register->register-transfer - (map-entry:any-alias entry) - alias))) - (allocator-values - alias - (register-map:add-home map home alias) - (append! instructions - (home->register-transfer home alias))))))))) - -(define-export (allocate-alias-register map type needed-registers home) - ;; Finds or makes an alias register for HOME. Used when about to - ;; modify HOME's contents. - (let ((entry (map-entries:find-home map home))) - (or (use-existing-alias map entry type) - (bind-allocator-values (make-free-register map type needed-registers) - (lambda (alias map instructions) - (allocator-values alias - (if entry - ;; MAKE-FREE-REGISTER will not flush - ;; ENTRY because it has no aliases - ;; of the appropriate TYPE. - (register-map:add-alias map entry alias) - (register-map:add-home map home alias)) - instructions)))))) - -(define (use-existing-alias map entry type) - (and entry - (let ((alias (list-search-positive (map-entry-aliases entry) - (register-type-predicate type)))) - (and alias - (allocator-values alias map '()))))) - -) - -(define-export (allocate-temporary-register map type needed-registers) - (bind-allocator-values (make-free-register map type needed-registers) - (lambda (alias map instructions) - (allocator-values alias - (register-map:add-home map false alias) - instructions)))) - -(define-export (add-pseudo-register-alias map register alias) - (let ((entry (map-entries:find-home map register))) - (if entry - (register-map:add-alias map entry alias) - (register-map:add-home map register alias)))) - -(define-export (machine-register-contents map register) - (let ((entry (map-entries:find-alias map register))) - (and entry - (map-entry-home entry)))) - -(define-export (pseudo-register-aliases map register) - (let ((entry (map-entries:find-home map register))) - (and entry - (map-entry-aliases entry)))) - -(define-export (machine-register-alias map type register) - (let ((entry (map-entries:find-alias map register))) - (and entry - (list-search-positive (map-entry-aliases entry) - (lambda (register*) - (and (not (eq? register register*)) - (register-type? type register*))))))) - -(define-export (pseudo-register-alias map type register) - (let ((entry (map-entries:find-home map register))) - (and entry - (list-search-positive (map-entry-aliases entry) - (register-type-predicate type))))) - -(define-export (save-machine-register map register receiver) - (let ((entry (map-entries:find-alias map register))) - (if (and entry - (not (map-entry-saved-into-home? entry)) - (null? (cdr (map-entry-aliases entry)))) - (receiver (register-map:save-entry map entry) - (save-into-home-instruction entry)) - (receiver map '())))) - -(define-export (save-pseudo-register map register receiver) - (let ((entry (map-entries:find-home map register))) - (if (and entry - (not (map-entry-saved-into-home? entry))) - (receiver (register-map:save-entry map entry) - (save-into-home-instruction entry)) - (receiver map '())))) - -(define-export (delete-machine-register map register) - (let ((entry (map-entries:find-alias map register))) - (if entry - (register-map:delete-alias map entry register) - map))) - -(define-export (delete-pseudo-register map register receiver) - (let ((entry (map-entries:find-home map register))) - (if entry - (receiver (register-map:delete-entry map entry) - (map-entry-aliases entry)) - (receiver map '())))) - -(define-export (delete-pseudo-registers map registers receiver) - ;; Used to remove dead registers from the map. - (let loop ((registers registers) - (receiver - (lambda (entries aliases) - (receiver (register-map:delete-entries map entries) - aliases)))) - (if (null? registers) - (receiver '() '()) - (loop (cdr registers) - (let ((entry (map-entries:find-home map (car registers)))) - (if entry - (lambda (entries aliases) - (receiver (cons entry entries) aliases)) - receiver)))))) - -(define-export (delete-other-locations map register) - ;; Used in assignments to indicate that other locations containing - ;; the same value no longer contain the value for a given home. - (register-map:delete-other-aliases - map - (or (map-entries:find-alias map register) - (error "DELETE-OTHER-LOCATIONS: Missing entry" register)) - register)) - -(define-integrable (allocator-values alias map instructions) - (vector alias map instructions)) - -(define-export (bind-allocator-values values receiver) - (receiver (vector-ref values 0) - (vector-ref values 1) - (vector-ref values 2))) - -(define (save-into-home-instruction entry) - (register->home-transfer (map-entry:any-alias entry) - (map-entry-home entry))) - -;;;; Map Coercion - -;;; These operations generate the instructions to coerce one map into -;;; another. They are used when joining two branches of a control -;;; flow graph which have different maps (e.g. in a loop.) - -(let () - -(define-export (coerce-map-instructions input-map output-map) - (three-way-sort map-entry=? - (map-entries input-map) - (map-entries output-map) - (lambda (input-entries shared-entries output-entries) - ((input-loop input-map - ((shared-loop (output-loop (empty-register-map) - output-entries)) - shared-entries)) - input-entries)))) - -(define-export (clear-map-instructions input-map) - ((input-loop input-map '()) (map-entries input-map))) - -(define (input-loop map tail) - (define (loop entries) - (if (null? entries) - tail - (let ((instructions (loop (cdr entries)))) - (if (map-entry-saved-into-home? (car entries)) - instructions - (append! (save-into-home-instruction (car entries)) - instructions))))) - loop) - -(define (shared-loop tail) - (define (loop entries) - (if (null? entries) - tail - (let ((input-aliases (map-entry-aliases (caar entries)))) - (define (loop output-aliases) - (if (null? output-aliases) - (shared-loop (cdr entries)) - (append! (register->register-transfer (car input-aliases) - (car output-aliases)) - (loop (cdr output-aliases))))) - (loop (eqv-set-difference (map-entry-aliases (cdar entries)) - input-aliases))))) - loop) - -(define (output-loop map entries) - (if (null? entries) - '() - (let ((instructions (output-loop map (cdr entries))) - (home (map-entry-home (car entries)))) - (if home - (let ((aliases (map-entry-aliases (car entries)))) - (define (loop registers) - (if (null? registers) - instructions - (append! (register->register-transfer (car aliases) - (car registers)) - (loop (cdr registers))))) - (append! (home->register-transfer home (car aliases)) - (loop (cdr aliases)))) - instructions)))) - -) - -;;; end REGISTER-ALLOCATOR-PACKAGE -) \ No newline at end of file diff --git a/v7/src/compiler/back/symtab.scm b/v7/src/compiler/back/symtab.scm deleted file mode 100644 index d33c6277b..000000000 --- a/v7/src/compiler/back/symtab.scm +++ /dev/null @@ -1,81 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/symtab.scm,v 1.39 1987/03/19 00:50:36 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Symbol Tables - -(declare (usual-integrations)) - -(define (make-symbol-table) - (cons "Symbol Table" '())) - -(define (symbol-table-define! table key value) - (let ((entry (assq key (cdr table)))) - (if entry - (set-binding-value! (cdr entry) value) - (set-cdr! table (cons (cons key (vector value '())) (cdr table)))))) - -(define (symbol-table-binding table key) - (let ((entry (assq key (cdr table)))) - (if entry - (cdr entry) - (let ((nothing (vector #F '()))) - (set-cdr! table (cons (cons key nothing) (cdr table))) - nothing)))) - -(define (symbol-table-value table key) - (let ((entry (assq key (cdr table)))) - (or (and entry (vector-ref (cdr entry) 0)) - (error "SYMBOL-TABLE-VALUE: Undefined key" key)))) - -(define (symbol-table-undefined-names table) - (let loop ((entries (cdr table))) - (cond ((null? entries) '()) - ((binding-value (cdr (car entries))) (loop (cdr entries))) - (else (cons (car (car entries)) (loop (cdr entries))))))) - -(define-integrable (binding-value binding) - (vector-ref binding 0)) - -(define (set-binding-value! binding value) - (if (vector-ref binding 0) - (error "Attempt to redefine variable" binding)) - (vector-set! binding 0 value) - (for-each (lambda (daemon) (daemon binding)) - (vector-ref binding 1))) - -(define (add-binding-daemon! binding daemon) - (vector-set! binding 1 (cons daemon (vector-ref binding 1)))) - -(define (remove-binding-daemon! binding daemon) - (vector-set! binding 1 (delq! daemon (vector-ref binding 1)))) \ No newline at end of file diff --git a/v7/src/compiler/back/syntax.scm b/v7/src/compiler/back/syntax.scm deleted file mode 100644 index b848e7cc0..000000000 --- a/v7/src/compiler/back/syntax.scm +++ /dev/null @@ -1,199 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syntax.scm,v 1.13 1987/03/19 00:50:43 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; LAP Syntaxer - -(declare (usual-integrations)) - -(define (syntax-instructions instructions) - (convert-output - (let loop ((instructions instructions)) - (if (null? instructions) - '() - (append-syntax! (syntax-instruction (car instructions)) - (loop (cdr instructions))))))) - -(define (convert-output directives) - (map (lambda (directive) - (cond ((bit-string? directive) (vector 'CONSTANT directive)) - ((pair? directive) - (if (eq? (car directive) 'GROUP) - (vector 'GROUP (convert-output (cdr directive))) - (list->vector directive))) - ((vector? directive) directive) - (else - (error "SYNTAX-INSTRUCTIONS: Unknown directive" directive)))) - directives)) - -(define (syntax-instruction instruction) - (if (memq (car instruction) '(EQUATE SCHEME-OBJECT ENTRY-POINT LABEL)) - (list instruction) - (let ((match-result (instruction-lookup instruction))) - (or (and match-result (match-result)) - (error "SYNTAX-INSTRUCTION: Badly formed instruction" - instruction))))) - -(define (instruction-lookup instruction) - (pattern-lookup - (cdr (or (assq (car instruction) instructions) - (error "INSTRUCTION-LOOKUP: Unknown keyword" (car instruction)))) - (cdr instruction))) - -(define (add-instruction! keyword lookup) - (let ((entry (assq keyword instructions))) - (if entry - (set-cdr! entry lookup) - (set! instructions (cons (cons keyword lookup) instructions)))) - keyword) - -(define instructions - '()) - -(define (integer-syntaxer expression coercion-type size) - (let ((coercion (make-coercion-name coercion-type size))) - (if (integer? expression) - `',((lexical-reference coercion-environment coercion) expression) - `(SYNTAX-EVALUATION ,expression ,coercion)))) - -(define (syntax-evaluation expression coercion) - (if (integer? expression) - (coercion expression) - (vector 'EVALUATION expression (coercion-size coercion) coercion))) - -(define (cons-syntax directive directives) - (if (and (bit-string? directive) - (not (null? directives)) - (bit-string? (car directives))) - (begin (set-car! directives - (bit-string-append (car directives) directive)) - directives) - (cons directive directives))) - -(define (append-syntax! directives directives*) - (cond ((null? directives) directives*) - ((null? directives*) directives) - (else - (let ((pair (last-pair directives))) - (if (and (bit-string? (car pair)) - (bit-string? (car directives*))) - (begin (set-car! pair - (bit-string-append (car directives*) - (car pair))) - (set-cdr! pair (cdr directives*))) - (set-cdr! pair directives*))) - directives))) - -(define optimize-group - (let () - (define (loop1 components) - (cond ((null? components) '()) - ((bit-string? (car components)) - (loop2 (car components) (cdr components))) - (else - (cons (car components) - (loop1 (cdr components)))))) - - (define (loop2 bit-string components) - (cond ((null? components) - (list bit-string)) - ((bit-string? (car components)) - (loop2 (bit-string-append (car components) bit-string) - (cdr components))) - (else - (cons bit-string - (cons (car components) - (loop1 (cdr components))))))) - - (lambda components - (let ((components (loop1 components))) - (cond ((null? components) (error "OPTIMIZE-GROUP: No components")) - ((null? (cdr components)) (car components)) - (else `(GROUP ,@components))))))) - -;;;; Coercion Machinery - -(define (make-coercion-name coercion-type size) - (string->symbol - (string-append "COERCE-" - (write-to-string size) - "-BIT-" - (write-to-string coercion-type)))) - -(define coercion-property-tag - "Coercion") - -(define ((coercion-maker coercion-types) coercion-type size) - (let ((coercion - ((cdr (or (assq coercion-type coercion-types) - (error "Unknown coercion type" coercion-type))) - size))) - (2D-put! coercion coercion-property-tag (list coercion-type size)) - coercion)) - -(define (coercion-size coercion) - (cadr (coercion-properties coercion))) - -(define (unmake-coercion coercion receiver) - (apply receiver (coercion-properties coercion))) - -(define (coercion-properties coercion) - (or (2D-get coercion coercion-property-tag) - (error "COERCION-PROPERTIES: Not a known coercion" coercion))) - -(define coercion-environment - (the-environment)) - -(define (define-coercion coercion-type size) - (local-assignment coercion-environment - (make-coercion-name coercion-type size) - (make-coercion coercion-type size))) - -(define (lookup-coercion name) - (lexical-reference coercion-environment name)) - -(define ((coerce-unsigned-integer nbits) n) - (unsigned-integer->bit-string nbits n)) - -(define (coerce-signed-integer nbits) - (let ((offset (expt 2 nbits))) - (lambda (n) - (unsigned-integer->bit-string nbits - (if (negative? n) - (+ n offset) - n))))) - -(define (standard-coercion kernel) - (lambda (nbits) - (lambda (n) - (unsigned-integer->bit-string nbits (kernel n))))) \ No newline at end of file diff --git a/v7/src/compiler/base/cfg1.scm b/v7/src/compiler/base/cfg1.scm deleted file mode 100644 index 233ff6cce..000000000 --- a/v7/src/compiler/base/cfg1.scm +++ /dev/null @@ -1,541 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 1.147 1987/03/19 00:32:34 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Control Flow Graph Abstraction - -(declare (usual-integrations)) - -;;;; Node Datatypes - -(define cfg-node-tag (make-vector-tag false 'CFG-NODE)) -(define cfg-node? (tagged-vector-subclass-predicate cfg-node-tag)) -(define-vector-slots node 1 generation bblock alist previous-edges) - -(define-vector-method cfg-node-tag ':DESCRIBE - (lambda (node) - (descriptor-list node generation bblock alist previous-edges))) - -(define snode-tag (make-vector-tag cfg-node-tag 'SNODE)) -(define snode? (tagged-vector-subclass-predicate snode-tag)) -(define-vector-slots snode 5 next-edge) - -(define (make-snode tag . extra) - (list->vector (cons* tag false false '() '() false extra))) - -(define-vector-method snode-tag ':DESCRIBE - (lambda (snode) - (append! ((vector-tag-parent-method snode-tag ':DESCRIBE) snode) - (descriptor-list snode next-edge)))) - -(define pnode-tag (make-vector-tag cfg-node-tag 'PNODE)) -(define pnode? (tagged-vector-subclass-predicate pnode-tag)) -(define-vector-slots pnode 5 consequent-edge alternative-edge) - -(define (make-pnode tag . extra) - (list->vector (cons* tag false false '() '() false false extra))) - -(define-vector-method pnode-tag ':DESCRIBE - (lambda (pnode) - (append! ((vector-tag-parent-method pnode-tag ':DESCRIBE) pnode) - (descriptor-list pnode consequent-edge alternative-edge)))) - -(define (edge-next-node edge) - (and edge (edge-right-node edge))) - -(define-integrable (snode-next snode) - (edge-next-node (snode-next-edge snode))) - -(define-integrable (pnode-consequent pnode) - (edge-next-node (pnode-consequent-edge pnode))) - -(define-integrable (pnode-alternative pnode) - (edge-next-node (pnode-alternative-edge pnode))) - -;;;; Edge Datatype - -(define-vector-slots edge 0 left-node left-connect right-node) - -(define-integrable (make-edge left-node left-connect right-node) - (vector left-node left-connect right-node)) - -(define (create-edge! left-node left-connect right-node) - (let ((edge (make-edge left-node left-connect right-node))) - (if left-node - (left-connect left-node edge)) - (if right-node - (let ((previous (node-previous-edges right-node))) - (if (not (memq right-node previous)) - (set-node-previous-edges! right-node (cons edge previous))))))) - -(define (edge-connect-left! edge left-node left-connect) - (set-edge-left-node! edge left-node) - (set-edge-left-connect! edge left-connect) - (if left-node - (left-connect left-node edge))) - -(define (edge-connect-right! edge right-node) - (set-edge-right-node! edge right-node) - (if right-node - (let ((previous (node-previous-edges right-node))) - (if (not (memq right-node previous)) - (set-node-previous-edges! right-node (cons edge previous)))))) - -(define (edges-connect-right! edges right-node) - (for-each (lambda (edge) - (edge-connect-right! edge right-node)) - edges)) - -(define (edge-disconnect-left! edge) - (let ((left-node (set-edge-left-node! edge false)) - (left-connect (set-edge-left-connect! edge false))) - (if left-node - (left-connect left-node false)))) - -(define (edge-disconnect-right! edge) - (let ((right-node (set-edge-right-node! edge false))) - (if right-node - (set-node-previous-edges! right-node - (delq! edge - (node-previous-edges right-node)))))) - -(define (edge-disconnect! edge) - (edge-disconnect-left! edge) - (edge-disconnect-right! edge)) - -(define (edges-disconnect-right! edges) - (for-each edge-disconnect-right! edges)) - -;;;; Editing - -;;; BBlock information is preserved only for deletions. Doing the -;;; same for insertions is more difficult and not currently needed. - -(define (snode-delete! snode) - (let ((bblock (node-bblock snode))) - (if (and bblock - (eq? snode (bblock-exit bblock)) - (not (eq? snode (bblock-entry bblock)))) - (set-bblock-exit! bblock (node-previous-first snode)))) - (let ((previous-edges (node-previous-edges snode)) - (next-edge (snode-next-edge snode))) - (let ((node (edge-right-node next-edge))) - (edges-disconnect-right! previous-edges) - (edge-disconnect! next-edge) - (edges-connect-right! previous-edges node)))) - -(define (edge-insert-snode! edge snode) - (let ((next (edge-right-node edge))) - (edge-disconnect-right! edge) - (edge-connect-right! edge snode) - (create-edge! snode set-snode-next-edge! next))) - -(define (node-insert-snode! node snode) - (let ((previous-edges (node-previous-edges node))) - (edges-disconnect-right! previous-edges) - (edges-connect-right! previous-edges snode) - (create-edge! snode set-snode-next-edge! node))) - -(define (node->edge node) - (let ((edge (make-edge false false false))) - (edge-connect-right! edge node) - edge)) - -(define-integrable (cfg-entry-edge cfg) - (node->edge (cfg-entry-node cfg))) - -;;;; Previous Connections - -(define-integrable (node-previous=0? node) - (edges=0? (node-previous-edges node))) - -(define (edges=0? edges) - (cond ((null? edges) true) - ((edge-left-node (car edges)) false) - (else (edges=0? (cdr edges))))) - -(define-integrable (node-previous>0? node) - (edges>0? (node-previous-edges node))) - -(define (edges>0? edges) - (cond ((null? edges) false) - ((edge-left-node (car edges)) true) - (else (edges>0? (cdr edges))))) - -(define-integrable (node-previous=1? node) - (edges=1? (node-previous-edges node))) - -(define (edges=1? edges) - (if (null? edges) - false - ((if (edge-left-node (car edges)) edges=0? edges=1?) (cdr edges)))) - -(define-integrable (node-previous>1? node) - (edges>1? (node-previous-edges node))) - -(define (edges>1? edges) - (if (null? edges) - false - ((if (edge-left-node (car edges)) edges>0? edges>1?) (cdr edges)))) - -(define-integrable (node-previous-first node) - (edges-first-node (node-previous-edges node))) - -(define (edges-first-node edges) - (if (null? edges) - (error "No first hook") - (or (edge-left-node (car edges)) - (edges-first-node (cdr edges))))) - -(define (for-each-previous-node node procedure) - (for-each (lambda (edge) - (let ((node (edge-left-node edge))) - (if node - (procedure node)))) - (node-previous-edges node))) - -;;;; Noops - -(define noop-node-tag (make-vector-tag snode-tag 'NOOP)) -(define *noop-nodes*) - -(define-integrable (make-noop-node) - (let ((node (make-snode noop-node-tag))) - (set! *noop-nodes* (cons node *noop-nodes*)) - node)) - -(define (delete-noop-nodes!) - (for-each snode-delete! *noop-nodes*) - (set! *noop-nodes* '())) - -(define (constant->pcfg value) - ((if value make-true-pcfg make-false-pcfg))) - -(define (make-false-pcfg) - (let ((node (make-noop-node))) - (make-pcfg node - '() - (list (make-hook node set-snode-next-edge!))))) - -(define (make-true-pcfg) - (let ((node (make-noop-node))) - (make-pcfg node - (list (make-hook node set-snode-next-edge!)) - '()))) - -;;;; Miscellaneous - -(package (with-new-node-marks - node-marked? - node-mark!) - -(define *generation*) - -(define-export (with-new-node-marks thunk) - (fluid-let ((*generation* (make-generation))) - (thunk))) - -(define make-generation - (let ((generation 0)) - (named-lambda (make-generation) - (let ((value generation)) - (set! generation (1+ generation)) - value)))) - -(define-export (node-marked? node) - (eq? (node-generation node) *generation*)) - -(define-export (node-mark! node) - (set-node-generation! node *generation*)) - -) - -(define (node-property-get node key) - (let ((entry (assq key (node-alist node)))) - (and entry (cdr entry)))) - -(define (node-property-put! node key item) - (let ((entry (assq key (node-alist node)))) - (if entry - (set-cdr! entry item) - (set-node-alist! node (cons (cons key item) (node-alist node)))))) - -(define (node-property-remove! node key) - (set-node-alist! node (del-assq! key (node-alist node)))) - -(define (node-label node) - (or (node-labelled? node) - (let ((label (generate-label))) - (set-node-label! node label) - label))) - -(define-integrable (node-labelled? node) - (node-property-get node node-label)) - -(define-integrable (set-node-label! node label) - (node-property-put! node node-label label)) - -;;;; CFG Datatypes - -;;; A CFG is a compound CFG-node, so there are different types of CFG -;;; corresponding to the (connective-wise) different types of -;;; CFG-node. One may insert a particular type of CFG anywhere in a -;;; graph that its corresponding node may be inserted. - -(define-integrable (make-scfg node next-hooks) - (vector 'SNODE-CFG node next-hooks)) - -(define-integrable (make-scfg* node consequent-hooks alternative-hooks) - (make-scfg node (hooks-union consequent-hooks alternative-hooks))) - -(define-integrable (make-pcfg node consequent-hooks alternative-hooks) - (vector 'PNODE-CFG node consequent-hooks alternative-hooks)) - -(define-integrable (cfg-tag cfg) - (vector-ref cfg 0)) - -(define-integrable (cfg-entry-node cfg) - (vector-ref cfg 1)) - -(define-integrable (scfg-next-hooks scfg) - (vector-ref scfg 2)) - -(define-integrable (pcfg-consequent-hooks pcfg) - (vector-ref pcfg 2)) - -(define-integrable (pcfg-alternative-hooks pcfg) - (vector-ref pcfg 3)) - -(define-integrable (make-null-cfg) false) -(define-integrable cfg-null? false?) - -(define-integrable (snode->scfg snode) - (node->scfg snode set-snode-next-edge!)) - -(define (node->scfg node set-node-next!) - (make-scfg node - (list (make-hook node set-node-next!)))) - -(define-integrable (pnode->pcfg pnode) - (node->pcfg pnode - set-pnode-consequent-edge! - set-pnode-alternative-edge!)) - -(define (node->pcfg node set-node-consequent! set-node-alternative!) - (make-pcfg node - (list (make-hook node set-node-consequent!)) - (list (make-hook node set-node-alternative!)))) - -;;;; Hook Datatype - -(define-integrable make-hook cons) -(define-integrable hook-node car) -(define-integrable hook-connect cdr) - -(define (hook=? x y) - (and (eq? (hook-node x) (hook-node y)) - (eq? (hook-connect x) (hook-connect y)))) - -(define hook-member? - (member-procedure hook=?)) - -(define (hooks-union x y) - (let loop ((x x)) - (cond ((null? x) y) - ((hook-member? (car x) y) (loop (cdr x))) - (else (cons (car x) (loop (cdr x))))))) - -(define (hooks-connect! hooks node) - (for-each (lambda (hook) - (hook-connect! hook node)) - hooks)) - -(define (hook-connect! hook node) - (create-edge! (hook-node hook) (hook-connect hook) node)) - -(define (scfg*node->node! scfg next-node) - (if (cfg-null? scfg) - next-node - (begin (if next-node - (hooks-connect! (scfg-next-hooks scfg) next-node)) - (cfg-entry-node scfg)))) - -(define (pcfg*node->node! pcfg consequent-node alternative-node) - (if (cfg-null? pcfg) - (error "PCFG*NODE->NODE!: Can't have null predicate")) - (if consequent-node - (hooks-connect! (pcfg-consequent-hooks pcfg) consequent-node)) - (if alternative-node - (hooks-connect! (pcfg-alternative-hooks pcfg) alternative-node)) - (cfg-entry-node pcfg)) - -;;;; CFG Construction - -(define-integrable (scfg-next-connect! scfg cfg) - (hooks-connect! (scfg-next-hooks scfg) (cfg-entry-node cfg))) - -(define-integrable (pcfg-consequent-connect! pcfg cfg) - (hooks-connect! (pcfg-consequent-hooks pcfg) (cfg-entry-node cfg))) - -(define-integrable (pcfg-alternative-connect! pcfg cfg) - (hooks-connect! (pcfg-alternative-hooks pcfg) (cfg-entry-node cfg))) - -(define (scfg*scfg->scfg! scfg scfg*) - (cond ((not scfg) scfg*) - ((not scfg*) scfg) - (else - (scfg-next-connect! scfg scfg*) - (make-scfg (cfg-entry-node scfg) (scfg-next-hooks scfg*))))) - -(package (scfg-append! scfg*->scfg!) - -(define-export (scfg-append! . scfgs) - (scfg*->scfg! scfgs)) - -(define-export (scfg*->scfg! scfgs) - (let ((first (find-non-null scfgs))) - (and (not (null? first)) - (let ((second (find-non-null (cdr first)))) - (if (null? second) - (car first) - (make-scfg (cfg-entry-node (car first)) - (scfg-next-hooks - (loop (car first) - (car second) - (find-non-null (cdr second)))))))))) - -(define (loop first second third) - (scfg-next-connect! first second) - (if (null? third) - second - (loop second (car third) (find-non-null (cdr third))))) - -(define (find-non-null scfgs) - (if (or (null? scfgs) - (car scfgs)) - scfgs - (find-non-null (cdr scfgs)))) - -) - -(define (pcfg->scfg! pcfg) - (make-scfg* (cfg-entry-node pcfg) - (pcfg-consequent-hooks pcfg) - (pcfg-alternative-hooks pcfg))) - -(package (scfg*pcfg->pcfg! scfg*pcfg->scfg!) - -(define ((scfg*pcfg->cfg! transformer constructor) scfg pcfg) - (cond ((not pcfg) (error "SCFG*PCFG->CFG!: Can't have null predicate")) - ((not scfg) (transformer pcfg)) - (else - (scfg-next-connect! scfg pcfg) - (constructor (cfg-entry-node scfg) - (pcfg-consequent-hooks pcfg) - (pcfg-alternative-hooks pcfg))))) - -(define scfg*pcfg->pcfg! - (scfg*pcfg->cfg! identity-procedure make-pcfg)) - -(define scfg*pcfg->scfg! - (scfg*pcfg->cfg! pcfg->scfg! make-scfg*)) - -) - -(package (pcfg*scfg->pcfg! pcfg*scfg->scfg!) - -(define ((pcfg*scfg->cfg! transformer constructor) pcfg consequent alternative) - (cond ((not pcfg) (error "PCFG*SCFG->CFG!: Can't have null predicate")) - ((not consequent) - (if (not alternative) - (transformer pcfg) - (begin (pcfg-alternative-connect! pcfg alternative) - (constructor (cfg-entry-node pcfg) - (pcfg-consequent-hooks pcfg) - (scfg-next-hooks alternative))))) - ((not alternative) - (pcfg-consequent-connect! pcfg consequent) - (constructor (cfg-entry-node pcfg) - (scfg-next-hooks consequent) - (pcfg-alternative-hooks pcfg))) - (else - (pcfg-consequent-connect! pcfg consequent) - (pcfg-alternative-connect! pcfg alternative) - (constructor (cfg-entry-node pcfg) - (scfg-next-hooks consequent) - (scfg-next-hooks alternative))))) - -(define pcfg*scfg->pcfg! - (pcfg*scfg->cfg! identity-procedure make-pcfg)) - -(define pcfg*scfg->scfg! - (pcfg*scfg->cfg! pcfg->scfg! make-scfg*)) - -) - -(package (pcfg*pcfg->pcfg! pcfg*pcfg->scfg!) - -(define ((pcfg*pcfg->cfg! transformer constructor) pcfg consequent alternative) - (cond ((not pcfg) - (error "PCFG*PCFG->CFG!: Can't have null predicate")) - ((not consequent) - (if (not alternative) - (transformer pcfg) - (begin (pcfg-alternative-connect! pcfg alternative) - (constructor - (cfg-entry-node pcfg) - (hooks-union (pcfg-consequent-hooks pcfg) - (pcfg-consequent-hooks alternative)) - (pcfg-alternative-hooks alternative))))) - ((not alternative) - (pcfg-consequent-connect! pcfg consequent) - (constructor (cfg-entry-node pcfg) - (pcfg-consequent-hooks consequent) - (hooks-union (pcfg-alternative-hooks consequent) - (pcfg-alternative-hooks pcfg)))) - (else - (pcfg-consequent-connect! pcfg consequent) - (pcfg-alternative-connect! pcfg alternative) - (constructor (cfg-entry-node pcfg) - (hooks-union (pcfg-consequent-hooks consequent) - (pcfg-consequent-hooks alternative)) - (hooks-union (pcfg-alternative-hooks consequent) - (pcfg-alternative-hooks alternative)))))) - -(define pcfg*pcfg->pcfg! - (pcfg*pcfg->cfg! identity-procedure make-pcfg)) - -(define pcfg*pcfg->scfg! - (pcfg*pcfg->cfg! pcfg->scfg! make-scfg*)) - - (for-each edge-disconnect-right! edges)) \ No newline at end of file diff --git a/v7/src/compiler/base/ctypes.scm b/v7/src/compiler/base/ctypes.scm deleted file mode 100644 index 746ddefe2..000000000 --- a/v7/src/compiler/base/ctypes.scm +++ /dev/null @@ -1,103 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 1.42 1987/03/19 23:11:10 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Compiler CFG Datatypes - -(declare (usual-integrations)) - -(define-snode assignment block lvalue rvalue) - -(define (make-assignment block lvalue rvalue) - (vnode-connect! lvalue rvalue) - (if (variable? lvalue) - (set-variable-assignments! lvalue (1+ (variable-assignments lvalue)))) - (snode->scfg (make-snode assignment-tag block lvalue rvalue))) - -(define-snode definition block lvalue rvalue) - -(define (make-definition block lvalue rvalue) - (vnode-connect! lvalue rvalue) - (if (variable? lvalue) - (set-variable-assignments! lvalue (1+ (variable-assignments lvalue)))) - (snode->scfg (make-snode definition-tag block lvalue rvalue))) - -(define-pnode true-test rvalue) - -(define-integrable (make-true-test rvalue) - (pnode->pcfg (make-pnode true-test-tag rvalue))) - -(define-pnode unassigned-test block variable) - -(define-integrable (make-unassigned-test block variable) - (pnode->pcfg (make-pnode unassigned-test-tag block variable))) - -(define-pnode unbound-test block variable) - -(define-integrable (make-unbound-test block variable) - (pnode->pcfg (make-pnode unbound-test-tag block variable))) - -(define-snode combination block compilation-type value operator operands - procedures known-operator) -(define *combinations*) - -(define (make-combination block compilation-type value operator operands) - (let ((combination - (make-snode combination-tag block compilation-type value operator - operands '() false))) - (set! *combinations* (cons combination *combinations*)) - (set-block-combinations! block - (cons combination (block-combinations block))) - (set-vnode-combinations! value - (cons combination (vnode-combinations value))) - (snode->scfg combination))) - -(define-snode continuation rtl-edge delta label) -(define *continuations*) - -(define-integrable (make-continuation delta) - (let ((continuation - (make-snode continuation-tag false delta - (generate-label 'CONTINUATION)))) - (set! *continuations* (cons continuation *continuations*)) - continuation)) - -(define-integrable (continuation-rtl-entry continuation) - (edge-right-node (continuation-rtl-edge continuation))) - -(define-integrable (set-continuation-rtl-entry! continuation node) - (set-continuation-rtl-edge! continuation (node->edge node))) - -(define-unparser continuation-tag - (lambda (continuation) - (symbol-hash-table/lookup *label->object* label)) \ No newline at end of file diff --git a/v7/src/compiler/base/macros.scm b/v7/src/compiler/base/macros.scm deleted file mode 100644 index 1d6a4aa25..000000000 --- a/v7/src/compiler/base/macros.scm +++ /dev/null @@ -1,251 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 1.56 1987/03/19 00:33:44 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Compiler Macros - -(declare (usual-integrations)) - -(define compiler-syntax-table - (make-syntax-table system-global-syntax-table)) - -(define lap-generator-syntax-table - (make-syntax-table compiler-syntax-table)) - -(define assembler-syntax-table - (make-syntax-table compiler-syntax-table)) - -(syntax-table-define compiler-syntax-table 'PACKAGE - (in-package system-global-environment - (declare (usual-integrations)) - (lambda (expression) - (apply (lambda (names . body) - (make-sequence - `(,@(map (lambda (name) - (make-definition name (make-unassigned-object))) - names) - ,(make-combination - (let ((block (syntax* body))) - (if (open-block? block) - (open-block-components block - (lambda (names* declarations body) - (make-lambda lambda-tag:let '() '() false - (list-transform-negative names* - (lambda (name) - (memq name names))) - declarations - body))) - (make-lambda lambda-tag:let '() '() false '() - '() block))) - '())))) - (cdr expression))))) - -(let () - -(define (parse-define-syntax pattern body if-variable if-lambda) - (cond ((pair? pattern) - (let loop ((pattern pattern) (body body)) - (cond ((pair? (car pattern)) - (loop (car pattern) `((LAMBDA ,(cdr pattern) ,@body)))) - ((symbol? (car pattern)) - (if-lambda pattern body)) - (else - (error "Illegal name" parse-define-syntax (car pattern)))))) - ((symbol? pattern) - (if-variable pattern body)) - (else - (error "Illegal name" parse-define-syntax pattern)))) - -(define lambda-list->bound-names - (let ((accumulate - (lambda (lambda-list) - (cons (let ((parameter (car lambda-list))) - (if (pair? parameter) (car parameter) parameter)) - (lambda-list->bound-names (cdr lambda-list)))))) - (named-lambda (lambda-list->bound-names lambda-list) - (cond ((symbol? lambda-list) - lambda-list) - ((null? lambda-list) '()) - ((not (pair? lambda-list)) - (error "Illegal rest variable" lambda-list)) - ((eq? (car lambda-list) - (access lambda-optional-tag lambda-package)) - (if (pair? (cdr lambda-list)) - (accumulate (cdr lambda-list)) - (error "Missing optional variable" lambda-list))) - (else - (accumulate lambda-list)))))) - -(syntax-table-define compiler-syntax-table 'DEFINE-EXPORT - (macro (pattern . body) - (parse-define-syntax pattern body - (lambda (name body) - `(SET! ,pattern ,@body)) - (lambda (pattern body) - `(SET! ,(car pattern) - (NAMED-LAMBDA ,pattern ,@body)))))) - -(syntax-table-define compiler-syntax-table 'DEFINE-INTEGRABLE - (macro (pattern . body) -#| - (parse-define-syntax pattern body - (lambda (name body) - `(BEGIN (DECLARE (INTEGRATE ,pattern)) - (DEFINE ,pattern ,@body))) - (lambda (pattern body) - `(BEGIN (DECLARE (INTEGRATE-OPERATOR ,(car pattern))) - (DEFINE ,pattern - ,@(if (list? (cdr pattern)) - `(DECLARE - (INTEGRATE - ,@(lambda-list->bound-names (cdr pattern)))) - '()) - ,@body)))) -|# - `(DEFINE ,pattern ,@body))) - -) - -(syntax-table-define compiler-syntax-table 'DEFINE-VECTOR-SLOTS - (macro (class index . slots) - (define (loop slots n) - (if (null? slots) - '() - (cons (let ((ref-name (symbol-append class '- (car slots)))) - `(BEGIN - (DEFINE-INTEGRABLE (,ref-name ,class) - (VECTOR-REF ,class ,n)) - (DEFINE-INTEGRABLE (,(symbol-append 'SET- ref-name '!) - ,class ,(car slots)) - (VECTOR-SET! ,class ,n ,(car slots))))) - (loop (cdr slots) (1+ n))))) - (if (null? slots) - '*THE-NON-PRINTING-OBJECT* - `(BEGIN ,@(loop slots index))))) - -(let-syntax - ((define-type-definition - (macro (name reserved) - (let ((parent (symbol-append name '-TAG))) - `(SYNTAX-TABLE-DEFINE COMPILER-SYNTAX-TABLE - ',(symbol-append 'DEFINE- name) - (macro (type . slots) - (let ((tag-name (symbol-append type '-TAG))) - `(BEGIN (DEFINE ,tag-name - (MAKE-VECTOR-TAG ,',parent ',type)) - (DEFINE ,(symbol-append type '?) - (TAGGED-VECTOR-PREDICATE ,tag-name)) - (DEFINE-VECTOR-SLOTS ,type ,,reserved ,@slots) - (DEFINE-VECTOR-METHOD ,tag-name ':DESCRIBE - (LAMBDA (,type) - (APPEND! - ((VECTOR-TAG-METHOD ,',parent ':DESCRIBE) ,type) - (DESCRIPTOR-LIST ,type ,@slots)))))))))))) - (define-type-definition snode 6) - (define-type-definition pnode 7) - (define-type-definition rvalue 1) - (define-type-definition vnode 10)) - -(syntax-table-define compiler-syntax-table 'DESCRIPTOR-LIST - (macro (type . slots) - `(LIST ,@(map (lambda (slot) - (let ((ref-name (symbol-append type '- slot))) - ``(,',ref-name ,(,ref-name ,type)))) - slots)))) - -(let ((rtl-common - (lambda (type prefix components wrap-constructor) - `(BEGIN - (DEFINE-INTEGRABLE (,(symbol-append prefix 'MAKE- type) . REST) - ,(wrap-constructor `(CONS ',type REST))) - (DEFINE-INTEGRABLE (,(symbol-append 'RTL: type '?) EXPRESSION) - (EQ? (CAR EXPRESSION) ',type)) - ,@(let loop ((components components) - (ref-index 6) - (set-index 2)) - (if (null? components) - '() - (let* ((slot (car components)) - (name (symbol-append type '- slot))) - `((DEFINE-INTEGRABLE (,(symbol-append 'RTL: name) ,type) - (GENERAL-CAR-CDR ,type ,ref-index)) - (DEFINE-INTEGRABLE (,(symbol-append 'RTL:SET- name '!) - ,type ,slot) - (SET-CAR! (GENERAL-CAR-CDR ,type ,set-index) ,slot)) - ,@(loop (cdr components) - (* ref-index 2) - (* set-index 2)))))))))) - (syntax-table-define compiler-syntax-table 'DEFINE-RTL-EXPRESSION - (macro (type prefix . components) - (rtl-common type prefix components identity-procedure))) - - (syntax-table-define compiler-syntax-table 'DEFINE-RTL-STATEMENT - (macro (type prefix . components) - (rtl-common type prefix components - (lambda (expression) `(STATEMENT->SCFG ,expression))))) - - (syntax-table-define compiler-syntax-table 'DEFINE-RTL-PREDICATE - (macro (type prefix . components) - (rtl-common type prefix components - (lambda (expression) `(PREDICATE->PCFG ,expression)))))) - -(syntax-table-define compiler-syntax-table 'DEFINE-REGISTER-REFERENCES - (macro (slot) - (let ((name (symbol-append 'REGISTER- slot))) - (let ((vector (symbol-append '* name '*))) - `(BEGIN (DEFINE ,vector) - (DEFINE-INTEGRABLE (,name REGISTER) - (VECTOR-REF ,vector REGISTER)) - (DEFINE-INTEGRABLE - (,(symbol-append 'SET- name '!) REGISTER VALUE) - (VECTOR-SET! ,vector REGISTER VALUE))))))) - -(syntax-table-define compiler-syntax-table 'UCODE-TYPE - (macro (name) - (microcode-type name))) - -(syntax-table-define compiler-syntax-table 'UCODE-PRIMITIVE - (macro (name) - (make-primitive-procedure name))) - -(syntax-table-define lap-generator-syntax-table 'DEFINE-RULE - (macro (type pattern . body) - (parse-rule pattern body - (lambda (pattern names transformer qualifier actions) - `(,(case type - ((STATEMENT) 'ADD-STATEMENT-RULE!) - ((PREDICATE) 'ADD-STATEMENT-RULE!) - (else (error "Unknown rule type" type))) - ',pattern - ,(rule-result-expression names transformer qualifier - `(BEGIN ,@actions))))))) \ No newline at end of file diff --git a/v7/src/compiler/base/mvalue.scm b/v7/src/compiler/base/mvalue.scm deleted file mode 100644 index 0edf0c712..000000000 --- a/v7/src/compiler/base/mvalue.scm +++ /dev/null @@ -1,81 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/mvalue.scm,v 3.0 1987/03/10 13:25:05 cph Rel $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Multiple Value Support - -(declare (usual-integrations)) - -(define (transmit-values transmitter receiver) - (transmitter receiver)) - -(define (multiple-value-list transmitter) - (transmitter list)) - -(define (return . values) - (lambda (receiver) - (apply receiver values))) - -;;; For efficiency: - -(define (return-2 v0 v1) - (lambda (receiver) - (receiver v0 v1))) - -(define (return-3 v0 v1 v2) - (lambda (receiver) - (receiver v0 v1 v2))) - -(define (return-4 v0 v1 v2 v3) - (lambda (receiver) - (receiver v0 v1 v2 v3))) - -(define (return-5 v0 v1 v2 v3 v4) - (lambda (receiver) - (receiver v0 v1 v2 v3 v4))) - -(define (return-6 v0 v1 v2 v3 v4 v5) - (lambda (receiver) - (receiver v0 v1 v2 v3 v4 v5))) - -(define (list-multiple first . rest) - (apply call-multiple list first rest)) - -(define (cons-multiple cars cdrs) - (call-multiple cons cars cdrs)) - -(define (call-multiple procedure . transmitters) - (apply return - (apply map - procedure - (map multiple-value-list transmitters)))) \ No newline at end of file diff --git a/v7/src/compiler/base/object.scm b/v7/src/compiler/base/object.scm deleted file mode 100644 index bfdd98611..000000000 --- a/v7/src/compiler/base/object.scm +++ /dev/null @@ -1,130 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/object.scm,v 1.1 1987/03/19 00:44:29 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Support for tagged objects - -(declare (usual-integrations)) - -(define (make-vector-tag parent name) - (let ((tag (cons '() (or parent vector-tag:object)))) - (vector-tag-put! tag ':TYPE-NAME name) - ((access add-unparser-special-object! unparser-package) - tag tagged-vector-unparser) - tag)) - -(define *tagged-vector-unparser-show-hash* - true) - -(define (tagged-vector-unparser object) - (unparse-with-brackets - (lambda () - (write-string "LIAR ") - (if *tagged-vector-unparser-show-hash* - (begin (fluid-let ((*unparser-radix* 10)) - (write (hash object))) - (write-string " "))) - (fluid-let ((*unparser-radix* 16)) - ((vector-method object ':UNPARSE) object))))) - -(define (vector-tag-put! tag key value) - (let ((entry (assq key (car tag)))) - (if entry - (set-cdr! entry value) - (set-car! tag (cons (cons key value) (car tag)))))) - -(define (vector-tag-get tag key) - (define (loop tag) - (and (pair? tag) - (or (assq key (car tag)) - (loop (cdr tag))))) - (let ((value - (or (assq key (car tag)) - (loop (cdr tag))))) - (and value (cdr value)))) - -(define vector-tag:object - (list '())) - -(vector-tag-put! vector-tag:object ':TYPE-NAME 'OBJECT) - -(define-integrable (vector-tag vector) - (vector-ref vector 0)) - -(define (define-vector-method tag name method) - (vector-tag-put! tag name method) - name) - -(define (vector-tag-method tag name) - (or (vector-tag-get tag name) - (error "Unbound method" tag name))) - -(define-integrable (vector-tag-parent-method tag name) - (vector-tag-method (cdr tag) name)) - -(define-integrable (vector-method vector name) - (vector-tag-method (vector-tag vector) name)) - -(define (define-unparser tag unparser) - (define-vector-method tag ':UNPARSE unparser)) - -(define-integrable make-tagged-vector - vector) - -(define ((tagged-vector-predicate tag) object) - (and (vector? object) - (not (zero? (vector-length object))) - (eq? tag (vector-tag object)))) - -(define (tagged-vector-subclass-predicate tag) - (define (loop tag*) - (or (eq? tag tag*) - (and (pair? tag*) - (loop (cdr tag*))))) - (lambda (object) - (and (vector? object) - (not (zero? (vector-length object))) - (loop (vector-tag object))))) - -(define tagged-vector? - (tagged-vector-subclass-predicate vector-tag:object)) - -(define-unparser vector-tag:object - (lambda (object) - (write (vector-method object ':TYPE-NAME)))) - -(define (->tagged-vector object) - (or (and (tagged-vector? object) object) - (and (integer? object) - (let ((object (unhash object))) - (and (tagged-vector? object) object))))) \ No newline at end of file diff --git a/v7/src/compiler/base/pmlook.scm b/v7/src/compiler/base/pmlook.scm deleted file mode 100644 index cb178305e..000000000 --- a/v7/src/compiler/base/pmlook.scm +++ /dev/null @@ -1,92 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmlook.scm,v 1.1 1987/04/17 07:59:56 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Very Simple Pattern Matcher: Lookup - -(declare (usual-integrations)) - -(package (pattern-lookup pattern-variables make-pattern-variable) - -;;; PATTERN-LOOKUP returns either false or a pair whose car is the -;;; item matched and whose cdr is the list of variable values. Use -;;; PATTERN-VARIABLES to get a list of names that is in the same order -;;; as the list of values. - -(define (pattern-lookup entries instance) - (define (lookup-loop entries values) - (define (match pattern instance) - (if (pair? pattern) - (if (eq? (car pattern) pattern-variable-tag) - (let ((entry (memq (cdr pattern) values))) - (if entry - (eqv? (cdr entry) instance) - (begin (set! values (cons instance values)) - true))) - (and (pair? instance) - (match (car pattern) (car instance)) - (match (cdr pattern) (cdr instance)))) - (eqv? pattern instance))) - (and (not (null? entries)) - (or (and (match (caar entries) instance) - (apply (cdar entries) values)) - (lookup-loop (cdr entries) '())))) - (lookup-loop entries '())) - -(define (pattern-variables pattern) - (let ((variables '())) - (define (loop pattern) - (if (pair? pattern) - (if (eq? (car pattern) pattern-variable-tag) - (if (not (memq (cdr pattern) variables)) - (set! variables (cons (cdr pattern) variables))) - (begin (loop (car pattern)) - (loop (cdr pattern)))))) - (loop pattern) - variables)) - -(define (make-pattern-variable name) - (cons pattern-variable-tag name)) - -(define pattern-variable-tag - (make-named-tag "Pattern Variable")) - -) - -;;; ALL-TRUE? is used to determine if splicing variables with -;;; qualifiers satisfy the qualification. - -(define (all-true? values) - (or (null? values) - (and (car values) - (all-true? (cdr values))))) \ No newline at end of file diff --git a/v7/src/compiler/base/sets.scm b/v7/src/compiler/base/sets.scm deleted file mode 100644 index 2d3340ff5..000000000 --- a/v7/src/compiler/base/sets.scm +++ /dev/null @@ -1,121 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/sets.scm,v 1.1 1987/03/19 00:44:43 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Simple Set Abstraction - -(declare (usual-integrations)) - -(define (eq-set-adjoin element set) - (if (memq element set) - set - (cons element set))) - -(define (eqv-set-adjoin element set) - (if (memv element set) - set - (cons element set))) - -(define (eq-set-delete set item) - (define (loop set) - (cond ((null? set) '()) - ((eq? (car set) item) (cdr set)) - (else (cons (car set) (loop (cdr set)))))) - (loop set)) - -(define (eqv-set-delete set item) - (define (loop set) - (cond ((null? set) '()) - ((eqv? (car set) item) (cdr set)) - (else (cons (car set) (loop (cdr set)))))) - (loop set)) - -(define (eq-set-substitute set old new) - (define (loop set) - (cond ((null? set) '()) - ((eq? (car set) old) (cons new (cdr set))) - (else (cons (car set) (loop (cdr set)))))) - (loop set)) - -(define (eqv-set-substitute set old new) - (define (loop set) - (cond ((null? set) '()) - ((eqv? (car set) old) (cons new (cdr set))) - (else (cons (car set) (loop (cdr set)))))) - (loop set)) - -(define (set-search set procedure) - (define (loop items) - (and (not (null? items)) - (or (procedure (car items)) - (loop (cdr items))))) - (loop set)) - -;;; The dataflow analyzer assumes that -;;; (eq? (list-tail (eq-set-union x y) n) y) for some n. - -(define (eq-set-union x y) - (if (null? y) - x - (let loop ((x x) (y y)) - (if (null? x) - y - (loop (cdr x) - (if (memq (car x) y) - y - (cons (car x) y))))))) - -(define (eqv-set-union x y) - (if (null? y) - x - (let loop ((x x) (y y)) - (if (null? x) - y - (loop (cdr x) - (if (memv (car x) y) - y - (cons (car x) y))))))) - -(define (eq-set-difference x y) - (define (loop x) - (cond ((null? x) '()) - ((memq (car x) y) (loop (cdr x))) - (else (cons (car x) (loop (cdr x)))))) - (loop x)) - -(define (eqv-set-difference x y) - (define (loop x) - (cond ((null? x) '()) - ((memv (car x) y) (loop (cdr x))) - (else (cons (car x) (loop (cdr x)))))) - (loop x)) \ No newline at end of file diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm deleted file mode 100644 index da2f59721..000000000 --- a/v7/src/compiler/base/utils.scm +++ /dev/null @@ -1,294 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 1.85 1987/04/17 07:38:02 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Compiler Utilities - -(declare (usual-integrations)) - -;;;; Miscellaneous - -(define (three-way-sort = set set* receiver) - (let ((member? (member-procedure =))) - (define (loop set set* receiver) - (if (null? set) - (receiver '() '() set*) - (let ((item (member? (car set) set*))) - (if item - (loop (cdr set) (delq! (car item) set*) - (lambda (set-only both set*-only) - (receiver set-only - (cons (cons (car set) (car item)) both) - set*-only))) - (loop (cdr set) set* - (lambda (set-only both set*-only) - (receiver (cons (car set) set-only) - both - set*-only))))))) - (loop set (list-copy set*) receiver))) - -(define (generate-label #!optional prefix) - (if (unassigned? prefix) (set! prefix 'LABEL)) - (string->symbol - (string-append - (symbol->string - (cond ((eq? prefix lambda-tag:unnamed) 'LAMBDA) - ((eq? prefix lambda-tag:let) 'LET) - ((eq? prefix lambda-tag:make-environment) 'MAKE-ENVIRONMENT) - ((or (eq? prefix lambda-tag:shallow-fluid-let) - (eq? prefix lambda-tag:deep-fluid-let) - (eq? prefix lambda-tag:common-lisp-fluid-let)) - 'FLUID-LET) - (else prefix))) - "-" - (write-to-string (generate-label-number))))) - -(define *current-label-number*) - -(define (generate-label-number) - (let ((number *current-label-number*)) - (set! *current-label-number* (1+ *current-label-number*)) - number)) - -(define (copy-alist alist) - (if (null? alist) - '() - (cons (cons (caar alist) (cdar alist)) - (copy-alist (cdr alist))))) - -(define (warn message . irritants) - (newline) - (write-string "Warning: ") - (write-string message) - (for-each (lambda (irritant) - (write-string " ") - (write irritant)) - irritants)) - -(define (show-time thunk) - (let ((start (runtime))) - (let ((value (thunk))) - (write-line (- (runtime) start)) - value))) - -;;;; SCode Interface - -(let-syntax ((define-scode-operator - (macro (name) - `(DEFINE ,(symbol-append 'SCODE/ name) - (ACCESS ,name SYSTEM-GLOBAL-ENVIRONMENT))))) - (define-scode-operator access-components) - (define-scode-operator access?) - (define-scode-operator assignment?) - (define-scode-operator assignment-components) - (define-scode-operator assignment-name) - (define-scode-operator assignment-value) - (define-scode-operator combination-components) - (define-scode-operator combination?) - (define-scode-operator comment-expression) - (define-scode-operator comment?) - (define-scode-operator conditional-components) - (define-scode-operator definition-components) - (define-scode-operator delay?) - (define-scode-operator delay-expression) - (define-scode-operator disjunction-components) - (define-scode-operator in-package-components) - (define-scode-operator lambda-components) - (define-scode-operator lambda?) - (define-scode-operator make-access) - (define-scode-operator make-assignment) - (define-scode-operator make-combination) - (define-scode-operator make-conditional) - (define-scode-operator make-definition) - (define-scode-operator make-lambda) - (define-scode-operator make-quotation) - (define-scode-operator make-sequence) - (define-scode-operator make-variable) - (define-scode-operator open-block-components) - (define-scode-operator open-block?) - (define-scode-operator primitive-procedure?) - (define-scode-operator procedure?) - (define-scode-operator quotation-expression) - (define-scode-operator sequence-actions) - (define-scode-operator unassigned-object?) - (define-scode-operator unassigned?-name) - (define-scode-operator unbound?-name) - (define-scode-operator variable-name) - (define-scode-operator variable?)) - -(define scode/constant? - (access scode-constant? system-global-environment)) - -(define (scode/error-combination-components combination receiver) - (scode/combination-components combination - (lambda (operator operands) - (receiver (car operands) - (let ((irritant (cadr operands))) - (cond ((scode/access? irritant) '()) - ((scode/combination? irritant) - (scode/combination-components irritant - (lambda (operator operands) - (if (and (scode/access? operator) - (scode/access-components operator - (lambda (environment name) - (and (null? environment) - (eq? name 'LIST))))) - operands - (list irritant))))) - (else (list irritant)))))))) - -(define (scode/procedure-type-code *lambda) - (cond ((primitive-type? type-code:lambda *lambda) - type-code:procedure) - ((primitive-type? type-code:extended-lambda *lambda) - type-code:extended-procedure) - (else - (error "SCODE/PROCEDURE-TYPE-CODE: Unknown lambda type" *lambda)))) - -(define (scode/make-let names values body) - (scode/make-combination (scode/make-lambda lambda-tag:let names '() false '() - '() body) - values)) - -;;;; Type Codes - -(define type-code:lambda - (microcode-type 'LAMBDA)) - -(define type-code:extended-lambda - (microcode-type 'EXTENDED-LAMBDA)) - -(define type-code:procedure - (microcode-type 'PROCEDURE)) - -(define type-code:extended-procedure - (microcode-type 'EXTENDED-PROCEDURE)) - -(define type-code:cell - (microcode-type 'CELL)) - -(define type-code:compiled-expression - (microcode-type 'COMPILED-EXPRESSION)) - -(define type-code:compiler-link - (microcode-type 'COMPILER-LINK)) - -(define type-code:compiled-procedure - (microcode-type 'COMPILED-PROCEDURE)) - -(define type-code:environment - (microcode-type 'ENVIRONMENT)) - -(define type-code:stack-environment - (microcode-type 'STACK-ENVIRONMENT)) - -(define type-code:return-address - (microcode-type 'COMPILER-RETURN-ADDRESS)) - -(define type-code:unassigned - (microcode-type 'UNASSIGNED)) - -;;; Disgusting hack to replace microcode implementation. - -(define (primitive-procedure-safe? object) - (and (primitive-type? (ucode-type primitive) object) - (not (memq object - (let-syntax ((primitives - (macro names - `'(,@(map make-primitive-procedure names))))) - (primitives call-with-current-continuation - non-reentrant-call-with-current-continuation - scode-eval - apply - garbage-collect - primitive-fasdump - set-current-history! - with-history-disabled - force - primitive-purify - complete-garbage-collect - dump-band - primitive-impurify - with-threaded-continuation - within-control-point - with-interrupts-reduced - primitive-eval-step - primitive-apply-step - primitive-return-step - execute-at-new-state-point - translate-to-state-point - with-interrupt-mask - error-procedure)))))) - -;;;; Special Compiler Support - -(define compiled-error-procedure - "Compiled error procedure") - -(define lambda-tag:delay - (make-named-tag "DELAY-LAMBDA")) - -(define (non-pointer-object? object) - (or (primitive-type? (ucode-type false) object) - (primitive-type? (ucode-type true) object) - (primitive-type? (ucode-type fixnum) object) - (primitive-type? (ucode-type character) object) - (primitive-type? (ucode-type unassigned) object) - (primitive-type? (ucode-type primitive) object) - (primitive-type? (ucode-type the-environment) object) - (primitive-type? (ucode-type manifest-nm-vector) object) - (primitive-type? (ucode-type manifest-special-nm-vector) object))) - -(define (object-immutable? object) - (or (non-pointer-object? object) - (number? object) - (symbol? object) - (scode/primitive-procedure? object) - (eq? object compiled-error-procedure))) - -(define (operator-constant-foldable? operator) - (memq operator constant-foldable-operators)) - -(define constant-foldable-operators - (list primitive-type primitive-type? - eq? null? pair? car cdr vector-length vector-ref - number? complex? real? rational? integer? - zero? positive? negative? odd? even? exact? inexact? - = < > <= >= max min - + - * / 1+ -1+ abs quotient remainder modulo integer-divide - gcd lcm floor ceiling truncate round - exp log expt sqrt sin cos tan asin acos atan - (ucode-primitive &+) (ucode-primitive &-) - (ucode-primitive &*) (ucode-primitive &/) - (ucode-primitive &<) (ucode-primitive &>) - (ucode-primitive &=) (ucode-primitive &atan))) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/assmd.scm b/v7/src/compiler/machines/bobcat/assmd.scm deleted file mode 100644 index e0b253b05..000000000 --- a/v7/src/compiler/machines/bobcat/assmd.scm +++ /dev/null @@ -1,58 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/assmd.scm,v 1.29 1987/03/19 00:52:27 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Assembler Machine Dependencies - -(declare (usual-integrations)) - -(define addressing-granularity 8) -(define scheme-object-width 32) - -(define make-nmv-header) -(let () - -(set! make-nmv-header -(named-lambda (make-nmv-header n) - (bit-string-append (unsigned-integer->bit-string 24 n) - nmv-type-string))) - -(define nmv-type-string - (unsigned-integer->bit-string 8 (microcode-type 'MANIFEST-NM-VECTOR))) - -) - -(define (object->bit-string object) - (bit-string-append - (unsigned-integer->bit-string 24 (primitive-datum object)) - (unsigned-integer->bit-string 8 (primitive-type object)))) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/coerce.scm b/v7/src/compiler/machines/bobcat/coerce.scm deleted file mode 100644 index 9508b2a36..000000000 --- a/v7/src/compiler/machines/bobcat/coerce.scm +++ /dev/null @@ -1,82 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/coerce.scm,v 1.7 1987/03/19 00:52:34 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; 68000 Specific Coercions - -(declare (usual-integrations)) - -(define coerce-quick - (standard-coercion - (lambda (n) - (cond ((< 0 n 8) n) - ((= n 8) 0) - (else (error "Bad quick immediate" n)))))) - -(define coerce-short-label - (standard-coercion - (lambda (offset) - (or (if (negative? offset) - (and (>= offset -128) (+ offset 256)) - (and (< offset 128) offset)) - (error "Short label out of range" offset))))) - -(define make-coercion - (coercion-maker - `((UNSIGNED . ,coerce-unsigned-integer) - (SIGNED . ,coerce-signed-integer) - (QUICK . ,coerce-quick) - (SHIFT-NUMBER . ,coerce-quick) - (SHORT-LABEL . ,coerce-short-label)))) - -(define-coercion 'UNSIGNED 1) -(define-coercion 'UNSIGNED 2) -(define-coercion 'UNSIGNED 3) -(define-coercion 'UNSIGNED 4) -(define-coercion 'UNSIGNED 5) -(define-coercion 'UNSIGNED 6) -(define-coercion 'UNSIGNED 8) -(define-coercion 'UNSIGNED 9) -(define-coercion 'UNSIGNED 10) -(define-coercion 'UNSIGNED 12) -(define-coercion 'UNSIGNED 13) -(define-coercion 'UNSIGNED 16) -(define-coercion 'UNSIGNED 32) - -(define-coercion 'SIGNED 8) -(define-coercion 'SIGNED 16) -(define-coercion 'SIGNED 32) - -(define-coercion 'QUICK 3) -(define-coercion 'SHIFT-NUMBER 3) -(define-coercion 'SHORT-LABEL 8) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/decls.scm b/v7/src/compiler/machines/bobcat/decls.scm deleted file mode 100644 index 6c6e81af2..000000000 --- a/v7/src/compiler/machines/bobcat/decls.scm +++ /dev/null @@ -1,110 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 1.1 1987/03/19 00:44:26 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Compiler File Dependencies - -(declare (usual-integrations)) - -(define (file-dependency/integration/chain filenames) - (if (not (null? (cdr filenames))) - (begin (file-dependency/integration/make (car filenames) (cdr filenames)) - (file-dependency/integration/chain (cdr filenames))))) - -(define (file-dependency/integration/join filenames dependency) - (for-each (lambda (filename) - (file-dependency/integration/make filename dependency)) - filenames)) - -(define (file-dependency/integration/make filename dependency) -#| - (sf/add-file-declarations! filename `((INTEGRATE-EXTERNAL ,@dependency))) -|# - 'DONE) - -(define (filename/append directory . names) - (map (lambda (name) - (string-append directory "/" name)) - names)) - -(define (file-dependency/syntax/join filenames dependency) - (for-each (lambda (filename) - (sf/set-file-syntax-table! filename dependency)) - filenames)) - -(define filenames/dependency-chain/base - (filename/append "base" - "object" "cfg" "ctypes" "dtypes" "bblock" "dfg" "rtltyp" - "rtlreg" "rtlcfg" "rtl" "emodel" "rtypes")) - -(define filenames/dependency-chain/rcse - (filename/append "front-end" "rcseht" "rcserq" "rcsesr" "rcseep" "rcse")) - -(define filenames/dependency-group/base - (append (filename/append "base" "linear") - (filename/append "alpha" "dflow" "graphc") - (filename/append "front-end" - "ralloc" "rcsesa" "rgcomb" "rlife" "rtlgen") - (filename/append "back-end" "lapgen"))) - -(file-dependency/integration/chain - (reverse - (append filenames/dependency-chain/base - filenames/dependency-chain/rcse))) - -(file-dependency/integration/join filenames/dependency-group/base - filenames/dependency-chain/base) - -(file-dependency/syntax/join - (append (filename/append "base" - "bblock" "cfg" "ctypes" "dfg" "dtypes" "emodel" - "linear" "object" "queue" "rtl" "rtlcfg" "rtlreg" - "rtltyp" "rtypes" "sets" "toplev" "utils") - (filename/append "alpha" "dflow" "graphc") - (filename/append "front-end" - "ralloc" "rcse" "rcseep" "rcseht" "rcserq" "rcsesa" - "rcsesr" "rgcomb" "rlife" "rtlgen") - (filename/append "back-end" - "asmmac" "block" "lapgen" "laptop" "regmap" "symtab") - (filename/append "machines/bobcat" "insmac" "machin")) - compiler-syntax-table) - -(file-dependency/syntax/join - (append (filename/append "machines/bobcat" "lapgen") - (filename/append "machines/spectrum" "lapgen")) - lap-generator-syntax-table) - -(file-dependency/syntax/join - (append (filename/append "machines/bobcat" "instr1" "instr2" "instr3") - (filename/append "machines/spectrum" "instrs")) - assembler-syntax-table) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/insmac.scm b/v7/src/compiler/machines/bobcat/insmac.scm deleted file mode 100644 index 70bd10805..000000000 --- a/v7/src/compiler/machines/bobcat/insmac.scm +++ /dev/null @@ -1,148 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insmac.scm,v 1.118 1987/03/19 00:52:58 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; 68000 Instruction Set Macros - -(declare (usual-integrations)) - -;;;; Instruction Definitions - -(syntax-table-define assembler-syntax-table 'MAKE-EA-DATABASE - (macro rules - (compile-database rules - (lambda (pattern actions) - (let ((keyword (car pattern)) - (categories (car actions)) - (mode (cadr actions)) - (register (caddr actions)) - (extension (cdddr actions))) - ;;(declare (integrate keyword categories mode register extension)) - `(MAKE-EFFECTIVE-ADDRESS - ',keyword - (LAMBDA () ,(integer-syntaxer mode 'UNSIGNED 3)) - (LAMBDA () ,(integer-syntaxer register 'UNSIGNED 3)) - (LAMBDA (IMMEDIATE-SIZE INSTRUCTION-TAIL) - ,(if (null? extension) - 'INSTRUCTION-TAIL - `(CONS-SYNTAX ,(car extension) INSTRUCTION-TAIL))) - ',categories)))))) - -(syntax-table-define assembler-syntax-table 'EXTENSION-WORD - (macro descriptors - (expand-descriptors descriptors - (lambda (instruction size source destination) - (if (or source destination) - (error "Source or destination used" 'EXTENSION-WORD) - (if (zero? (remainder size 16)) - (apply optimize-group-syntax instruction) - (error "EXTENSION-WORD: Extensions must be 16 bit multiples" - size))))))) - -(define (parse-word expression tail) - (expand-descriptors (cdr expression) - (lambda (instruction size src dst) - (if (zero? (remainder size 16)) - (let ((code - (let ((code - (let ((code (if dst `(,@dst '()) '()))) - (if src - `(,@src ,code) - code)))) - (if (null? tail) - code - `(,(if (null? code) 'CONS 'CONS-SYNTAX) - ,(car tail) - ,code))))) - `(,(if (null? code) 'CONS 'CONS-SYNTAX) - ,(apply optimize-group-syntax instruction) - ,code)) - (error "PARSE-WORD: Instructions must be 16 bit multiples" size))))) - -(define (expand-descriptors descriptors receiver) - (if (null? descriptors) - (receiver '() 0 false false) - (expand-descriptors (cdr descriptors) - (lambda (instruction* size* source* destination*) - (expand-descriptor (car descriptors) - (lambda (instruction size source destination) - (receiver (append! instruction instruction*) - (+ size size*) - (if source - (if source* - (error "Multiple source definitions" - 'EXPAND-DESCRIPTORS) - source) - source*) - (if destination - (if destination* - (error "Multiple destination definitions" - 'EXPAND-DESCRIPTORS) - destination) - destination*)))))))) - -(define (expand-descriptor descriptor receiver) - (let ((size (car descriptor)) - (expression (cadr descriptor)) - (coercion-type - (if (null? (cddr descriptor)) 'UNSIGNED (caddr descriptor)))) - (case coercion-type - ((UNSIGNED SIGNED SHIFT-NUMBER QUICK) - (receiver `(,(integer-syntaxer expression coercion-type size)) - size false false)) - ((SHORT-LABEL) - (receiver `(,(integer-syntaxer - ``(- ,,expression (+ *PC* 2)) - 'SHORT-LABEL - size)) - size false false)) - ((SOURCE-EA) - (receiver `(((EA-MODE ,expression)) - ((EA-REGISTER ,expression))) - size - `((EA-EXTENSION ,expression) ,(cadddr descriptor)) - false)) - ((DESTINATION-EA) - (receiver `(((EA-MODE ,expression)) - ((EA-REGISTER ,expression))) - size - false - `((EA-EXTENSION ,expression) '()))) - ((DESTINATION-EA-REVERSED) - (receiver `(((EA-REGISTER ,expression)) - ((EA-MODE ,expression))) - size - false - `((EA-EXTENSION ,expression) '()))) - (else - (error "EXPAND-DESCRIPTOR: Badly-formed descriptor" descriptor))))) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/instr1.scm b/v7/src/compiler/machines/bobcat/instr1.scm deleted file mode 100644 index 0c741711a..000000000 --- a/v7/src/compiler/machines/bobcat/instr1.scm +++ /dev/null @@ -1,394 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr1.scm,v 1.60 1987/03/19 00:53:05 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; 68000 Instruction Set Description -;;; Originally from GJS (who did the hard part). - -(declare (usual-integrations)) - -;;;; Effective Addressing - -(define (make-effective-address keyword mode register extension categories) - (vector ea-tag keyword mode register extension categories)) - -(define (effective-address? object) - (and (vector? object) - (not (zero? (vector-length object))) - (eq? (vector-ref object 0) ea-tag))) - -(define ea-tag - "Effective-Address") - -(define-integrable (ea-keyword ea) - (vector-ref ea 1)) - -(define-integrable (ea-mode ea) - (vector-ref ea 2)) - -(define-integrable (ea-register ea) - (vector-ref ea 3)) - -(define-integrable (ea-extension ea) - (vector-ref ea 4)) - -(define-integrable (ea-categories ea) - (vector-ref ea 5)) - -(define (ea-all expression) - (let ((match-result (pattern-lookup ea-database expression))) - (and match-result (match-result)))) - -(define ((ea-filtered filter) expression) - (let ((ea (ea-all expression))) - (and ea (filter ea) ea))) - -(define (ea-filtered-by-category category) - (ea-filtered - (lambda (ea) - (memq category (ea-categories ea))))) - -(define ea-d (ea-filtered-by-category 'DATA)) -(define ea-a (ea-filtered-by-category 'ALTERABLE)) -(define ea-c (ea-filtered-by-category 'CONTROL)) - -(define (ea-filtered-by-categories categories) - (ea-filtered - (lambda (ea) - (eq?-subset? categories (ea-categories ea))))) - -(define (eq?-subset? x y) - (or (null? x) - (and (memq (car x) y) - (eq?-subset? (cdr x) y)))) - -(define ea-d&a (ea-filtered-by-categories '(DATA ALTERABLE))) -(define ea-c&a (ea-filtered-by-categories '(CONTROL ALTERABLE))) -(define ea-m&a (ea-filtered-by-categories '(MEMORY ALTERABLE))) - -(define ea-d&-& - (ea-filtered - (lambda (ea) - (and (not (eq? (ea-keyword ea) '&)) - (memq 'DATA (ea-categories ea)))))) - -;;; These are just predicates, to be used in conjunction with EA-ALL. - -(define (ea-b=>-A ea s) - (not (and (eq? s 'B) (eq? (ea-keyword ea) 'A)))) - -(define (ea-a&-A> ea s) - (and (memq 'ALTERABLE (ea-categories ea)) (ea-b=>-A ea s))) - -;;;; Effective Address Description - -(define ea-database - (make-ea-database - ((D (? r)) (DATA ALTERABLE) #b000 r) - - ((A (? r)) (ALTERABLE) #b001 r) - - ((@A (? r)) (DATA MEMORY CONTROL ALTERABLE) #b010 r) - - ((@D (? r)) - (DATA MEMORY CONTROL ALTERABLE) #b110 #b000 - (output-@D-indirect r)) - - ((@A+ (? r)) (DATA MEMORY ALTERABLE) #b011 r) - - ((@-A (? r)) (DATA MEMORY ALTERABLE) #b100 r) - - ((@AO (? r) (? o)) - (DATA MEMORY CONTROL ALTERABLE) #b101 r - (output-16bit-offset o)) - - ((@AR (? r) (? l)) - (DATA MEMORY CONTROL ALTERABLE) #b101 r - (output-16bit-relative l)) - - ((@DO (? r) (? o)) - (DATA MEMORY CONTROL ALTERABLE) #b110 #b000 - (output-@DO-indirect r o)) - - ((@AOX (? r) (? o) (? xtype) (? xr) (? s)) - (QUALIFIER (da? xtype) (wl? s)) - (DATA MEMORY CONTROL ALTERABLE) #b110 r - (output-offset-index-register xtype xr s o)) - - ((@ARX (? r) (? l) (? xtype) (? xr) (? s)) - (QUALIFIER (da? xtype) (wl? s)) - (DATA MEMORY CONTROL ALTERABLE) #b110 r - (output-relative-index-register xtype xr s l)) - - ((W (? a)) - (DATA MEMORY CONTROL ALTERABLE) #b111 #b000 - (output-16bit-address a)) - - ((L (? a)) - (DATA MEMORY CONTROL ALTERABLE) #b111 #b001 - (output-32bit-address a)) - - ((@PCO (? o)) - (DATA MEMORY CONTROL) #b111 #b010 - (output-16bit-offset o)) - - ((@PCR (? l)) - (DATA MEMORY CONTROL) #b111 #b010 - (output-16bit-relative l)) - - ((@PCOX (? o) (? xtype) (? xr) (? s)) - (QUALIFIER (da? xtype) (wl? s)) - (DATA MEMORY CONTROL) #b111 #b011 - (output-offset-index-register xtype xr s o)) - - ((@PCRX (? l) (? xtype) (? xr) (? s)) - (QUALIFIER (da? xtype) (wl? s)) - (DATA MEMORY CONTROL) #b111 #b011 - (output-relative-index-register xtype xr s l)) - - ((& (? i)) - (DATA MEMORY) #b111 #b100 - (output-immediate-data immediate-size i)))) - -;;;; Effective Address Extensions - -(define-integrable (output-16bit-offset o) - (EXTENSION-WORD (16 o SIGNED))) - -(define-integrable (output-16bit-relative l) - (EXTENSION-WORD (16 `(- ,l *PC*) SIGNED))) - -(define-integrable (output-offset-index-register xtype xr s o) - (EXTENSION-WORD (1 (encode-da xtype)) - (3 xr) - (1 (encode-wl s)) - (3 #b000) - (8 o SIGNED))) - -(define-integrable (output-relative-index-register xtype xr s l) - (EXTENSION-WORD (1 (encode-da xtype)) - (3 xr) - (1 (encode-wl s)) - (3 #b000) - (8 `(- ,l *PC*) SIGNED))) - -(define-integrable (output-16bit-address a) - (EXTENSION-WORD (16 a))) - -(define-integrable (output-32bit-address a) - (EXTENSION-WORD (32 a))) - -(define (output-immediate-data immediate-size i) - (case immediate-size - ((B) - (EXTENSION-WORD (8 #b00000000) - (8 i SIGNED))) - ((W) - (EXTENSION-WORD (16 i SIGNED))) - ((L) - (EXTENSION-WORD (32 i SIGNED))) - (else - (error "OUTPUT-IMMEDIATE-DATA: illegal immediate size" - immediate-size)))) - -;;; New stuff for 68020 - -(define (output-brief-format-extension-word immediate-size - index-register-type index-register - index-size scale-factor - displacement) - (EXTENSION-WORD (1 (encode-da index-register-type)) - (3 index-register) - (1 (encode-wl index-size)) - (2 (encode-bwlq scale-factor)) - (1 #b0) - (8 displacement SIGNED))) - -(define (output-full-format-extension-word immediate-size - index-register-type index-register - index-size scale-factor - base-suppress? index-suppress? - base-displacement-size - base-displacement - memory-indirection-type - outer-displacement-size - outer-displacement) - (EXTENSION-WORD (1 (encode-da index-register-type)) - (3 index-register) - (1 (encode-wl index-size)) - (2 (encode-bwlq scale-factor)) - (1 #b1) - (1 (if base-suppress? #b1 #b0)) - (1 (if index-suppress? #b1 #b0)) - (2 (encode-nwl base-displacement-size)) - (1 #b0) - (3 (case memory-indirection-type - ((#F) #b000) - ((PRE) (encode-nwl outer-displacement-size)) - ((POST) - (+ #b100 (encode-nwl outer-displacement-size)))))) - (output-displacement base-displacement-size base-displacement) - (output-displacement outer-displacement-size outer-displacement)) - -(define (output-displacement size displacement) - (case size - ((N)) - ((W) (EXTENSION-WORD (16 displacement SIGNED))) - ((L) (EXTENSION-WORD (32 displacement SIGNED))))) - -(define-integrable (output-@D-indirect register) - (EXTENSION-WORD (1 #b0) ;index register = data - (3 register) - (1 #b1) ;index size = longword - (2 #b00) ;scale factor = 1 - (1 #b1) - (1 #b1) ;suppress base register - (1 #b0) ;don't suppress index register - (2 #b01) ;null base displacement - (1 #b0) - (3 #b000) ;no memory indirection - )) - -(define (output-@DO-indirect register displacement) - (EXTENSION-WORD (1 #b0) ;index register = data - (3 register) - (1 #b1) ;index size = 32 bits - (2 #b00) ;scale factor = 1 - (1 #b1) - (1 #b1) ;suppress base register - (1 #b0) ;don't suppress index register - (2 #b10) ;base displacement size = 16 bits - (1 #b0) - (3 #b000) ;no memory indirection - (16 displacement SIGNED))) - -;;;; Operand Syntaxers. - -(define (immediate-words data size) - (case size - ((B) (immediate-byte data)) - ((W) (immediate-word data)) - ((L) (immediate-long data)) - (else (error "IMMEDIATE-WORD: Illegal size" size)))) - -(define-integrable (immediate-byte data) - `(GROUP ,(make-bit-string 8 0) - ,(syntax-evaluation data coerce-8-bit-signed))) - -(define-integrable (immediate-word data) - (syntax-evaluation data coerce-16-bit-signed)) - -(define-integrable (immediate-long data) - (syntax-evaluation data coerce-32-bit-signed)) - -(define-integrable (relative-word address) - (syntax-evaluation `(- ,address *PC*) coerce-16-bit-signed)) - -(define-integrable (offset-word data) - (syntax-evaluation data coerce-16-bit-signed)) - -(define-integrable (output-bit-string bit-string) - bit-string) - -;;;; Symbolic Constants - -;(declare (integrate symbol-member bwl? bw? wl? rl? us? da? cc? nwl? bwlq?)) - -(define ((symbol-member list) expression) -; (declare (integrate list expression)) - (memq expression list)) - -(define bwl? (symbol-member '(B W L))) -(define bw? (symbol-member '(B W))) -(define wl? (symbol-member '(W L))) -(define rl? (symbol-member '(R L))) -(define us? (symbol-member '(U S))) -(define da? (symbol-member '(D A))) -(define nwl? (symbol-member '(N W L))) -(define bwlq? (symbol-member '(B W L Q))) - -(define cc? - (symbol-member - '(T F HI LS HS LO CC CS NE EQ VC VS PL MI GE LT GT LE))) - -;(declare (integrate symbol-mapping encode-bwl encode-blw encode-bw encode-wl -; encode-lw encode-rl encode-us encode-da granularity -; encode-cc encode-nwl encode-bwlq)) - -(define ((symbol-mapping alist) expression) -; (declare (integrate alist expression)) - (cdr (assq expression alist))) - -(define encode-bwl (symbol-mapping '((B . 0) (W . 1) (L . 2)))) -(define encode-blw (symbol-mapping '((B . 1) (W . 3) (L . 2)))) -(define encode-bw (symbol-mapping '((B . 0) (W . 1)))) -(define encode-wl (symbol-mapping '((W . 0) (L . 1)))) -(define encode-lw (symbol-mapping '((W . 1) (L . 0)))) -(define encode-rl (symbol-mapping '((R . 0) (L . 1)))) -(define encode-us (symbol-mapping '((U . 0) (S . 1)))) -(define encode-da (symbol-mapping '((D . 0) (A . 1)))) -(define granularity (symbol-mapping '((B . 8) (W . 16) (L . 32)))) -(define encode-nwl (symbol-mapping '((N . 1) (W . 2) (L . 3)))) -(define encode-bwlq (symbol-mapping '((B . 0) (W . 1) (L . 2) (Q . 3)))) - -(define encode-cc - (symbol-mapping - '((T . 0) (F . 1) (HI . 2) (LS . 3) (HS . 4) (LO . 5) - (CC . 4) (CS . 5) (NE . 6) (EQ . 7) (VC . 8) (VS . 9) - (PL . 10) (MI . 11) (GE . 12) (LT . 13) (GT . 14) (LE . 15)))) - -(define (register-list? expression) - (eq?-subset? expression '(D0 D1 D2 D3 D4 D5 D6 D7 A0 A1 A2 A3 A4 A5 A6 A7))) - -(define ((encode-register-list encoding) registers) - (let ((bit-string (make-bit-string 16 #!FALSE))) - (for-each (lambda (register) - (bit-string-set! bit-string (cdr (assq register encoding)))) - registers) - bit-string)) - -(define encode-c@a+register-list - (encode-register-list - '((A7 . 0) (A6 . 1) (A5 . 2) (A4 . 3) (A3 . 4) (A2 . 5) (A1 . 6) (A0 . 7) - (D7 . 8) (D6 . 9) (D5 . 10) (D4 . 11) (D3 . 12) (D2 . 13) - (D1 . 14) (D0 . 15)))) - -(define encode-@-aregister-list - (encode-register-list - '((D0 . 0) (D1 . 1) (D2 . 2) (D3 . 3) (D4 . 4) (D5 . 5) (D6 . 6) (D7 . 7) - (A0 . 8) (A1 . 9) (A2 . 10) (A3 . 11) (A4 . 12) (A5 . 13) - (A6 . 14) (A7 . 15)))) - -(define-instruction DC - ((W (? expression)) - (WORD (16 expression SIGNED)))) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/instr2.scm b/v7/src/compiler/machines/bobcat/instr2.scm deleted file mode 100644 index b2f9ef748..000000000 --- a/v7/src/compiler/machines/bobcat/instr2.scm +++ /dev/null @@ -1,340 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr2.scm,v 1.9 1987/03/19 00:53:15 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; 68000 Instruction Set Description -;;; Originally from GJS (who did the hard part). - -(declare (usual-integrations)) - -;;;; BCD Arithmetic - -(let-syntax ((define-BCD-addition - (macro (keyword opcode) - `(define-instruction ,keyword - (((D (? ry)) (D (? rx))) - (WORD (4 ,opcode) - (3 rx) - (6 #b100000) - (3 ry))) - - (((@-A (? ry)) (@-A (? rx))) - (WORD (4 ,opcode) - (3 rx) - (6 #b100001) - (3 ry))))))) - (define-BCD-addition ABCD #b1100) - (define-BCD-addition SBCD #b1000)) - -(define-instruction NBCD - ((? dea ea-d&a) - (WORD (10 #b0100100000) - (6 dea DESTINATION-EA)))) - -;;;; Binary Arithmetic - -(let-syntax ((define-binary-addition - (macro (keyword Qkeyword Xkeyword opcode Qbit Iopcode) - `(BEGIN - (define-instruction ,Qkeyword - (((? s) (& (? data)) (? ea ea-all)) - (QUALIFIER (bwl? s) (ea-a&-A> ea s)) - (WORD (4 #b0101) - (3 data QUICK) - (1 ,Qbit) - (2 (encode-bwl s)) - (6 ea DESTINATION-EA)))) - - (define-instruction ,keyword - (((? s) (& (? data)) (? ea ea-d&a)) ;ADDI - (QUALIFIER (bwl? s)) - (WORD (4 #b0000) - (4 ,Iopcode) - (2 (encode-bwl s)) - (6 ea DESTINATION-EA)) - (immediate-words data s)) - - (((? s) (? ea ea-all) (D (? rx))) - (QUALIFIER (bwl? s) (ea-b=>-A ea s)) - (WORD (4 ,opcode) - (3 rx) - (1 #b0) - (2 (encode-bwl s)) - (6 ea SOURCE-EA s))) - - (((? s) (D (? rx)) (? ea ea-m&a)) - (QUALIFIER (bwl? s)) - (WORD (4 ,opcode) - (3 rx) - (1 #b1) - (2 (encode-bwl s)) - (6 ea DESTINATION-EA))) - - (((? s) (? ea ea-all) (A (? rx))) ;ADDA - (QUALIFIER (wl? s)) - (WORD (4 ,opcode) - (3 rx) - (1 (encode-wl s)) - (2 #b11) - (6 ea SOURCE-EA s)))) - - (define-instruction ,Xkeyword - (((? s) (D (? ry)) (D (? rx))) - (QUALIFIER (bwl? s)) - (WORD (4 ,opcode) - (3 rx) - (1 #b1) - (2 (encode-bwl s)) - (3 #b000) - (3 ry))) - - (((? s) (@-A (? ry)) (@-A (? rx))) - (QUALIFIER (bwl? s)) - (WORD (4 ,opcode) - (3 rx) - (1 #b1) - (2 (encode-bwl s)) - (3 #b001) - (3 ry)))))))) - (define-binary-addition ADD ADDQ ADDX #b1101 #b0 #b0110) - (define-binary-addition SUB SUBQ SUBX #b1001 #b1 #b0100)) - -(define-instruction DIV - (((? sgn) (D (? rx)) (? ea ea-d)) - (QUALIFIER (us? sgn)) - (WORD (4 #b1000) - (3 rx) - (1 (encode-us sgn)) - (2 #b11) - (6 ea SOURCE-EA 'W)))) - -(define-instruction EXT - (((? s) (D (? rx))) - (QUALIFIER (wl? s)) - (WORD (9 #b010010001) - (1 (encode-wl s)) - (3 #b000) - (3 rx)))) - -(define-instruction MUL - (((? sgn) (? ea ea-d) (D (? rx))) - (QUALIFIER (us? sgn)) - (WORD (4 #b1100) - (3 rx) - (1 (encode-us sgn)) - (2 #b11) - (6 ea SOURCE-EA 'W)))) - -(define-instruction NEG - (((? s) (? dea ea-d&a)) - (QUALIFIER (bwl? s)) - (WORD (8 #b01000100) - (2 (encode-bwl s)) - (6 dea DESTINATION-EA)))) - -(define-instruction NEGX - (((? s) (? dea ea-d&a)) - (QUALIFIER (bwl? s)) - (WORD (8 #b01000000) - (2 (encode-bwl s)) - (6 dea DESTINATION-EA)))) - -;;;; Comparisons - -(define-instruction CMP - (((? s) (? ea ea-all) (D (? rx))) - (QUALIFIER (bwl? s) (ea-b=>-A ea s)) - (WORD (4 #b1011) - (3 rx) - (1 #b0) - (2 (encode-bwl s)) - (6 ea SOURCE-EA s))) - - (((? s) (? ea ea-all) (A (? rx))) ;CMPA - (QUALIFIER (wl? s)) - (WORD (4 #b1011) - (3 rx) - (1 (encode-wl s)) - (2 #b11) - (6 ea SOURCE-EA s))) - - (((? s) (& (? data)) (? ea ea-d&a)) ;CMPI - (QUALIFIER (bwl? s)) - (WORD (8 #b00001100) - (2 (encode-bwl s)) - (6 ea DESTINATION-EA)) - (immediate-words data s)) - - (((? s) (@A+ (? ry)) (@A+ (? rx))) ;CMPM - (QUALIFIER (bwl? s)) - (WORD (4 #b1011) - (3 rx) - (1 #b1) - (2 (encode-bwl s)) - (3 #b001) - (3 ry)))) - -(define-instruction TST - (((? s) (? dea ea-d&a)) - (QUALIFIER (bwl? s)) - (WORD (8 #b01001010) - (2 (encode-bwl s)) - (6 dea DESTINATION-EA)))) - -;;;; Bitwise Logical - -(let-syntax ((define-bitwise-logical - (macro (keyword opcode Iopcode) - `(define-instruction ,keyword - (((? s) (? ea ea-d) (D (? rx))) - (QUALIFIER (bwl? s)) - (WORD (4 ,opcode) - (3 rx) - (1 #b0) - (2 (encode-bwl s)) - (6 ea SOURCE-EA s))) - - (((? s) (D (? rx)) (? ea ea-m&a)) - (QUALIFIER (bwl? s)) - (WORD (4 ,opcode) - (3 rx) - (1 #b1) - (2 (encode-bwl s)) - (6 ea DESTINATION-EA))) - - (((? s) (& (? data)) (? ea ea-d&a)) ;fooI - (QUALIFIER (bwl? s)) - (WORD (4 #b0000) - (4 ,Iopcode) - (2 (encode-bwl s)) - (6 ea DESTINATION-EA)) - (immediate-words data s)) - - (((? s) (& (? data)) (SR)) ;fooI to CCR/SR - (QUALIFIER (bw? s)) - (WORD (4 #b0000) - (4 ,Iopcode) - (2 (encode-bwl s)) - (6 #b111100)) - (immediate-words data s)))))) - (define-bitwise-logical AND #b1100 #b0010) - (define-bitwise-logical OR #b1000 #b0000)) - -(define-instruction EOR - (((? s) (D (? rx)) (? ea ea-d&a)) - (QUALIFIER (bwl? s)) - (WORD (4 #b1011) - (3 rx) - (1 #b1) - (2 (encode-bwl s)) - (6 ea DESTINATION-EA))) - - (((? s) (& (? data)) (? ea ea-d&a)) ;EORI - (QUALIFIER (bwl? s)) - (WORD (8 #b00001010) - (2 (encode-bwl s)) - (6 ea DESTINATION-EA)) - (immediate-words data s)) - - (((? s) (& (? data)) (SR)) ;EORI to CCR/SR - (QUALIFIER (bw? s)) - (WORD (8 #b00001010) - (2 (encode-bwl s)) - (6 #b111100)) - (immediate-words data s))) - -(define-instruction NOT - (((? s) (? dea ea-d&a)) - (QUALIFIER (bwl? s)) - (WORD (8 #b01000110) - (2 (encode-bwl s)) - (6 dea DESTINATION-EA)))) - -;;;; Shift - -(let-syntax ((define-shift-instruction - (macro (keyword bits) - `(define-instruction ,keyword - (((? d) (? s) (D (? ry)) (D (? rx))) - (QUALIFIER (rl? d) (bwl? s)) - (WORD (4 #b1110) - (3 rx) - (1 (encode-rl d)) - (2 (encode-bwl s)) - (1 #b1) - (2 ,bits) - (3 ry))) - - (((? d) (? s) (& (? data)) (D (? ry))) - (QUALIFIER (rl? d) (bwl? s)) - (WORD (4 #b1110) - (3 data SHIFT-NUMBER) - (1 (encode-rl d)) - (2 (encode-bwl s)) - (1 #b0) - (2 ,bits) - (3 ry))) - - (((? d) (? ea ea-m&a)) - (QUALIFIER (rl? d)) - (WORD (5 #b11100) - (2 ,bits) - (1 (encode-rl d)) - (2 #b11) - (6 ea DESTINATION-EA))))))) - (define-shift-instruction AS #b00) - (define-shift-instruction LS #b01) - (define-shift-instruction ROX #b10) - (define-shift-instruction RO #b11)) - -;;;; Bit Manipulation - -(let-syntax ((define-bit-manipulation - (macro (keyword bits ea-register-target ea-immediate-target) - `(define-instruction ,keyword - (((D (? rx)) (? ea ,ea-register-target)) - (WORD (4 #b0000) - (3 rx) - (1 #b1) - (2 ,bits) - (6 ea DESTINATION-EA))) - - (((& (? bitnum)) (? ea ,ea-immediate-target)) - (WORD (8 #b00001000) - (2 ,bits) - (6 ea DESTINATION-EA)) - (immediate-byte bitnum)))))) - (define-bit-manipulation BTST #b00 ea-d ea-d&-&) - (define-bit-manipulation BCHG #b01 ea-d&a ea-d&a) - (define-bit-manipulation BCLR #b10 ea-d&a ea-d&a) - (define-bit-manipulation BSET #b11 ea-d&a ea-d&a)) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/instr3.scm b/v7/src/compiler/machines/bobcat/instr3.scm deleted file mode 100644 index 045d6090d..000000000 --- a/v7/src/compiler/machines/bobcat/instr3.scm +++ /dev/null @@ -1,361 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr3.scm,v 1.9 1987/03/19 00:53:25 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; 68000 Instruction Set Description -;;; Originally from GJS (who did the hard part). - -(declare (usual-integrations)) - -;;;; Control Transfer - -(define-instruction B - (((? c) S (@PCO (? o))) - (QUALIFIER (cc? c)) - (WORD (4 #b0110) - (4 (encode-cc c)) - (8 o SIGNED))) - - (((? c) S (@PCR (? l))) - (QUALIFIER (cc? c)) - (WORD (4 #b0110) - (4 (encode-cc c)) - (8 l SHORT-LABEL))) - - (((? c) L (@PCO (? o))) - (QUALIFIER (cc? c)) - (WORD (4 #b0110) - (4 (encode-cc c)) - (8 #b00000000)) - (immediate-word o)) - - (((? c) L (@PCR (? l))) - (QUALIFIER (cc? c)) - (WORD (4 #b0110) - (4 (encode-cc c)) - (8 #b00000000)) - (relative-word l))) - -(define-instruction BRA - ((S (@PCO (? o))) - (WORD (8 #b01100000) - (8 o SIGNED))) - - ((S (@PCR (? l))) - (WORD (8 #b01100000) - (8 l SHORT-LABEL))) - - ((L (@PCO (? o))) - (WORD (16 #b0110000000000000)) - (immediate-word o)) - - ((L (@PCR (? l))) - (WORD (16 #b0110000000000000)) - (relative-word l))) - -(define-instruction BSR - ((S (@PCO (? o))) - (WORD (8 #b01100001) - (8 o SIGNED))) - - ((S (@PCR (? o))) - (WORD (8 #b01100001) - (8 o SHORT-LABEL))) - - ((L (@PCO (? o))) - (WORD (16 #b0110000100000000)) - (immediate-word o)) - - ((L (@PCR (? l))) - (WORD (16 #b0110000100000000)) - (relative-word l))) - -(define-instruction DB - (((? c) (D (? rx)) (@PCO (? o))) - (QUALIFIER (cc? c)) - (WORD (4 #b0101) - (4 (encode-cc c)) - (5 #b11001) - (3 rx)) - (immediate-word o)) - - (((? c) (D (? rx)) (@PCR (? l))) - (QUALIFIER (cc? c)) - (WORD (4 #b0101) - (4 (encode-cc c)) - (5 #b11001) - (3 rx)) - (relative-word l))) - -(define-instruction JMP - (((? ea ea-c)) - (WORD (10 #b0100111011) - (6 ea DESTINATION-EA)))) - -(define-instruction JSR - (((? ea ea-c)) - (WORD (10 #b0100111010) - (6 ea DESTINATION-EA)))) - -(define-instruction RTE - (() - (WORD (16 #b0100111001110011)))) - -(define-instruction RTR - (() - (WORD (16 #b0100111001110111)))) - -(define-instruction RTS - (() - (WORD (16 #b0100111001110101)))) - -(define-instruction TRAP - (((& (? v))) - (WORD (12 #b010011100100) - (4 v)))) - -(define-instruction TRAPV - (() - (WORD (16 #b0100111001110110)))) - -;;;; Randomness - -(define-instruction CHK - (((? ea ea-d) (D (? rx))) - (WORD (4 #b0100) - (3 rx) - (3 #b110) - (6 ea SOURCE-EA 'W)))) - -(define-instruction LINK - (((A (? rx)) (& (? d))) - (WORD (13 #b0100111001010) - (3 rx)) - (immediate-word d))) - -(define-instruction NOP - (() - (WORD (16 #b0100111001110001)))) - -(define-instruction RESET - (() - (WORD (16 #b0100111001110000)))) - -(define-instruction STOP - (((& (? data))) - (WORD (16 #b0100111001110010)) - (immediate-word data))) - -(define-instruction SWAP - (((D (? rx))) - (WORD (13 #b0100100001000) - (3 rx)))) - -(define-instruction UNLK - (((A (? rx))) - (WORD (13 #b0100111001011) - (3 rx)))) - -;;;; Data Transfer - -(define-instruction CLR - (((? s) (? ea ea-d&a)) - (QUALIFIER (bwl? s)) - (WORD (8 #b01000010) - (2 (encode-bwl s)) - (6 ea DESTINATION-EA)))) - -(define-instruction EXG - (((D (? rx)) (D (? ry))) - (WORD (4 #b1100) - (3 rx) - (6 #b101000) - (3 ry))) - - (((A (? rx)) (A (? ry))) - (WORD (4 #b1100) - (3 rx) - (6 #b101001) - (3 ry))) - - (((D (? rx)) (A (? ry))) - (WORD (4 #b1100) - (3 rx) - (6 #b110001) - (3 ry))) - - (((A (? ry)) (D (? rx))) - (WORD (4 #b1100) - (3 rx) - (6 #b110001) - (3 ry)))) - -(define-instruction LEA - (((? ea ea-c) (A (? rx))) - (WORD (4 #b0100) - (3 rx) - (3 #b111) - (6 ea DESTINATION-EA)))) - -(define-instruction PEA - (((? cea ea-c)) - (WORD (10 #b0100100001) - (6 cea DESTINATION-EA)))) - -(define-instruction S - (((? c) (? dea ea-d&a)) - (QUALIFIER (cc? c)) - (WORD (4 #b0101) - (4 (encode-cc c)) - (2 #b11) - (6 dea DESTINATION-EA)))) - -(define-instruction TAS - (((? dea ea-d&a)) - (WORD (10 #b0100101011) - (6 dea DESTINATION-EA)))) - -(define-instruction MOVEQ - (((& (? data)) (D (? rx))) - (WORD (4 #b0111) - (3 rx) - (1 #b0) - (8 data SIGNED)))) - -(define-instruction MOVE - (((? s) (? sea ea-all) (A (? rx))) ;MOVEA - (QUALIFIER (wl? s)) - (WORD (3 #b001) - (1 (encode-lw s)) - (3 rx) - (3 #b001) - (6 sea SOURCE-EA s))) - - (((? s) (? sea ea-all) (? dea ea-d&a)) - (QUALIFIER (bwl? s) (ea-b=>-A sea s)) - (WORD (2 #b00) - (2 (encode-blw s)) - (6 dea DESTINATION-EA-REVERSED) - (6 sea SOURCE-EA s))) - - ((W (? ea ea-d) (CCR)) ;MOVE to CCR - (WORD (10 #b0100010011) - (6 ea SOURCE-EA 'W))) - - ((W (? ea ea-d) (SR)) ;MOVE to SR - (WORD (10 #b0100011011) - (6 ea SOURCE-EA 'W))) - - ((W (SR) (? ea ea-d&a)) ;MOVE from SR - (WORD (10 #b0100000011) - (6 ea DESTINATION-EA))) - - ((L (USP) (A (? rx))) ;MOVE from USP - (WORD (13 #b0100111001101) - (3 rx))) - - ((L (A (? rx)) (USP)) ;MOVE to USP - (WORD (13 #b0100111001100) - (3 rx)))) - -(define-instruction MOVEM - (((? s) (? r) (? dea ea-c&a)) - (QUALIFIER (wl? s) (register-list? r)) - (WORD (9 #b010010001) - (1 (encode-wl s)) - (6 dea DESTINATION-EA)) - (output-bit-string (encode-c@a+register-list r))) - - (((? s) (? r) (@-a (? rx))) - (QUALIFIER (wl? s) (register-list? r)) - (WORD (9 #b010010001) - (1 (encode-wl s)) - (3 #b100) - (3 rx)) - (output-bit-string (encode-@-aregister-list r))) - - (((? s) (? sea ea-c) (? r)) - (QUALIFIER (wl? s) (register-list? r)) - (WORD (9 #b010011001) - (1 (encode-wl s)) - (6 sea SOURCE-EA s)) - (output-bit-string (encode-c@a+register-list r))) - - (((? s) (@A+ (? rx)) (? r)) - (QUALIFIER (wl? s) (register-list? r)) - (WORD (9 #b010011001) - (1 (encode-wl s)) - (3 #b011) - (3 rx)) - (output-bit-string (encode-c@a+register-list r)))) - -(define-instruction MOVEP - (((? s) (D (? rx)) (@AO (? ry) (? o))) - (QUALIFIER (wl? s)) - (WORD (4 #b0000) - (3 rx) - (2 #b11) - (1 (encode-wl s)) - (3 #b001) - (3 ry)) - (offset-word o)) - - (((? s) (D (? rx)) (@AR (? ry) (? l))) - (QUALIFIER (wl? s)) - (WORD (4 #b0000) - (3 rx) - (2 #b11) - (1 (encode-wl s)) - (3 #b001) - (3 ry)) - (relative-word l)) - - (((? s) (@AO (? ry) (? o)) (D (? rx))) - (QUALIFIER (wl? s)) - (WORD (4 #b0000) - (3 rx) - (2 #b10) - (1 (encode-wl s)) - (3 #b001) - (3 ry)) - (offset-word o)) - - (((? s) (@AR (? ry) (? l)) (D (? rx))) - (QUALIFIER (wl? s)) - (WORD (4 #b0000) - (3 rx) - (2 #b10) - (1 (encode-wl s)) - (3 #b001) - (3 ry)) - (relative-word l))) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm deleted file mode 100644 index 9d807240f..000000000 --- a/v7/src/compiler/machines/bobcat/lapgen.scm +++ /dev/null @@ -1,752 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 1.156 1987/04/12 00:24:56 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; RTL Rules for 68020 - -(declare (usual-integrations)) - -;;;; Basic machine instructions - -(define (register->register-transfer source target) - `(,(machine->machine-register source target))) - -(define (home->register-transfer source target) - `(,(pseudo->machine-register source target))) - -(define (register->home-transfer source target) - `(,(machine->pseudo-register source target))) - -(define-integrable (pseudo->machine-register source target) - (memory->machine-register (pseudo-register-home source) target)) - -(define-integrable (machine->pseudo-register source target) - (machine-register->memory source (pseudo-register-home target))) - -(define-integrable (pseudo-register-home register) - (offset-reference regnum:regs-pointer - (+ #x000A (register-renumber register)))) - -(define-integrable (machine->machine-register source target) - `(MOVE L ,(register-reference source) ,(register-reference target))) - -(define-integrable (machine-register->memory source target) - `(MOVE L ,(register-reference source) ,target)) - -(define-integrable (memory->machine-register source target) - `(MOVE L ,source ,(register-reference target))) - -(define (offset-reference register offset) - (if (zero? offset) - (if (< register 8) - `(@D ,register) - `(@A ,(- register 8))) - (if (< register 8) - `(@DO ,register ,(* 4 offset)) - `(@AO ,(- register 8) ,(* 4 offset))))) - -(define (load-dnw n d) - (cond ((zero? n) `(CLR W (D ,d))) - ((<= -128 n 127) `(MOVEQ (& ,n) (D ,d))) - (else `(MOVE W (& ,n) (D ,d))))) - -(define (test-dnw n d) - (if (zero? n) - `(TST W (D ,d)) - `(CMP W (& ,n) (D ,d)))) - -(define (increment-anl an n) - (case n - ((0) '()) - ((1 2) `((ADDQ L (& ,(* 4 n)) (A ,an)))) - ((-1 -2) `((SUBQ L (& ,(* -4 n)) (A ,an)))) - (else `((LEA (@AO ,an ,(* 4 n)) (A ,an)))))) - -(define (load-constant constant target) - (if (non-pointer-object? constant) - (load-non-pointer (primitive-type constant) - (primitive-datum constant) - target) - `(MOVE L (@PCR ,(constant->label constant)) ,target))) - -(define (load-non-pointer type datum target) - (cond ((not (zero? type)) - `(MOVE L (& ,(make-non-pointer-literal type datum)) ,target)) - ((and (zero? datum) - (memq (car target) '(D @D @A @A+ @-A @AO @DO @AOX W L))) - `(CLR L ,target)) - ((and (<= -128 datum 127) (eq? (car target) 'D)) - `(MOVEQ (& ,datum) ,target)) - (else - `(MOVE L (& ,datum) ,target)))) - -(define (test-byte n expression) - (if (and (zero? n) (TSTable-expression? expression)) - `(TST B ,expression) - `(CMP B (& ,n) ,expression))) - -(define (test-non-pointer type datum expression) - (if (and (zero? type) (zero? datum) (TSTable-expression? expression)) - `(TST L ,expression) - `(CMP L (& ,(make-non-pointer-literal type datum)) ,expression))) - -(define make-non-pointer-literal - (let ((type-scale-factor (expt 2 24))) - (lambda (type datum) - (+ (* type type-scale-factor) datum)))) - -(define (set-standard-branches! cc) - (set-current-branches! (lambda (label) - `((B ,cc L (@PCR ,label)))) - (lambda (label) - `((B ,(invert-cc cc) L (@PCR ,label)))))) - -(define (invert-cc cc) - (cdr (or (assq cc - '((T . F) (F . T) - (HI . LS) (LS . HI) - (HS . LO) (LO . HS) - (CC . CS) (CS . CC) - (NE . EQ) (EQ . NE) - (VC . VS) (VS . VC) - (PL . MI) (MI . PL) - (GE . LT) (LT . GE) - (GT . LE) (LE . GT) - )) - (error "INVERT-CC: Not a known CC" cc)))) - -(define (expression->machine-register! expression register) - (let ((target (register-reference register))) - (let ((result - (case (car expression) - ((REGISTER) `((MOVE L ,(coerce->any (cadr expression)) ,target))) - ((OFFSET) - `((MOVE L ,(indirect-reference! (cadadr expression) - (caddr expression)) - ,target))) - ((CONSTANT) `(,(load-constant (cadr expression) target))) - (else (error "Bad expression type" (car expression)))))) - (delete-machine-register! register) - result))) - -(define-integrable (TSTable-expression? expression) - (memq (car expression) '(D @D @A @A+ @-A @DO @AO @AOX W L))) - -(define-integrable (register-expression? expression) - (memq (car expression) '(A D))) - -(define (indirect-reference! register offset) - (offset-reference - (if (machine-register? register) - register - (or (register-alias register false) - ;; This means that someone has written an address out - ;; to memory, something that should never happen. - (error "Needed to load indirect register!" register))) - offset)) - -(define (coerce->any register) - (if (machine-register? register) - (register-reference register) - (let ((alias (register-alias register false))) - (if alias - (register-reference alias) - (pseudo-register-home register))))) - -(define (code-object-label-initialize code-object) - false) - -(define (generate-n-times n limit instruction with-counter) - (if (<= n limit) - (let loop ((n n)) - (if (zero? n) - '() - `(,instruction - ,@(loop (-1+ n))))) - (let ((loop (generate-label 'LOOP))) - (with-counter - (lambda (counter) - `(,(load-dnw (-1+ n) counter) - (LABEL ,loop) - ,instruction - (DB F (D ,counter) (@PCR ,loop)))))))) - -(define-integrable (data-register? register) - (< register 8)) - -(define (address-register? register) - (and (< register 16) - (>= register 8))) - -;;;; Registers/Entries - -(let-syntax ((define-entries - (macro names - (define (loop names index) - (if (null? names) - '() - (cons `(DEFINE ,(symbol-append 'ENTRY:COMPILER- - (car names)) - '(@AO 6 ,index)) - (loop (cdr names) (+ index 6))))) - `(BEGIN ,@(loop names #x00F0))))) - (define-entries apply error wrong-number-of-arguments interrupt-procedure - interrupt-continuation lookup-apply lookup access unassigned? unbound? - set! define primitive-apply enclose setup-lexpr setup-ic-procedure)) - -(define reg:temp '(@AO 6 #x0010)) -(define reg:enclose-result '(@AO 6 #x0014)) -(define reg:compiled-memtop '(@A 6)) - -(define popper:apply-closure '(@AO 6 #x0168)) -(define popper:apply-stack '(@AO 6 #x01A8)) -(define popper:value '(@AO 6 #x01E8)) - -;;;; Transfers to Registers - -;;; All assignments to pseudo registers are required to delete the -;;; dead registers BEFORE performing the assignment. This is because -;;; the register being assigned may be PSEUDO-REGISTER=? to one of the -;;; dead registers, and thus would be flushed if the deletions -;;; happened after the assignment. - -(define-rule statement - (ASSIGN (REGISTER 15) (OFFSET-ADDRESS (REGISTER 15) (? n))) - (increment-anl 7 n)) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (CONSTANT (? source))) - `(,(load-constant source (coerce->any target)))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (REGISTER (? source))) - (QUALIFIER (pseudo-register? target)) - (move-to-alias-register! source 'DATA target) - '()) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source)))) - (QUALIFIER (pseudo-register? target)) - (let ((target (move-to-alias-register! source 'DATA target))) - `((AND L ,mask-reference ,target)))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source)))) - (QUALIFIER (pseudo-register? target)) - (let ((target (move-to-alias-register! source 'DATA target))) - `((RO L L (& 8) ,target)))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset))) - (QUALIFIER (pseudo-register? target)) - (let ((source (indirect-reference! address offset))) - (delete-dead-registers!) - ;; The fact that the target register here is a data register is a - ;; heuristic that works reasonably well since if the value is a - ;; pointer, we will probably want to dereference it, which - ;; requires that we first mask it. - `((MOVE L ,source - ,(register-reference (allocate-alias-register! target 'DATA)))))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 15) 1)) - (let ((target* (coerce->any target))) - (if (pseudo-register? target) - (delete-dead-registers!)) - `((MOVE L (@A+ 7) ,target*)))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) - (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum)))) - (let ((target* (coerce->any target)) - (datum (coerce->any datum))) - (if (pseudo-register? target) - (delete-dead-registers!)) - (if (register-expression? target*) - `((MOVE L ,datum ,reg:temp) - (MOVE B (& ,type) ,reg:temp) - (MOVE L ,reg:temp ,target*)) - `((MOVE L ,datum ,target*) - (MOVE B (& ,type) ,target*))))) - -;;;; Transfers to Memory - -(define-rule statement - (ASSIGN (OFFSET (REGISTER (? a)) (? n)) - (CONSTANT (? object))) - `(,(load-constant object (indirect-reference! a n)))) - -(define-rule statement - (ASSIGN (OFFSET (REGISTER (? a)) (? n)) - (REGISTER (? r))) - `((MOVE L ,(coerce->any r) ,(indirect-reference! a n)))) - -(define-rule statement - (ASSIGN (OFFSET (REGISTER (? a)) (? n)) - (POST-INCREMENT (REGISTER 15) 1)) - `((MOVE L (@A+ 7) ,(indirect-reference! a n)))) - -(define-rule statement - (ASSIGN (OFFSET (REGISTER (? a)) (? n)) - (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r)))) - (let ((target (indirect-reference! a n))) - `((MOVE L ,(coerce->any r) ,target) - (MOVE B (& ,type) ,target)))) - -(define-rule statement - (ASSIGN (OFFSET (REGISTER (? a0)) (? n0)) - (OFFSET (REGISTER (? a1)) (? n1))) - (let ((source (indirect-reference! a1 n1))) - `((MOVE L ,source ,(indirect-reference! a0 n0))))) - -;;;; Consing - -(define-rule statement - (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (CONSTANT (? object))) - `(,(load-constant object '(@A+ 5)))) - -(define-rule statement - (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (UNASSIGNED)) - `(,(load-non-pointer type-code:unassigned 0 '(@A+ 5)))) - -(define-rule statement - (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (REGISTER (? r))) - `((MOVE L ,(coerce->any r) (@A+ 5)))) - -(define-rule statement - (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (OFFSET (REGISTER (? r)) (? n))) - `((MOVE L ,(indirect-reference! r n) (@A+ 5)))) - -(define-rule statement - (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (ENTRY:PROCEDURE (? procedure))) - (let ((temporary - (register-reference (allocate-temporary-register! 'ADDRESS)))) - `((LEA (@PCR ,(procedure-external-label procedure)) ,temporary) - (MOVE L ,temporary (@A+ 5)) - (MOVE B (& ,type-code:return-address) (@AO 5 -4))))) - -;;;; Pushes - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (CONSTANT (? object))) - `(,(load-constant object '(@-A 7)))) - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (UNASSIGNED)) - `(,(load-non-pointer type-code:unassigned 0 '(@-A 7)))) - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (REGISTER (? r))) - `((MOVE L ,(coerce->any r) (@-A 7)))) - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) - (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r)))) - `((MOVE L ,(coerce->any r) (@-A 7)) - (MOVE B (& ,type) (@A 7)))) - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (OFFSET (REGISTER (? r)) (? n))) - `((MOVE L ,(indirect-reference! r n) (@-A 7)))) - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) - (OFFSET-ADDRESS (REGISTER 15) (? n))) - `((PEA ,(offset-reference a7 n)) - (MOVE B (& ,type-code:stack-environment) (@A 7)))) - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) - (ENTRY:CONTINUATION (? continuation))) - `((PEA (@PCR ,(continuation-label continuation))) - (MOVE B (& ,type-code:return-address) (@A 7)))) - -;;;; Predicates - -(define-rule predicate - (TRUE-TEST (REGISTER (? register))) - (set-standard-branches! 'NE) - `(,(test-non-pointer (ucode-type false) 0 (coerce->any register)))) - -(define-rule predicate - (TRUE-TEST (OFFSET (REGISTER (? register)) (? offset))) - (set-standard-branches! 'NE) - `(,(test-non-pointer (ucode-type false) 0 - (indirect-reference! register offset)))) - -(define-rule predicate - (TYPE-TEST (REGISTER (? register)) (? type)) - (QUALIFIER (pseudo-register? register)) - (set-standard-branches! 'EQ) - `(,(test-byte type - (register-reference (load-alias-register! register 'DATA))))) - -(define-rule predicate - (TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) (? type)) - (QUALIFIER (pseudo-register? register)) - (set-standard-branches! 'EQ) - (let ((reference (move-to-temporary-register! register 'DATA))) - `((RO L L (& 8) ,reference) - ,(test-byte type reference)))) - -(define-rule predicate - (UNASSIGNED-TEST (REGISTER (? register))) - (set-standard-branches! 'EQ) - `(,(test-non-pointer (ucode-type unassigned) 0 (coerce->any register)))) - -(define-rule predicate - (UNASSIGNED-TEST (OFFSET (REGISTER (? register)) (? offset))) - (set-standard-branches! 'EQ) - `(,(test-non-pointer (ucode-type unassigned) 0 - (indirect-reference! register offset)))) - -;;;; Invocations - -(define-rule statement - (INVOCATION:APPLY (? number-pushed) (? prefix) (? continuation)) - `(,@(generate-invocation-prefix prefix) - ,(load-dnw number-pushed 0) - (JMP ,entry:compiler-apply))) - -(define-rule statement - (INVOCATION:JUMP (? n) - (APPLY-CLOSURE (? frame-size) (? receiver-offset)) - (? continuation) (? procedure)) - `(,@(clear-map!) - ,@(apply-closure-sequence frame-size receiver-offset - (procedure-label procedure)))) - -(define-rule statement - (INVOCATION:JUMP (? n) - (APPLY-STACK (? frame-size) (? receiver-offset) - (? n-levels)) - (? continuation) (? procedure)) - `(,@(clear-map!) - ,@(apply-stack-sequence frame-size receiver-offset n-levels - (procedure-label procedure)))) - -(define-rule statement - (INVOCATION:JUMP (? number-pushed) (? prefix) (? continuation) (? procedure)) - (QUALIFIER (not (memq (car prefix) '(APPLY-CLOSURE APPLY-STACK)))) - `(,@(generate-invocation-prefix prefix) - (BRA L (@PCR ,(procedure-label procedure))))) - -(define-rule statement - (INVOCATION:LEXPR (? number-pushed) (? prefix) (? continuation) - (? procedure)) - `(,@(generate-invocation-prefix prefix) - ,(load-dnw number-pushed 0) - (BRA L (@PCR ,(procedure-label procedure))))) - -(define-rule statement - (INVOCATION:LOOKUP (? number-pushed) (? prefix) (? continuation) - (? environment) (? name)) - (let ((set-environment (expression->machine-register! environment d4))) - (delete-dead-registers!) - `(,@set-environment - ,@(generate-invocation-prefix prefix) - ,(load-constant name '(D 5)) - (MOVE W (& ,(1+ number-pushed)) (D 0)) - (JMP ,entry:compiler-lookup-apply)))) - -(define-rule statement - (INVOCATION:PRIMITIVE (? number-pushed) (? prefix) (? continuation) - (? primitive)) - `(,@(generate-invocation-prefix prefix) - ,@(if (eq? primitive compiled-error-procedure) - `(,(load-dnw (1+ number-pushed) 0) - (JMP ,entry:compiler-error)) - `(,(load-dnw (primitive-datum primitive) 6) - (JMP ,entry:compiler-primitive-apply))))) - -(define-rule statement - (RETURN) - `(,@(clear-map!) - (CLR B (@A 7)) - (RTS))) - -(define (generate-invocation-prefix prefix) - `(,@(clear-map!) - ,@(case (car prefix) - ((NULL) '()) - ((MOVE-FRAME-UP) - (apply generate-invocation-prefix:move-frame-up (cdr prefix))) - ((APPLY-CLOSURE) - (apply generate-invocation-prefix:apply-closure (cdr prefix))) - ((APPLY-STACK) - (apply generate-invocation-prefix:apply-stack (cdr prefix))) - (else (error "GENERATE-INVOCATION-PREFIX: bad prefix type" prefix))))) - -(define (generate-invocation-prefix:move-frame-up frame-size how-far) - (cond ((or (zero? frame-size) (zero? how-far)) '()) - ((= frame-size 1) - `((MOVE L (@A+ 7) ,(offset-reference a7 (-1+ how-far))) - ,@(increment-anl 7 (-1+ how-far)))) - ((= frame-size 2) - (if (= how-far 1) - `((MOVE L (@AO 7 4) (@AO 7 8)) - (MOVE L (@A+ 7) (@A 7))) - (let ((i `(MOVE L (@A+ 7) ,(offset-reference a7 (-1+ how-far))))) - `(,i ,i ,@(increment-anl 7 (- how-far 2)))))) - (else - (let ((temp-0 (allocate-temporary-register! 'ADDRESS)) - (temp-1 (allocate-temporary-register! 'ADDRESS))) - `((LEA ,(offset-reference a7 frame-size) - ,(register-reference temp-0)) - (LEA ,(offset-reference a7 (+ frame-size how-far)) - ,(register-reference temp-1)) - ,@(generate-n-times frame-size 5 - `(MOVE L - (@-A ,(- temp-0 8)) - (@-A ,(- temp-1 8))) - (lambda (generator) - (generator (allocate-temporary-register! 'DATA)))) - (MOVE L ,(register-reference temp-1) (A 7))))))) - -(define (generate-invocation-prefix:apply-closure frame-size receiver-offset) - (let ((label (generate-label))) - `(,@(apply-closure-sequence frame-size receiver-offset label) - (LABEL ,label)))) - -(define (generate-invocation-prefix:apply-stack frame-size receiver-offset - n-levels) - (let ((label (generate-label))) - `(,@(apply-stack-sequence frame-size receiver-offset n-levels label) - (LABEL ,label)))) - -;;;; Interpreter Calls - -(define-rule statement - (INTERPRETER-CALL:ACCESS (? environment) (? name)) - (lookup-call entry:compiler-access environment name)) - -(define-rule statement - (INTERPRETER-CALL:LOOKUP (? environment) (? name)) - (lookup-call entry:compiler-lookup environment name)) - -(define-rule statement - (INTERPRETER-CALL:UNASSIGNED? (? environment) (? name)) - (lookup-call entry:compiler-unassigned? environment name)) - -(define-rule statement - (INTERPRETER-CALL:UNBOUND? (? environment) (? name)) - (lookup-call entry:compiler-unbound? environment name)) - -(define (lookup-call entry environment name) - (let ((set-environment (expression->machine-register! environment a0))) - (let ((clear-map (clear-map!))) - `(,@set-environment - ,@clear-map - ,(load-constant name '(A 1)) - (JSR ,entry) - ,@(make-external-label (generate-label)))))) - -(define-rule statement - (INTERPRETER-CALL:ENCLOSE (? number-pushed)) - `((MOVE L (A 5) ,reg:enclose-result) - (MOVE B (& ,(ucode-type vector)) ,reg:enclose-result) - ,(load-non-pointer (ucode-type manifest-vector) number-pushed - '(@A+ 5)) - ,@(generate-n-times number-pushed 5 '(MOVE L (@A+ 7) (@A+ 5)) - (lambda (generator) - `(,@(clear-registers! d0) - ,@(generator 0))))) -#| Alternate sequence which minimizes code size. - `(,@(clear-registers! a0 a1 d0) - (MOVE W (& ,number-pushed) (D 0)) - (JSR ,entry:compiler-enclose))|# - ) - -(define-rule statement - (INTERPRETER-CALL:DEFINE (? environment) (? name) (? value)) - (QUALIFIER (not (eq? 'CONS-POINTER (car value)))) - (assignment-call:default entry:compiler-define environment name value)) - -(define-rule statement - (INTERPRETER-CALL:SET! (? environment) (? name) (? value)) - (QUALIFIER (not (eq? 'CONS-POINTER (car value)))) - (assignment-call:default entry:compiler-set! environment name value)) - -(define (assignment-call:default entry environment name value) - (let ((set-environment (expression->machine-register! environment a0))) - (let ((set-value (expression->machine-register! value a2))) - (let ((clear-map (clear-map!))) - `(,@set-environment - ,@set-value - ,@clear-map - ,(load-constant name '(A 1)) - (JSR ,entry) - ,@(make-external-label (generate-label))))))) - -(define-rule statement - (INTERPRETER-CALL:DEFINE (? environment) (? name) - (CONS-POINTER (CONSTANT (? type)) - (REGISTER (? datum)))) - (assignment-call:cons-pointer entry:compiler-define environment name type - datum)) - -(define-rule statement - (INTERPRETER-CALL:SET! (? environment) (? name) - (CONS-POINTER (CONSTANT (? type)) - (REGISTER (? datum)))) - (assignment-call:cons-pointer entry:compiler-set! environment name type - datum)) - -(define (assignment-call:cons-pointer entry environment name type datum) - (let ((set-environment (expression->machine-register! environment a0))) - (let ((datum (coerce->any datum))) - (let ((clear-map (clear-map!))) - `(,@set-environment - (MOVE L ,datum ,reg:temp) - (MOVE B (& ,type) ,reg:temp) - ,@clear-map - (MOVE L ,reg:temp (A 2)) - ,(load-constant name '(A 1)) - (JSR ,entry) - ,@(make-external-label (generate-label))))))) - -;;;; Procedure/Continuation Entries - -;;; The following calls MUST appear as the first thing at the entry -;;; point of a procedure. They assume that the register map is clear -;;; and that no register contains anything of value. - -;;; **** The only reason that this is true is that no register is live -;;; across calls. If that were not true, then we would have to save -;;; any such registers on the stack so that they would be GC'ed -;;; appropriately. - -(define-rule statement - (PROCEDURE-HEAP-CHECK (? procedure)) - (let ((gc-label (generate-label))) - `(,@(procedure-header procedure gc-label) - (CMP L ,reg:compiled-memtop (A 5)) - (B GE S (@PCR ,gc-label))))) - -;;; Note: do not change the MOVE.W in the setup-lexpr call to a MOVEQ. -;;; The setup-lexpr code assumes a fixed calling sequence to compute -;;; the GC address if that is needed. This could be changed so that -;;; the microcode determined how far to back up based on the argument, -;;; or by examining the calling sequence. - -(define-rule statement - (SETUP-LEXPR (? procedure)) - `(,@(procedure-header procedure false) - (MOVE W - (& ,(+ (length (procedure-required procedure)) - (length (procedure-optional procedure)) - (if (procedure/closure? procedure) 1 0))) - (D 1)) - (MOVEQ (& ,(if (procedure-rest procedure) 1 0)) (D 2)) - (JSR , entry:compiler-setup-lexpr))) - -(define-rule statement - (CONTINUATION-HEAP-CHECK (? continuation)) - (let ((gc-label (generate-label)) - (internal-label (continuation-label continuation))) - `((LABEL ,gc-label) - (JSR ,entry:compiler-interrupt-continuation) - ,@(make-external-label internal-label) - (CMP L ,reg:compiled-memtop (A 5)) - (B GE S (@PCR ,gc-label))))) - -(define (procedure-header procedure gc-label) - (let ((internal-label (procedure-label procedure))) - (append! (if (procedure/closure? procedure) - (let ((required (1+ (length (procedure-required procedure)))) - (optional (length (procedure-optional procedure))) - (label (procedure-external-label procedure))) - (if (and (procedure-rest procedure) - (zero? required)) - (begin (set-procedure-external-label! procedure - internal-label) - `((ENTRY-POINT ,internal-label))) - `((ENTRY-POINT ,label) - ,@(make-external-label label) - ,(test-dnw required 0) - ,@(cond ((procedure-rest procedure) - `((B GE S (@PCR ,internal-label)))) - ((zero? optional) - `((B EQ S (@PCR ,internal-label)))) - (else - (let ((wna-label (generate-label))) - `((B LT S (@PCR ,wna-label)) - ,(test-dnw (+ required optional) 0) - (B LE S (@PCR ,internal-label)) - (LABEL ,wna-label))))) - (JMP ,entry:compiler-wrong-number-of-arguments)))) - '()) - (if gc-label - `((LABEL ,gc-label) - (JSR ,entry:compiler-interrupt-procedure)) - '()) - `(,@(make-external-label internal-label))))) - -(define (make-external-label label) - `((DC W (- ,label ,*block-start-label*)) - (LABEL ,label))) - -;;;; Poppers - -(define-rule statement - (MESSAGE-RECEIVER:CLOSURE (? frame-size)) - `((MOVE L (& ,(* frame-size 4)) (@-A 7)))) - -(define-rule statement - (MESSAGE-RECEIVER:STACK (? frame-size)) - `((MOVE L (& ,(+ #x00100000 (* frame-size 4))) (@-A 7)))) - -(define-rule statement - (MESSAGE-RECEIVER:SUBPROBLEM (? continuation)) - `((PEA (@PCR ,(continuation-label continuation))) - (MOVE B (& ,type-code:return-address) (@A 7)) - (MOVE L (& #x00200000) (@-A 7)))) - -(define (apply-closure-sequence frame-size receiver-offset label) - `(,(load-dnw frame-size 1) - (LEA (@AO 7 ,(* receiver-offset 4)) (A 0)) - (LEA (@PCR ,label) (A 1)) - (JMP ,popper:apply-closure))) - -(define (apply-stack-sequence frame-size receiver-offset n-levels label) - `((MOVEQ (& ,n-levels) (D 0)) - ,(load-dnw frame-size 1) - (LEA (@AO 7 ,(* receiver-offset 4)) (A 0)) - (LEA (@PCR ,label) (A 1)) - (JMP ,popper:apply-stack))) - -(define-rule statement - (MESSAGE-SENDER:VALUE (? receiver-offset)) - `(,@(clear-map!) - ,@(increment-anl 7 receiver-offset) -(define popper:value '(@AO 6 #x01E8)) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/machin.scm b/v7/src/compiler/machines/bobcat/machin.scm deleted file mode 100644 index 83eb26809..000000000 --- a/v7/src/compiler/machines/bobcat/machin.scm +++ /dev/null @@ -1,207 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 1.44 1987/03/19 00:53:49 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Machine Model for 68020 - -(declare (usual-integrations)) - (define (rtl:message-receiver-size:closure) 1) -(define (rtl:message-receiver-size:stack) 1) -(define (rtl:message-receiver-size:subproblem) 2) - -(define-integrable (stack->memory-offset offset) - offset) - -(define (rtl:expression-cost expression) - ;; Returns an estimate of the cost of evaluating the expression. - ;; For simplicity, we try to estimate the actual number of cycles - ;; that a typical code sequence would produce. - (case (rtl:expression-type expression) - ((CONSTANT) - (let ((value (cadr expression))) - (cond ((false? value) 4) ;clr.l reg - ((or (eq? value true) - (char? value) - (and (integer? value) - (<= -#x80000000 value #x7FFFFFFF))) - 12) ;move.l #...,reg - (else 16)))) ;move.l d(pc),reg - ((CONS-POINTER) - ;; Best case = 12 cycles, worst = 44 - ;; move.l reg,d(reg) = 16 - ;; move.b reg,d(reg) = 12 - ;; move.l d(reg),reg = 16 - (+ 30 - (rtl:expression-cost (rtl:cons-pointer-type expression)) - (rtl:expression-cost (rtl:cons-pointer-datum expression)))) - ((OBJECT->ADDRESS OBJECT->DATUM) 6) ;and.l d7,reg - ;; move.l reg,d(reg) = 16 - ;; move.b d(reg),reg = 12 - ((OBJECT->TYPE) 28) - ((OFFSET) 16) ;move.l d(reg),reg - ((OFFSET-ADDRESS) 8) ;lea d(an),reg - ((POST-INCREMENT) 12) ;move.l (reg)+,reg - ((PRE-INCREMENT) 14) ;move.l -(reg),reg - ((REGISTER) 4) ;move.l reg,reg - ((UNASSIGNED) 12) ;move.l #data,reg - ;; lea d(pc),reg = 8 - ;; move.l reg,d(reg) = 16 - ;; move.b #type,d(reg) = 16 - ;; move.l d(reg),reg = 16 - ((ENTRY:CONTINUATION ENTRY:PROCEDURE) 56) - (else (error "Unknown expression type" expression)))) - -(define (rtl:machine-register? rtl-register) - (case rtl-register - ((STACK-POINTER) (interpreter-stack-pointer)) - ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access)) - ((INTERPRETER-CALL-RESULT:LOOKUP) (interpreter-register:lookup)) - ((INTERPRETER-CALL-RESULT:UNASSIGNED?) (interpreter-register:unassigned?)) - ((INTERPRETER-CALL-RESULT:UNBOUND?) (interpreter-register:unbound?)) - (else false))) - -(define (rtl:interpreter-register? rtl-register) - (case rtl-register - ((MEMORY_TOP) 0) - ((STACK_GUARD) 1) - ((VALUE) 2) - ((ENVIRONMENT) 3) - ((TEMPORARY) 4) - ((INTERPRETER-CALL-RESULT:ENCLOSE) 5) - (else false))) - -(define (rtl:interpreter-register->offset locative) - (or (rtl:interpreter-register? locative) - (error "Unknown register type" locative))) - -(define-integrable d0 0) -(define-integrable d1 1) -(define-integrable d2 2) -(define-integrable d3 3) -(define-integrable d4 4) -(define-integrable d5 5) -(define-integrable d6 6) -(define-integrable d7 7) - -(define-integrable a0 8) -(define-integrable a1 9) -(define-integrable a2 10) -(define-integrable a3 11) -(define-integrable a4 12) -(define-integrable a5 13) -(define-integrable a6 14) -(define-integrable a7 15) - -(define number-of-machine-registers 16) - -(define-integrable (sort-machine-registers registers) - registers) - -(define (pseudo-register=? x y) - (= (register-renumber x) (register-renumber y))) - -(define available-machine-registers - (list d0 d1 d2 d3 d4 d5 d6 a0 a1 a2 a3 a4)) - -(define-integrable (register-contains-address? register) - (memv register '(13 14 15))) - -(define register-type - (let ((types (make-vector 16))) - (let loop ((i 0) (j 8)) - (if (< i 8) - (begin (vector-set! types i 'DATA) - (vector-set! types j 'ADDRESS) - (loop (1+ i) (1+ j))))) - (lambda (register) - (vector-ref types register)))) - -(define register-reference - (let ((references (make-vector 16))) - (let loop ((i 0) (j 8)) - (if (< i 8) - (begin (vector-set! references i `(D ,i)) - (vector-set! references j `(A ,i)) - (loop (1+ i) (1+ j))))) (lambda (register) - (vector-ref references register)))) - -(define mask-reference - '(D 7)) - -(define regnum:free-pointer a5) -(define regnum:regs-pointer a6) -(define regnum:stack-pointer a7) - -(define-integrable (interpreter-register:access) - (rtl:make-machine-register d0)) - -(define-integrable (interpreter-register:enclose) - (rtl:make-offset (interpreter-regs-pointer) 5)) - -(define-integrable (interpreter-register:lookup) - (rtl:make-machine-register d0)) - -(define-integrable (interpreter-register:unassigned?) - (rtl:make-machine-register d0)) - -(define-integrable (interpreter-register:unbound?) - (rtl:make-machine-register d0)) - -(define-integrable (interpreter-free-pointer) - (rtl:make-machine-register regnum:free-pointer)) - -(define-integrable (interpreter-free-pointer? register) - (= (rtl:register-number register) regnum:free-pointer)) - -(define-integrable (interpreter-regs-pointer) - (rtl:make-machine-register regnum:regs-pointer)) - -(define-integrable (interpreter-regs-pointer? register) - (= (rtl:register-number register) regnum:regs-pointer)) - -(define-integrable (interpreter-stack-pointer) - (rtl:make-machine-register regnum:stack-pointer)) - -(define-integrable (interpreter-stack-pointer? register) - (= (rtl:register-number register) regnum:stack-pointer)) - -(define (lap:make-label-statement label) - `(LABEL ,label)) - -(define (lap:make-unconditional-branch label) - `(BRA L (@PCR ,label))) - -(define (lap:make-entry-point label block-start-label) - `((ENTRY-POINT ,label) - (DC W (- ,label ,block-start-label)) - (LABEL ,label))) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 deleted file mode 100644 index e0cffc2e1..000000000 --- a/v7/src/compiler/machines/bobcat/make.scm-68040 +++ /dev/null @@ -1,147 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.12 1987/03/20 05:29:33 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Compiler Make File for MC68020 - -(declare (usual-integrations)) - -(set-working-directory-pathname! "$zcomp") -(load "base/rcs" system-global-environment) -(load "base/load" system-global-environment) - -(load-system system-global-environment - 'COMPILER-PACKAGE - '(SYSTEM-GLOBAL-ENVIRONMENT) - '( - (SYSTEM-GLOBAL-ENVIRONMENT - "base/pbs" ;bit-string read/write syntax - ) - - (COMPILER-PACKAGE - "base/macros" ;compiler syntax - "base/decls" ;declarations -; "machines/bobcat/decls" ;more declarations - - "base/object" ;tagged object support - "base/queue" ;queue abstraction - "base/sets" ;set abstraction - "source/mvalue" ;multiple-value support - - "machines/bobcat/machin" ;machine dependent stuff - "base/toplev" ;top level - "base/utils" ;odds and ends - "base/cfg" ;control flow graph - "base/ctypes" ;CFG datatypes - "base/dtypes" ;DFG datatypes - "base/bblock" ;Basic block datatype - "base/dfg" ;data flow graph - "base/rtltyp" ;RTL: type definitions - "base/rtl" ;RTL: expression operations - "base/rtlreg" ;RTL: registers - "base/rtlcfg" ;RTL: CFG types - "base/emodel" ;environment model - "base/rtypes" ;RTL analyzer datatypes - "base/nmatch" ;simple pattern matcher - ) - - (CONVERTER-PACKAGE - "alpha/graphc" ;SCode->flow-graph converter - ) - - (DATAFLOW-PACKAGE - "alpha/dflow" ;Dataflow analyzer - ) - - (RTL-GENERATOR-PACKAGE - "front-end/rtlgen" ;RTL generator - "front-end/rgcomb" ;RTL generator: combinations - "base/linear" ;linearization - ) - - (RTL-CSE-PACKAGE - "front-end/rcse" ;RTL common subexpression eliminator - "front-end/rcseep" ;CSE expression predicates - "front-end/rcsesr" ;CSE stack references - "front-end/rcseht" ;CSE hash table - "front-end/rcsesa" ;CSE state abstraction - "front-end/rcserq" ;CSE register/quantity abstractions - ) - - (RTL-ANALYZER-PACKAGE - "front-end/rlife" ;RTL register lifetime analyzer - "front-end/ralloc" ;RTL register allocator - ) - - (LAP-GENERATOR-PACKAGE - "back-end/lapgen" ;LAP generator. - "back-end/regmap" ;Hardware register allocator. - "machines/bobcat/lapgen" ;code generation rules. - ) - - (LAP-SYNTAXER-PACKAGE - "back-end/syntax" ;Generic syntax phase - "machines/bobcat/coerce" ;Coercions: integer -> bit string - "back-end/asmmac" ;Macros for hairy syntax - "machines/bobcat/insmac" ;Macros for hairy syntax - "machines/bobcat/instr1" ;68000 Effective addressing - "machines/bobcat/instr2" ;68000 Instructions - "machines/bobcat/instr3" ; " " - ) - - (LAP-PACKAGE - "machines/bobcat/assmd" ;Machine dependent - "back-end/symtab" ;Symbol tables - "back-end/block" ;Assembly blocks - "back-end/laptop" ;Assembler top level - ) - - )) - -(in-package compiler-package - - (define compiler-system - (make-environment - (define :name "Liar (Bobcat 68020)") - (define :version) - (define :modification) - - (parse-rcs-header "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.12 1987/03/20 05:29:33 cph Exp $" - (lambda (filename version date time author state) - (set! :version (car version)) - (set! :modification (cadr version)))))) - - (add-system! compiler-system)) - -(%ge compiler-package) -(%gst (access compiler-syntax-table compiler-package)) \ No newline at end of file diff --git a/v7/src/compiler/machines/spectrum/assmd.scm b/v7/src/compiler/machines/spectrum/assmd.scm deleted file mode 100644 index 2f19b4964..000000000 --- a/v7/src/compiler/machines/spectrum/assmd.scm +++ /dev/null @@ -1,58 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/assmd.scm,v 1.29 1987/03/19 00:54:40 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Assembler Machine Dependencies - -(declare (usual-integrations)) - -(define addressing-granularity 8) -(define scheme-object-width 32) - -(define make-nmv-header) -(let () - -(set! make-nmv-header -(named-lambda (make-nmv-header n) - (bit-string-append (unsigned-integer->bit-string 24 n) - nmv-type-string))) - -(define nmv-type-string - (unsigned-integer->bit-string 8 (microcode-type 'MANIFEST-NM-VECTOR))) - -) - -(define (object->bit-string object) - (bit-string-append - (unsigned-integer->bit-string 24 (primitive-datum object)) - (unsigned-integer->bit-string 8 (primitive-type object)))) \ No newline at end of file diff --git a/v7/src/compiler/machines/spectrum/coerce.scm b/v7/src/compiler/machines/spectrum/coerce.scm deleted file mode 100644 index eb8c4c818..000000000 --- a/v7/src/compiler/machines/spectrum/coerce.scm +++ /dev/null @@ -1,166 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/coerce.scm,v 1.4 1987/03/19 00:54:46 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Spectrum Specific Coercions - -(declare (usual-integrations)) - -(define (parse-word expression tail) - (expand-descriptors (cdr expression) - (lambda (instruction size) - (if (not (zero? (remainder size 32))) - (error "PARSE-WORD: Instructions must be 32 bit multiples" size)) - (let ((instruction (apply optimize-group-syntax instruction))) - (if (null? tail) - `(CONS ,instruction '()) - `(CONS-SYNTAX ,instruction (CONS ,(car tail) '()))))))) - -(define (expand-descriptors descriptors receiver) - (if (null? descriptors) - (receiver '() 0) - (expand-descriptors (cdr descriptors) - (lambda (instruction* size*) - (expand-descriptor (car descriptors) - (lambda (instruction size) - (receiver (append! instruction instruction*) - (+ size size*)))))))) - -(define (expand-descriptor descriptor receiver) - (let ((size (car descriptor))) - (receiver `(,(integer-syntaxer (cadr descriptor) - (if (null? (cddr descriptor)) - 'UNSIGNED - (caddr descriptor)) - size)) - size))) - -(define (coerce-right-signed nbits) - (let ((offset (1+ (expt 2 nbits)))) - (lambda (n) - (unsigned-integer->bit-string nbits - (if (negative? n) - (+ (* n 2) offset) - (* n 2)))))) - -(define coerce-assemble3:x - (standard-coercion - (lambda (n) - (+ (* (land n 3) 2) (quotient n 4))))) - -(define coerce-assemble12:X - (standard-coercion - (lambda (n) - (let ((qr (integer-divide n 4))) - (if (not (zero? (integer-divide-remainder qr))) - (error "COERCE-ASSEMBLE12:X: offset not multiple of 4" n)) - (let ((n (integer-divide-quotient qr))) - (+ (* (land n #x3FF) 2) (quotient (land n #x400) #x400))))))) - -(define coerce-assemble12:Y - (standard-coercion - (lambda (n) - (quotient (land (quotient n 4) #x800) #x800)))) - -(define coerce-assemble17:X - (standard-coercion - (lambda (n) - (let ((qr (integer-divide n 4))) - (if (not (zero? (integer-divide-remainder qr))) - (error "COERCE-ASSEMBLE17:X: offset not multiple of 4" n)) - (quotient (land (integer-divide-quotient qr) #xF800) #x800))))) - -(define coerce-assemble17:Y - (standard-coercion - (lambda (n) - (let ((n (quotient n 4))) - (+ (quotient (land n #x400) #x400) (* (land n #x3FF) 2)))))) - -(define coerce-assemble17:Z - (standard-coercion - (lambda (n) - (+ (quotient (land (quotient n 4) #x10000) #x10000))))) - -(define coerce-assemble21:X - (standard-coercion - (lambda (n) - (+ (* (land n #x7C) #x4000) - (* (land n #x180) #x80) - (* (land n #x3) #x1000) - (quotient (land n #xFFE00) #x100) - (quotient (land n #x100000) #x100000))))) - -(define make-coercion - (coercion-maker - `((ASSEMBLE3:X . ,coerce-assemble3:x) - (ASSEMBLE12:X . ,coerce-assemble12:x) - (ASSEMBLE12:Y . ,coerce-assemble12:y) - (ASSEMBLE17:X . ,coerce-assemble17:x) - (ASSEMBLE17:Y . ,coerce-assemble17:y) - (ASSEMBLE17:Z . ,coerce-assemble17:z) - (ASSEMBLE21:X . ,coerce-assemble21:x) - (RIGHT-SIGNED . ,coerce-right-signed) - (UNSIGNED . ,coerce-unsigned-integer) - (SIGNED . ,coerce-signed-integer)))) - -(define-coercion 'UNSIGNED 1) -(define-coercion 'UNSIGNED 2) -(define-coercion 'UNSIGNED 3) -(define-coercion 'UNSIGNED 4) -(define-coercion 'UNSIGNED 5) -(define-coercion 'UNSIGNED 6) -(define-coercion 'UNSIGNED 7) -(define-coercion 'UNSIGNED 8) -(define-coercion 'UNSIGNED 9) -(define-coercion 'UNSIGNED 10) -(define-coercion 'UNSIGNED 11) -(define-coercion 'UNSIGNED 12) -(define-coercion 'UNSIGNED 13) -(define-coercion 'UNSIGNED 14) -(define-coercion 'UNSIGNED 16) -(define-coercion 'UNSIGNED 32) - -(define-coercion 'SIGNED 8) -(define-coercion 'SIGNED 16) -(define-coercion 'SIGNED 32) - -(define-coercion 'RIGHT-SIGNED 5) -(define-coercion 'RIGHT-SIGNED 11) -(define-coercion 'RIGHT-SIGNED 14) -(define-coercion 'ASSEMBLE3:X 3) -(define-coercion 'ASSEMBLE12:X 11) -(define-coercion 'ASSEMBLE12:Y 1) -(define-coercion 'ASSEMBLE17:X 5) -(define-coercion 'ASSEMBLE17:Y 11) -(define-coercion 'ASSEMBLE17:Z 1) -(define-coercion 'ASSEMBLE21:X 21) \ No newline at end of file diff --git a/v7/src/compiler/machines/spectrum/lapgen.scm b/v7/src/compiler/machines/spectrum/lapgen.scm deleted file mode 100644 index ce8d90ebf..000000000 --- a/v7/src/compiler/machines/spectrum/lapgen.scm +++ /dev/null @@ -1,1041 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/lapgen.scm,v 1.137 1987/04/12 00:25:26 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; RTL Rules for Spectrum - -(declare (usual-integrations)) - -;;;; Interface to Allocator - -(define (register->register-transfer source destination) - `(,(machine->machine-register source destination))) - -(define (home->register-transfer source destination) - `(,(pseudo->machine-register source destination))) - -(define (register->home-transfer source destination) - `(,(machine->pseudo-register source destination))) - -(define-integrable (pseudo->machine-register source target) - (memory->machine-register (pseudo-register-home source) target)) - -(define-integrable (machine->pseudo-register source target) - (machine-register->memory source (pseudo-register-home target))) - -(define-integrable (pseudo-register-home register) - (index-reference regnum:regs-pointer - (+ #x000A (register-renumber register)))) - -;;;; Basic machine instructions - -(define-integrable (machine->machine-register source target) - `(OR () ,source 0 ,target)) - -(define-integrable (machine-register->memory source target) - `(STW () ,source ,target)) - -(define-integrable (machine-register->memory-post-increment source target) - ;; Used for heap allocation - `(STWM () ,source ,(index-reference target 1))) - -(define-integrable (machine-register->memory-pre-decrement source target) - ;; Used for stack push - `(STWM () ,source ,(index-reference target -1))) - -(define-integrable (memory->machine-register source target) - `(LDW () ,source ,target)) - -(define-integrable (memory-post-increment->machine-register source target) - ;; Used for stack pop - `(LDWM () ,(index-reference source 1) ,target)) - -(define-integrable (invoke-entry entry) - `(BE (N) ,entry)) - -(define (assign&invoke-entry number target entry) - (if (<= -8192 number 8191) - `((BE () ,entry) - (LDI () ,number ,target)) - `((LDIL () (LEFT ,number) ,target) - (BE () ,entry) - (LDO () (OFFSET (RIGHT ,number) ,target) ,target)))) - -(define (branch->label label) - `(BL (N) ,(label-relative-expression label) 0)) - -(define-integrable (index-reference register offset) - `(INDEX ,(* 4 offset) 0 ,(register-reference register))) - -(define-integrable (offset-reference register offset) - `(OFFSET ,(* 4 offset) ,(register-reference register))) - -(define-integrable (short-offset? offset) - (< offset 2048)) - -(define (load-memory source offset target) - `(LDW () ,(index-reference source offset) ,target)) - -(define (store-memory source target offset) - `(STW () ,source ,(index-reference target offset))) - -(define (load-memory-increment source offset target) - `(LDWM () ,(index-reference source offset) ,target)) - -(define (store-memory-increment source target offset) - `(STWM () ,source ,(index-reference target offset))) - -;;;; Instruction Sequence Generators - -(define (indirect-reference! register offset) - (index-reference - (if (machine-register? register) - register - (or (register-alias register false) - ;; This means that someone has written an address out - ;; to memory, something that should never happen. - (error "Needed to load indirect register!" register))) - offset)) - -(define (object->address source #!optional target) - (if (unassigned? target) (set! target source)) - `((EXTRU () ,source 31 24 ,target) - (OR () ,regnum:address-offset ,target ,target))) - -(define (register->machine-register register target) - (if (machine-register? register) - (machine->machine-register register target) - (let ((alias (register-alias register false))) - (if alias - (machine->machine-register alias target) - (pseudo->machine-register register target))))) - -(define (expression->machine-register! expression register) - (let ((result - (case (car expression) - ((REGISTER) - `(,(register->machine-register (cadr expression) register))) - ((OFFSET) - `(,(memory->machine-register - (indirect-reference! (cadadr expression) (caddr expression)) - register))) - ((CONSTANT) - (scheme-constant->machine-register (cadr expression) register)) - (else (error "Bad expression type" (car expression)))))) - (delete-machine-register! register) - result)) - -(package (register->memory - register->memory-post-increment - register->memory-pre-decrement) - (define ((->memory machine-register->memory) register target) - `(,(machine-register->memory (guarantee-machine-register! register false) - target))) - (define-export register->memory - (->memory machine-register->memory)) - (define-export register->memory-post-increment - (->memory machine-register->memory-post-increment)) - (define-export register->memory-pre-decrement - (->memory machine-register->memory-pre-decrement))) - -(package (memory->memory - memory->memory-post-increment - memory->memory-pre-decrement) - (define ((->memory machine-register->memory) source target) - `(,(memory->machine-register source r1) - ,(machine-register->memory r1 target))) - (define-export memory->memory - (->memory machine-register->memory)) - (define-export memory->memory-post-increment - (->memory machine-register->memory-post-increment)) - (define-export memory->memory-pre-decrement - (->memory machine-register->memory-pre-decrement))) - -(package (memory-post-increment->memory - memory-post-increment->memory-post-increment - memory-post-increment->memory-pre-decrement) - (define ((->memory machine-register->memory) source target) - `(,(memory-post-increment->machine-register source r1) - ,(machine-register->memory r1 target))) - (define-export memory-post-increment->memory - (->memory machine-register->memory)) - (define-export memory-post-increment->memory-post-increment - (->memory machine-register->memory-post-increment)) - (define-export memory-post-increment->memory-pre-decrement - (->memory machine-register->memory-pre-decrement))) - -(package (scheme-constant->memory - scheme-constant->memory-post-increment - scheme-constant->memory-pre-decrement) - (define ((->memory machine-register->memory) constant target) - `(,@(scheme-constant->machine-register constant r1) - ,(machine-register->memory r1 target))) - (define-export scheme-constant->memory - (->memory machine-register->memory)) - (define-export scheme-constant->memory-post-increment - (->memory machine-register->memory-post-increment)) - (define-export scheme-constant->memory-pre-decrement - (->memory machine-register->memory-pre-decrement))) - -(define (scheme-constant->machine-register constant target) - (if (non-pointer-object? constant) - (non-pointer->machine-register (primitive-type constant) - (primitive-datum constant) - target) - `(,(memory->machine-register (scheme-constant-reference constant) - target)))) - -(define-integrable (scheme-constant-reference constant) - `(INDEX ,(label->machine-constant (constant->label constant)) - 0 - ,regnum:code-object-base)) - -(define (non-pointer->machine-register type datum target) - (if (and (zero? datum) - (deposit-type-constant? type)) - (if (zero? type) - `((OR () 0 0 ,target)) - (with-type-deposit-parameters type - (lambda (const end) - `((ZDEPI () ,const ,end 5 ,target))))) - (let ((number (make-non-pointer type datum))) - (if (<= -8192 number 8191) - `((LDI () ,number ,target)) - `((LDIL () (LEFT ,number) ,target) - (LDO () (OFFSET (RIGHT ,number) ,target) ,target)))))) - -(package (non-pointer->memory - non-pointer->memory-post-increment - non-pointer->memory-pre-decrement) - (define ((->memory machine-register->memory) constant target) - `(,@(non-pointer->machine-register constant r1) - ,(machine-register->memory r1 target))) - (define-export non-pointer->memory - (->memory machine-register->memory)) - (define-export non-pointer->memory-post-increment - (->memory machine-register->memory-post-increment)) - (define-export non-pointer->memory-pre-decrement - (->memory machine-register->memory-pre-decrement))) - -(define (machine-constant->machine-register constant target) - (non-pointer->machine-register (machine-constant->type constant) - (machine-constant->datum constant) - target)) - -(package (machine-constant->memory - machine-constant->memory-post-increment - machine-constant->memory-pre-decrement) - (define ((->memory machine-register->memory) constant target) - `(,@(machine-constant->machine-register constant r1) - ,(machine-register->memory r1 target))) - (define-export machine-constant->memory - (->memory machine-register->memory)) - (define-export machine-constant->memory-post-increment - (->memory machine-register->memory-post-increment)) - (define-export machine-constant->memory-pre-decrement - (->memory machine-register->memory-pre-decrement))) - -(define (label->machine-register label target) - (let ((constant (label->machine-constant label))) - `((ADDIL () (LEFT ,constant) ,regnum:code-object-base) - (LDO () (OFFSET (RIGHT ,constant) ,r1) ,target)))) - -(define-integrable (label->machine-constant label) - `(- ,label ,(code-object-base))) - -(package (label->memory - label->memory-post-increment - label->memory-pre-decrement) - (define ((->memory machine-register->memory) type label target) - (let ((temp (allocate-temporary-register! false))) - `(,@(label->machine-register type label temp) - ,(machine-register->memory temp target)))) - (define-export label->memory - (->memory machine-register->memory)) - (define-export label->memory-post-increment - (->memory machine-register->memory-post-increment)) - (define-export label->memory-pre-decrement - (->memory machine-register->memory-pre-decrement))) - -(define (typed-label->machine-register type label target) - `(,@(label->machine-register label target) - ,@(cons-pointer->machine-register type target target))) - -(package (typed-label->memory - typed-label->memory-post-increment - typed-label->memory-pre-decrement) - (define ((->memory machine-register->memory) type label target) - (let ((temp (allocate-temporary-register! false))) - `(,@(typed-label->machine-register type label temp) - ,(machine-register->memory temp target)))) - (define-export typed-label->memory - (->memory machine-register->memory)) - (define-export typed-label->memory-post-increment - (->memory machine-register->memory-post-increment)) - (define-export typed-label->memory-pre-decrement - (->memory machine-register->memory-pre-decrement))) - -(define (cons-pointer->machine-register type source target) - (let ((source (guarantee-machine-register! source false))) - (if (eqv? source target) - (let ((temp (allocate-temporary-register! false))) - `(,@(cons-pointer->machine-register type source temp) - ,(machine->machine-register temp source))) - `(,@(if (deposit-type-constant? type) - (with-type-deposit-parameters type - (lambda (type end) - `((ZDEPI () ,type ,end 5 ,target)))) - `((LDI () ,type ,target) - (ZDEP () ,target 7 8 ,target))) - (DEP () ,source 31 24 ,target))))) - -(package (cons-pointer->memory - cons-pointer->memory-post-increment - cons-pointer->memory-pre-decrement) - (define ((->memory machine-register->memory) type source target) - (let ((temp (allocate-temporary-register! false))) - `(,@(cons-pointer->machine-register type source temp) - ,(machine-register->memory temp target)))) - (define cons-pointer->memory - (->memory machine-register->memory)) - (define cons-pointer->memory-post-increment - (->memory machine-register->memory-post-increment)) - (define cons-pointer->memory-pre-decrement - (->memory machine-register->memory-pre-decrement))) - -(define (test:machine/machine-register condition source0 source1 receiver) - (let ((make-branch - (lambda (completer) - (lambda (label) - `((COMB (,completer N) ,source0 ,source1 - ,(label-relative-expression label))))))) - (receiver '() - (make-branch condition) - (make-branch (invert-test-completer condition))))) - -(define (test:short-machine-constant/machine-register condition constant source - receiver) - (let ((make-branch - (lambda (completer) - (lambda (label) - `((COMIB (,completer N) ,constant ,source - ,(label-relative-expression label))))))) - (receiver '() - (make-branch condition) - (make-branch (invert-test-completer condition))))) - -(define (invert-test-completer completer) - (cdr (or (assq completer - '((EQ . LTGT) (LTGT . EQ) - (LT . GTEQ) (GTEQ . LT) - (GT . LTEQ) (GT . LTEQ) - (LTLT . GTGTEQ) (GTGTEQ . LTLT) - (GTGT . LTLTEQ) (GTGT . LTLTEQ) - )) - (error "Unknown test completer" completer)))) - -(define (test:machine-constant/machine-register condition constant source - receiver) - (cond ((zero? constant) - (test:machine/machine-register condition 0 source receiver)) - ((test-short-constant? constant) - (test:short-machine-constant/machine-register condition constant - source receiver)) - (else - `(,@(non-pointer->machine-register 0 constant r1) - ,@(test:machine/machine-register condition r1 source receiver))))) - -(define (test:machine-constant/register condition constant source receiver) - (test:machine-constant/machine-register - condition constant (guarantee-machine-register! source false) receiver)) - -(define (test:machine-constant/memory condition constant source receiver) - (let ((temp (allocate-temporary-register! false))) - `(,(memory->machine-register source temp) - ,@(test:machine-constant/machine-register condition constant temp - receiver)))) - -(define (test:type/machine-register condition type source receiver) - (let ((temp (allocate-temporary-register! false))) - `(,(extract-type-machine->machine-register source temp) - ,@(test:machine-constant/machine-register condition type temp - receiver)))) - -(define (test:type/register condition type source receiver) - (test:type/machine-register condition type - (guarantee-machine-register! source false) - receiver)) - -(define (test:type/memory condition type source receiver) - (let ((temp (allocate-temporary-register! false))) - `(,(memory->machine-register source temp) - ,@(cond ((zero? type) - (test:machine/machine-register condition 0 temp receiver)) - ((test-short-constant? type) - `(,(extract-type-machine->machine-register temp temp) - ,@(test:short-machine-constant/machine-register condition - type - temp - receiver))) - (else - `(,@(non-pointer->machine-register 0 type r1) - ,(extract-type-machine->machine-register temp temp) - ,@(test:machine/machine-register condition r1 temp - receiver))))))) - -(define (standard-predicate-receiver prefix consequent alternative) - (set-current-branches! consequent alternative) - prefix) - -(define ((inline-predicate-receiver label) prefix consequent alternative) - `(,@prefix ,@(consequent label))) - -(define-integrable (extract-type-machine->machine-register source target) - `(EXTRU () ,source 7 8 ,target)) - -(define-integrable (test-short-constant? constant) - (<= -16 constant 15)) - -(define (deposit-type-constant? n) - ;; Assume that (<= 0 n 127). - (or (< n 16) - (zero? (remainder n - (cond ((< n 32) 2) - ((< n 64) 4) - (else 8)))))) - -(define (with-type-deposit-parameters type receiver) - ;; This one is for type codes, assume that (<= 0 n 127). - ;; Also assume that `(deposit-type-constant? type)' is true. - (cond ((< type 16) (receiver type 7)) - ((< type 32) (receiver (quotient type 2) 6)) - ((< type 64) (receiver (quotient type 4) 5)) - (else (receiver (quotient type 8) 4)))) - -(define (code-object-label-initialize code-object) - (cond ((procedure? code-object) false) - ((continuation? code-object) (continuation-label code-object)) - ((quotation? code-object) (quotation-label code-object)) - (else - (error "CODE-OBJECT-LABEL-INITIALIZE: Unknown code object type" - code-object)))) - -(define (code-object-base) - ;; This will fail if the difference between the beginning of the - ;; code-object and LABEL is greater than 11 bits (signed). - (or *code-object-label* - (let ((label (generate-label))) - (prefix-instructions! - `((BL () 0 ,regnum:code-object-base) - (LABEL ,label))) - (let ((label `(+ ,label 4))) - (set! *code-object-label* label) - label)))) - -(define (generate-n-times n limit prefix suffix with-counter) - (if (<= n limit) - (let loop ((n n)) - (if (zero? n) - '() - `(,@prefix - ,suffix - ,@(loop (-1+ n))))) - (let ((loop (generate-label 'LOOP))) - (with-counter - (lambda (counter) - `(,@(machine-constant->machine-register (-1+ n) counter) - (LABEL ,loop) - ,@prefix - (ADDIBF (EQ) -1 ,counter ,(label-relative-expression loop)) - ,suffix)))))) - -(define-integrable (label-relative-expression label) - `(- (- ,label *PC*) 8)) - -;;;; Registers/Entries - -(let-syntax ((define-entries - (macro names - (define (loop names index) - (if (null? names) - '() - (cons `(DEFINE ,(symbol-append 'ENTRY:COMPILER- - (car names)) - `(INDEX ,,index 5 ,regnum:regs-pointer)) - (loop (cdr names) (+ index 8))))) - `(BEGIN ,@(loop names #x00F0))))) - (define-entries apply error wrong-number-of-arguments interrupt-procedure - interrupt-continuation lookup-apply lookup access unassigned? unbound? - set! define primitive-apply enclose setup-lexpr setup-ic-procedure)) - -(define reg:temp `(INDEX #x0010 0 ,regnum:regs-pointer)) -(define reg:compiled-memtop `(INDEX 0 0 ,regnum:regs-pointer)) - -(define popper:apply-closure `(INDEX 400 5 ,regnum:regs-pointer)) -(define popper:apply-stack `(INDEX 528 5 ,regnum:regs-pointer)) -(define popper:value `(INDEX 656 5 ,regnum:regs-pointer)) - -(package (type->machine-constant - make-non-pointer - machine-constant->type - machine-constant->datum) - (define type-scale-factor - (expt 2 24)) - (define-export (type->machine-constant type) - (* type type-scale-factor)) - (define-export (make-non-pointer type datum) - (+ (* type type-scale-factor) datum)) - (define-export (machine-constant->type constant) - (quotient constant type-scale-factor)) - (define-export (machine-constant->datum constant) - (remainder constant type-scale-factor))) - -(define constant:compiled-expression - (type->machine-constant (ucode-type compiled-expression))) - -(define constant:return-address - (type->machine-constant (ucode-type return-address))) - -(define constant:unassigned - (make-non-pointer (ucode-type unassigned) 0)) - -(define constant:false - (make-non-pointer (ucode-type false) 0)) - -;;;; Transfers to Registers - -;;; All assignments to pseudo registers are required to delete the -;;; dead registers BEFORE performing the assignment. This is because -;;; the register being assigned may be PSEUDO-REGISTER=? to one of the -;;; dead registers, and thus would be flushed if the deletions -;;; happened after the assignment. - -(define-rule statement - (ASSIGN (REGISTER 30) (OFFSET-ADDRESS (REGISTER 30) (? n))) - `((LDO () ,(offset-reference regnum:stack-pointer n) ,r30))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (CONSTANT (? source))) - (QUALIFIER (pseudo-register? target)) - (scheme-constant->machine-register source - (allocate-assignment-alias! target - false))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (REGISTER (? source))) - (QUALIFIER (pseudo-register? target)) - (move-to-alias-register! source false target) - '()) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source)))) - (QUALIFIER (pseudo-register? target)) - (object->address (move-to-alias-register! source false target))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source)))) - (QUALIFIER (pseudo-register? target)) - (let ((target (move-to-alias-register! source false target))) - `(,(extract-type-machine->machine-register target target)))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset))) - (QUALIFIER (and (pseudo-register? target) (short-offset? offset))) - (let ((source (indirect-reference! address offset))) ;force eval order. - `(,(memory->machine-register source - (allocate-assignment-alias! target false))))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER (? source)) 1)) - (QUALIFIER (pseudo-register? target)) - (memory-post-increment->machine-register - source - (allocate-assignment-alias! target false))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) - (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum)))) - (QUALIFIER (pseudo-register? target)) - (cons-pointer->machine-register type datum - (allocate-assignment-alias! target false))) - -;;;; Transfers to Memory - -(define-rule statement - (ASSIGN (OFFSET (REGISTER (? a)) (? n)) - (CONSTANT (? object))) - (QUALIFIER (short-offset? n)) - (scheme-constant->memory object (indirect-reference! a n))) - -(define-rule statement - (ASSIGN (OFFSET (REGISTER (? a)) (? n)) - (REGISTER (? r))) - (QUALIFIER (short-offset? n)) - (register->memory r (indirect-reference! a n))) - -(define-rule statement - (ASSIGN (OFFSET (REGISTER (? a)) (? n)) - (POINTER-INCREMENT (REGISTER (? source)) 1)) - (QUALIFIER (short-offset? n)) - (memory-post-increment->memory source (indirect-reference! a n))) - -(define-rule statement - ;; The code assumes r cannot be trashed - (ASSIGN (OFFSET (REGISTER (? a)) (? n)) - (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r)))) - (QUALIFIER (short-offset? n)) - (cons-pointer->memory type r (indirect-reference! a n))) - -(define-rule statement - (ASSIGN (OFFSET (REGISTER (? r-target)) (? n-target)) - (OFFSET (REGISTER (? r-source)) (? n-source))) - (QUALIFIER (and (short-offset? n-target) (short-offset? n-source))) - (memory->memory (indirect-reference! r-source n-source) - (indirect-reference! r-target n-target))) - -;;;; Consing - -(define-rule statement - (ASSIGN (POST-INCREMENT (REGISTER 25) 1) (CONSTANT (? object))) - (scheme-constant->memory-post-increment object r25)) - -(define-rule statement - (ASSIGN (POST-INCREMENT (REGISTER 25) 1) (REGISTER (? r))) - (register->memory-post-increment r r25)) - -(define-rule statement - (ASSIGN (POST-INCREMENT (REGISTER 25) 1) (OFFSET (REGISTER (? r)) (? n))) - (memory->memory-post-increment (indirect-reference! r n) r25)) - -(define-rule statement - (ASSIGN (POST-INCREMENT (REGISTER 25) 1) (ENTRY:PROCEDURE (? procedure))) - (typed-label->memory-post-increment (ucode-type compiled-expression) - (procedure-external-label procedure) - r25)) - -;;;; Pushes - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) (CONSTANT (? object))) - (scheme-constant->memory-pre-decrement object r30)) - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) (UNASSIGNED)) - (scheme-constant->memory-pre-decrement constant:unassigned r30)) - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) (REGISTER (? r))) - (register->memory-pre-decrement r r30)) - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) - (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r)))) - (cons-pointer->memory-pre-decrement type r r30)) - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) (OFFSET (REGISTER (? r)) (? n))) - (QUALIFIER (short-offset? n)) - (memory->memory-pre-decrement (indirect-reference! r n) r30)) - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) - (OFFSET-ADDRESS (REGISTER 30) (? n))) - (QUALIFIER (short-offset? n)) - (let ((temp (allocate-temporary-register! false))) - `((LDI () ,(ucode-type stack-environment) ,temp) - (LDO () ,(offset-reference r30 n) ,r1) - (DEP () ,temp 7 8 ,r1) - ,@(register->memory-pre-decrement r1 r30)))) - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) - (ENTRY:CONTINUATION (? continuation))) - (typed-label->memory-pre-decrement (ucode-type return-address) - (continuation-label continuation) - r30)) - -;;;; Predicates - -(define-rule predicate - (TRUE-TEST (REGISTER (? register))) - (test:machine-constant/register 'LTGT constant:false register - standard-predicate-receiver)) - -(define-rule predicate - (TRUE-TEST (OFFSET (REGISTER (? register)) (? offset))) - (test:machine-constant/memory 'LTGT constant:false - (indirect-reference! register offset) - standard-predicate-receiver)) - -(define-rule predicate - (TYPE-TEST (REGISTER (? register)) (? type)) - (test:machine-constant/machine-register 'LTGT type register - standard-predicate-receiver)) - -(define-rule predicate - (TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) (? type)) - (test:type/register 'LTGT type register standard-predicate-receiver)) - -(define-rule predicate - (UNASSIGNED-TEST (REGISTER (? register))) - (test:machine-constant/register 'LTGT constant:unassigned register - standard-predicate-receiver)) - -(define-rule predicate - (UNASSIGNED-TEST (OFFSET (REGISTER (? register)) (? offset))) - (test:machine-constant/memory 'LTGT constant:unassigned - (indirect-reference! register offset) - standard-predicate-receiver)) - -;;;; Invocations - -(define-rule statement - (INVOCATION:APPLY (? number-pushed) (? prefix) (? continuation)) - `(,@(generate-invocation-prefix prefix) - ,@(assign&invoke-entry number-pushed regnum:frame-size - entry:compiler-apply))) - -(define-rule statement - (INVOCATION:JUMP (? n) - (APPLY-CLOSURE (? frame-size) (? receiver-offset)) - (? continuation) (? procedure)) - `(,@(clear-map!) - ,@(apply-closure-sequence frame-size receiver-offset - (procedure-label procedure)))) - -(define-rule statement - (INVOCATION:JUMP (? n) - (APPLY-STACK (? frame-size) (? receiver-offset) - (? n-levels)) - (? continuation) (? procedure)) - `(,@(clear-map!) - ,@(apply-stack-sequence frame-size receiver-offset n-levels - (procedure-label procedure)))) - -(define-rule statement - (INVOCATION:JUMP (? number-pushed) (? prefix) (? continuation) (? procedure)) - (QUALIFIER (not (memq (car prefix) '(APPLY-CLOSURE APPLY-STACK)))) - `(,@(generate-invocation-prefix prefix) - ,(branch->label (procedure-label procedure)))) - -(define-rule statement - (INVOCATION:LEXPR (? number-pushed) (? prefix) (? continuation) - (? procedure)) - `(,@(generate-invocation-prefix prefix) - ,@(machine-constant->machine-register number-pushed regnum:frame-size) - ,(branch->label (procedure-label procedure)))) - -(define-rule statement - (INVOCATION:LOOKUP (? number-pushed) (? prefix) (? continuation) - (? environment) (? name)) - (let ((set-environment - (expression->machine-register! environment regnum:call-argument-0))) - (delete-dead-registers!) - `(,@set-environment - ,@(generate-invocation-prefix prefix) - ,@(scheme-constant->machine-register name regnum:call-argument-1) - ,@(assign&invoke-entry (1+ number-pushed) regnum:frame-size - entry:compiler-lookup-apply)))) - -(define-rule statement - (INVOCATION:PRIMITIVE (? number-pushed) (? prefix) (? continuation) - (? primitive)) - `(,@(generate-invocation-prefix prefix) - ,@(if (eq? primitive compiled-error-procedure) - (assign&invoke-entry number-pushed regnum:frame-size - entry:compiler-error) - ;; Simple thing for now. - (assign&invoke-entry (primitive-datum primitive) - regnum:call-argument-0 - entry:compiler-primitive-apply)))) - -(define-rule statement - (RETURN) - `(,@(clear-map!) - ,(memory-post-increment->machine-register regnum:stack-pointer - regnum:code-object-base) - ,@(object->address regnum:code-object-base) - (BE (N) (INDEX 0 1 ,regnum:code-object-base)))) - -(define (generate-invocation-prefix prefix) - `(,@(clear-map!) - ,@(case (car prefix) - ((NULL) '()) - ((MOVE-FRAME-UP) - (apply generate-invocation-prefix:move-frame-up (cdr prefix))) - ((APPLY-CLOSURE) - (apply generate-invocation-prefix:apply-closure (cdr prefix))) - ((APPLY-STACK) - (apply generate-invocation-prefix:apply-stack (cdr prefix))) - (else (error "GENERATE-INVOCATION-PREFIX: bad prefix type" prefix))))) - -(define (generate-invocation-prefix:move-frame-up frame-size how-far) - (cond ((or (zero? frame-size) (zero? how-far)) '()) - ((= frame-size 1) - `(,(load-memory-increment regnum:stack-pointer (+ frame-size how-far) - r1) - ,(store-memory r1 regnum:stack-pointer 0))) - ((= frame-size 2) - (let ((temp (allocate-temporary-register! false))) - `(,(load-memory-increment regnum:stack-pointer 1 r1) - ,(load-memory-increment regnum:stack-pointer (-1+ how-far) temp) - ,(store-memory r1 regnum:stack-pointer 0) - ,(store-memory temp regnum:stack-pointer 1)))) - (else - (let ((temp0 (allocate-temporary-register! false)) - (temp1 (allocate-temporary-register! false))) - `((LDO () - ,(offset-reference regnum:stack-pointer frame-size) - ,temp0) - (LDO () - ,(offset-reference regnum:stack-pointer - (+ frame-size how-far)) - ,temp1) - ,@(generate-n-times - frame-size 5 - `(,(load-memory-increment temp0 -1 r1)) - (store-memory-increment r1 temp1 -1) - (lambda (generator) - (generator (allocate-temporary-register! false)))) - ,(machine->machine-register temp1 regnum:stack-pointer)))))) - -(define (generate-invocation-prefix:apply-closure frame-size receiver-offset) - (let ((label (generate-label))) - `(,@(apply-closure-sequence frame-size receiver-offset label) - (LABEL ,label)))) - -(define (generate-invocation-prefix:apply-stack frame-size receiver-offset - n-levels) - (let ((label (generate-label))) - `(,@(apply-stack-sequence frame-size receiver-offset n-levels label) - (LABEL ,label)))) - -;;;; Environment Calls - -(define-rule statement - (INTERPRETER-CALL:ACCESS (? environment) (? name)) - (lookup-call entry:compiler-access environment name)) - -(define-rule statement - (INTERPRETER-CALL:LOOKUP (? environment) (? name)) - (lookup-call entry:compiler-lookup environment name)) - -(define-rule statement - (INTERPRETER-CALL:UNASSIGNED? (? environment) (? name)) - (lookup-call entry:compiler-unassigned? environment name)) - -(define-rule statement - (INTERPRETER-CALL:UNBOUND? (? environment) (? name)) - (lookup-call entry:compiler-unbound? environment name)) - -(define (lookup-call entry environment name) - (let ((set-environment - (expression->machine-register! environment regnum:call-argument-0))) - (let ((clear-map (clear-map!))) - `(,@set-environment - ,@clear-map - ,(scheme-constant->machine-register name regnum:argument-1) - (BLE (N) ,entry) - ,@(make-external-label (generate-label)))))) - -(define-rule statement - (INTERPRETER-CALL:ENCLOSE (? number-pushed)) - `(,@(cons-pointer->machine-register (ucode-type vector) regnum:free-pointer - regnum:call-value) - ,@(non-pointer->memory-post-increment (ucode-type manifest-vector) - number-pushed - regnum:free-pointer) - ,@(generate-n-times number-pushed 5 - `(,(load-memory-increment regnum:stack-pointer 1 r1)) - (store-memory-increment r1 regnum:free-pointer 1) - (lambda (generator) - (generator (allocate-temporary-register! false)))))) - -(define-rule statement - (INTERPRETER-CALL:DEFINE (? environment) (? name) (? value)) - (QUALIFIER (not (eq? 'CONS-POINTER (car value)))) - (assignment-call:default entry:compiler-define environment name value)) - -(define-rule statement - (INTERPRETER-CALL:SET! (? environment) (? name) (? value)) - (QUALIFIER (not (eq? 'CONS-POINTER (car value)))) - (assignment-call:default entry:compiler-set! environment name value)) - -(define (assignment-call:default entry environment name value) - (let ((set-environment - (expression->machine-register! environment regnum:call-argument-0))) - (let ((set-value - (expression->machine-register! value regnum:call-argument-2))) - (let ((clear-map (clear-map!))) - `(,@set-environment - ,@set-value - ,@clear-map - ,@(scheme-constant->machine-register name regnum:call-argument-1) - (BLE (N) ,entry) - ,@(make-external-label (generate-label))))))) - -(define-rule statement - (INTERPRETER-CALL:DEFINE (? environment) (? name) - (CONS-POINTER (CONSTANT (? type)) - (REGISTER (? datum)))) - (assignment-call:cons-pointer entry:compiler-define environment name type - datum)) - -(define-rule statement - (INTERPRETER-CALL:SET! (? environment) (? name) - (CONS-POINTER (CONSTANT (? type)) - (REGISTER (? datum)))) - (assignment-call:cons-pointer entry:compiler-set! environment name type - datum)) - -(define (assignment-call:cons-pointer entry environment name type datum) - (let ((set-environment - (expression->machine-register! environment regnum:call-argument-0))) - (let ((set-value - (cons-pointer->machine-register type datum regnum:call-argument-2))) - (let ((clear-map (clear-map!))) - `(,@set-environment - ,@set-value - ,@clear-map - ,@(scheme-constant->machine-register name regnum:call-argument-1) - (BLE (N) ,entry) - ,@(make-external-label (generate-label))))))) - -;;;; Procedure/Continuation Entries - -;;; The following calls MUST appear as the first thing at the entry -;;; point of a procedure. They assume that the register map is clear -;;; and that no register contains anything of value. - -;;; **** The only reason that this is true is that no register is live -;;; across calls. If that were not true, then we would have to save -;;; any such registers on the stack so that they would be GC'ed -;;; appropriately. - -(define-rule statement - (PROCEDURE-HEAP-CHECK (? procedure)) - (let ((label (generate-label))) - `(,@(procedure-header procedure) - (COMBT (LT N) ,regnum:free-pointer ,regnum:memtop-pointer - ,(label-relative-expression label)) - (BLE (N) ,entry:compiler-interrupt-procedure) - (LABEL ,label)))) - -(define-rule statement - (CONTINUATION-HEAP-CHECK (? continuation)) - (let ((label (generate-label))) - `(,@(make-external-label (continuation-label continuation)) - (COMBT (LT N) ,regnum:free-pointer ,regnum:memtop-pointer - ,(label-relative-expression label)) - (BLE (N) ,entry:compiler-interrupt-procedure) - (LABEL ,label)))) - -(define (procedure-header procedure) - (let ((internal-label (procedure-label procedure))) - (append! (if (procedure/closure? procedure) - (let ((required (1+ (length (procedure-required procedure)))) - (optional (length (procedure-optional procedure))) - (label (procedure-external-label procedure))) - (if (and (procedure-rest procedure) - (zero? required)) - (begin (set-procedure-external-label! procedure - internal-label) - `((ENTRY-POINT ,internal-label))) - `((ENTRY-POINT ,label) - ,@(make-external-label label) - ,@(cond ((procedure-rest procedure) - (test:machine-constant/machine-register - 'GTEQ required regnum:frame-size - (inline-predicate-receiver internal-label))) - ((zero? optional) - (test:machine-constant/machine-register - 'EQ required regnum:frame-size - (inline-predicate-receiver internal-label))) - (else - (let ((wna-label (generate-label))) - `(,@(test:machine-constant/machine-register - 'LT required regnum:frame-size - (inline-predicate-receiver wna-label)) - ,@(test:machine-constant/machine-register - 'LTEQ (+ required optional) - regnum:frame-size - (inline-predicate-receiver - internal-label)) - (LABEL ,wna-label))))) - ,(invoke-entry - entry:compiler-wrong-number-of-arguments)))) - '()) - `(,@(make-external-label internal-label))))) - -(define *block-start-label*) - -(define (make-external-label label) - `((WORD (- ,label ,*block-start-label*)) - (LABEL ,label))) - -;;;; Poppers - -(define-rule statement - (MESSAGE-RECEIVER:CLOSURE (? frame-size)) - (machine-constant->memory-pre-decrement (* frame-size 4) r30)) - -(define-rule statement - (MESSAGE-RECEIVER:STACK (? frame-size)) - (machine-constant->memory-pre-decrement (+ #x00200000 (* frame-size 4)) - r30)) - -(define-rule statement - (MESSAGE-RECEIVER:SUBPROBLEM (? continuation)) - `(,@(typed-label->memory-pre-decrement (ucode-type return-address) - (continuation-label continuation) - r30) - ,@(machine-constant->memory-pre-decrement #x00400000 r30))) - -(define (apply-closure-sequence frame-size receiver-offset label) - `(,@(machine-constant->machine-register (* frame-size 4) r19) - (LDO () ,(offset-reference r30 (* receiver-offset 4)) ,r20) - ,@(label->machine-register label r21) - (BLE (N) ,popper:apply-closure))) - -(define (apply-stack-sequence frame-size receiver-offset n-levels label) - `(,@(machine-constant->machine-register (* frame-size 4) r19) - (LDO () ,(offset-reference r30 (* receiver-offset 4)) ,r20) - ,@(label->machine-register label r21) - ,@(machine-constant->machine-register n-levels r22) - (BLE (N) ,popper:apply-stack))) - -(define-rule statement - (MESSAGE-SENDER:VALUE (? receiver-offset)) - `(,@(clear-map!) - (LDO () ,(offset-reference r30 (* receiver-offset 4)) ,r30) - (BLE (N) ,popper:value))) \ No newline at end of file diff --git a/v7/src/compiler/machines/spectrum/machin.scm b/v7/src/compiler/machines/spectrum/machin.scm deleted file mode 100644 index ac31a85c6..000000000 --- a/v7/src/compiler/machines/spectrum/machin.scm +++ /dev/null @@ -1,183 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/machin.scm,v 1.41 1987/03/19 00:55:54 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Machine Model for Spectrum - -(declare (usual-integrations)) - -(define (rtl:message-receiver-size:closure) 1) -(define (rtl:message-receiver-size:stack) 1) -(define (rtl:message-receiver-size:subproblem) 1) - -(define-integrable (stack->memory-offset offset) - offset) - -(define (rtl:expression-cost expression) - ;; Returns an estimate of the cost of evaluating the expression. - ;; For time being, disable this feature. - 1) - -(define (rtl:machine-register? rtl-register) - (case rtl-register - ((STACK-POINTER) (interpreter-stack-pointer)) - ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access)) - ((INTERPRETER-CALL-RESULT:ENCLOSE) (interpreter-register:enclose)) - ((INTERPRETER-CALL-RESULT:LOOKUP) (interpreter-register:lookup)) - ((INTERPRETER-CALL-RESULT:UNASSIGNED?) (interpreter-register:unassigned?)) - ((INTERPRETER-CALL-RESULT:UNBOUND?) (interpreter-register:unbound?)) - (else false))) - -(define (rtl:interpreter-register? rtl-register) - (case rtl-register - ((MEMORY_TOP) 0) - ((STACK_GUARD) 1) - ((VALUE) 2) - ((ENVIRONMENT) 3) - ((TEMPORARY) 4) - (else false))) - -(define (rtl:interpreter-register->offset locative) - (or (rtl:interpreter-register? locative) - (error "Unknown register type" locative))) - -(define-integrable r0 0) -(define-integrable r1 1) -(define-integrable r2 2) -(define-integrable r3 3) -(define-integrable r4 4) -(define-integrable r5 5) -(define-integrable r6 6) -(define-integrable r7 7) -(define-integrable r8 8) -(define-integrable r9 9) -(define-integrable r10 10) -(define-integrable r11 11) -(define-integrable r12 12) -(define-integrable r13 13) -(define-integrable r14 14) -(define-integrable r15 15) -(define-integrable r16 16) -(define-integrable r17 17) -(define-integrable r18 18) -(define-integrable r19 19) -(define-integrable r20 20) -(define-integrable r21 21) -(define-integrable r22 22) -(define-integrable r23 23) -(define-integrable r24 24) -(define-integrable r25 25) -(define-integrable r26 26) -(define-integrable r27 27) -(define-integrable r28 28) -(define-integrable r29 29) -(define-integrable r30 30) -(define-integrable r31 31) - -(define number-of-machine-registers 32) - -(define-integrable (sort-machine-registers registers) - registers) - -(define (pseudo-register=? x y) - (= (register-renumber x) (register-renumber y))) - -(define available-machine-registers - (list r3 r4 r5 r6 r7 r8 r9 r10 r11 r12 r13 r14 r15 r16 r17 r18 - r19 r20 r21 r22)) - -(define-integrable (register-contains-address? register) - (memv register '(23 24 25 30))) - -(define-integrable (register-type register) - false) - -(define-integrable (register-reference register) - register) - -(define-integrable regnum:frame-size r3) -(define-integrable regnum:call-argument-0 r4) -(define-integrable regnum:call-argument-1 r5) -(define-integrable regnum:call-argument-2 r6) -(define-integrable regnum:call-value r28) - -(define-integrable regnum:memtop-pointer r23) -(define-integrable regnum:regs-pointer r24) -(define-integrable regnum:free-pointer r25) -(define-integrable regnum:code-object-base r26) -(define-integrable regnum:address-offset r27) -(define-integrable regnum:stack-pointer r30) - -(define-integrable (interpreter-register:access) - (rtl:make-machine-register regnum:call-value)) - -(define-integrable (interpreter-register:enclose) - (rtl:make-machine-register regnum:call-value)) - -(define-integrable (interpreter-register:lookup) - (rtl:make-machine-register regnum:call-value)) - -(define-integrable (interpreter-register:unassigned?) - (rtl:make-machine-register regnum:call-value)) - -(define-integrable (interpreter-register:unbound?) - (rtl:make-machine-register regnum:call-value)) - -(define-integrable (interpreter-free-pointer) - (rtl:make-machine-register regnum:free-pointer)) - -(define-integrable (interpreter-free-pointer? register) - (= (rtl:register-number register) regnum:free-pointer)) - -(define-integrable (interpreter-regs-pointer) - (rtl:make-machine-register regnum:regs-pointer)) - -(define-integrable (interpreter-regs-pointer? register) - (= (rtl:register-number register) regnum:regs-pointer)) - -(define-integrable (interpreter-stack-pointer) - (rtl:make-machine-register regnum:stack-pointer)) - -(define-integrable (interpreter-stack-pointer? register) - (= (rtl:register-number register) regnum:stack-pointer)) - -(define (lap:make-label-statement label) - `(LABEL ,label)) - -(define (lap:make-unconditional-branch label) - `((BL (N) (- (- ,label *PC*) 8) 0))) - -(define (lap:make-entry-point label block-start-label) - `((ENTRY-POINT ,label) - (WORD (- ,label ,block-start-label)) - (LABEL ,label))) \ No newline at end of file diff --git a/v7/src/compiler/machines/spectrum/make.scm b/v7/src/compiler/machines/spectrum/make.scm deleted file mode 100644 index 2461094ee..000000000 --- a/v7/src/compiler/machines/spectrum/make.scm +++ /dev/null @@ -1,131 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/make.scm,v 1.3 1987/03/19 00:56:02 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Compiler Make File for HP Precision Architecture - -(declare (usual-integrations)) - -(set-working-directory-pathname! "$zcomp") -(load "rcs" system-global-environment) -(load "load" system-global-environment) - -(load-system system-global-environment - 'COMPILER-PACKAGE - '(SYSTEM-GLOBAL-ENVIRONMENT) - '( - (SYSTEM-GLOBAL-ENVIRONMENT - "macros.bin" ;compiler syntax - "pbs.bin" ;bit-string read/write syntax - ) - - (COMPILER-PACKAGE - "spectrum/machin.bin" ;machine dependent stuff - "toplev.bin" ;top level - "utils.bin" ;odds and ends - "cfg.bin" ;control flow graph - "ctypes.bin" ;CFG datatypes - "dtypes.bin" ;DFG datatypes - "bblock.bin" ;Basic block datatype - "dfg.bin" ;data flow graph - "rtl.bin" ;register transfer language - "emodel.bin" ;environment model - "rtypes.bin" ;RTL analyzer datatypes - "nmatch.bin" ;simple pattern matcher - ) - - (CONVERTER-PACKAGE - "graphc.bin" ;SCode->flow-graph converter - ) - - (DATAFLOW-PACKAGE - "dflow.bin" ;Dataflow analyzer - ) - - (RTL-GENERATOR-PACKAGE - "rtlgen.bin" ;RTL generator - "rgcomb.bin" ;RTL generator: combinations - "linear.bin" ;linearization - ) - - (RTL-CSE-PACKAGE - "rcse.bin" ;RTL common subexpression eliminator - ) - - (RTL-ANALYZER-PACKAGE - "rlife.bin" ;RTL register lifetime analyzer - "ralloc.bin" ;RTL register allocator - ) - - (LAP-GENERATOR-PACKAGE - "lapgen.bin" ;LAP generator. - "regmap.bin" ;Hardware register allocator. - "spectrum/lapgen.bin" ;code generation rules. - ) - - (LAP-SYNTAXER-PACKAGE - "syntax.bin" ;Generic syntax phase - "spectrum/insutl.bin" ;Utilities for spectrum - "spectrum/coerce.bin" ;Coercions: integer -> bit string - "asmmac.bin" ;Macros for hairy syntax - "spectrum/instrs.bin" ;Spectrum instructions - ) - - (LAP-PACKAGE - "spectrum/assmd.bin" ;Machine dependent - "symtab.bin" ;Symbol tables - "block.bin" ;Assembly blocks - "laptop.bin" ;Assembler top level - "spectrum/asmops.bin" ;Spectrum assembly operators - ) - - )) - -(in-package compiler-package - - (define compiler-system - (make-environment - (define :name "Liar (Spectrum)") - (define :version) - (define :modification) - - (parse-rcs-header "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/make.scm,v 1.3 1987/03/19 00:56:02 cph Exp $" - (lambda (filename version date time author state) - (set! :version (car version)) - (set! :modification (cadr version)))))) - - (add-system! compiler-system)) - -(%ge compiler-package) -(%gst (access compiler-syntax-table compiler-package)) -(disk-save "$zcomp/machines/spectrum/compiler") \ No newline at end of file diff --git a/v7/src/compiler/rtlbase/rtlcfg.scm b/v7/src/compiler/rtlbase/rtlcfg.scm deleted file mode 100644 index 26cbbc334..000000000 --- a/v7/src/compiler/rtlbase/rtlcfg.scm +++ /dev/null @@ -1,82 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcfg.scm,v 1.1 1987/03/19 00:44:34 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; RTL CFG Nodes - -(declare (usual-integrations)) - -;;; Hack to make RNODE-RTL, etc, work on both types of node. - -(define-snode rtl-snode) -(define-pnode rtl-pnode) -(define-vector-slots rnode 7 rtl dead-registers logical-link register-map lap) -(define-vector-slots rtl-pnode 12 consequent-lap-generator - alternative-lap-generator) - -(define-integrable (statement->snode statement) - (make-pnode rtl-snode-tag statement '() false false false)) - -(define-integrable (statement->scfg statement) - (snode->scfg (statement->snode statement))) - -(define-integrable (predicate->pnode predicate) - (make-pnode rtl-pnode-tag predicate '() false false false false false)) - -(define-integrable (predicate->pcfg predicate) - (pnode->pcfg (predicate->pnode predicate))) - -(define-integrable (rnode-dead-register? rnode register) - (memv register (rnode-dead-registers rnode))) - -(let ((rnode-describe - (lambda (rnode) - `((RNODE-RTL ,(rnode-rtl rnode)) - (RNODE-DEAD-REGISTERS ,(rnode-dead-registers rnode)) - (RNODE-LOGICAL-LINK ,(rnode-logical-link rnode)) - (RNODE-REGISTER-MAP ,(rnode-register-map rnode)) - (RNODE-LAP ,(rnode-lap rnode)))))) - - (define-vector-method rtl-snode-tag ':DESCRIBE - (lambda (snode) - (append! ((vector-tag-method snode-tag ':DESCRIBE) snode) - (rnode-describe snode)))) - - (define-vector-method rtl-pnode-tag ':DESCRIBE - (lambda (pnode) - (append! ((vector-tag-method pnode-tag ':DESCRIBE) pnode) - (rnode-describe pnode) - `((RTL-PNODE-CONSEQUENT-LAP-GENERATOR - ,(rtl-pnode-consequent-lap-generator pnode)) - (RTL-PNODE-ALTERNATIVE-LAP-GENERATOR - ,(rtl-pnode-alternative-lap-generator pnode))))))) \ No newline at end of file diff --git a/v7/src/compiler/rtlbase/rtlreg.scm b/v7/src/compiler/rtlbase/rtlreg.scm deleted file mode 100644 index c5f701b7e..000000000 --- a/v7/src/compiler/rtlbase/rtlreg.scm +++ /dev/null @@ -1,66 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlreg.scm,v 1.1 1987/03/19 00:44:37 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; RTL Registers - -(declare (usual-integrations)) - -(define machine-register-map - (make-vector number-of-machine-registers)) - -(let loop ((n 0)) - (if (< n number-of-machine-registers) - (begin (vector-set! machine-register-map n (%make-register n)) - (loop (1+ n))))) - -(define-integrable (rtl:make-machine-register n) - (vector-ref machine-register-map n)) - -(define *next-pseudo-number*) -(define *temporary->register-map*) - -(define (rtl:make-pseudo-register) - (let ((n *next-pseudo-number*)) - (set! *next-pseudo-number* (1+ *next-pseudo-number*)) - (%make-register n))) - -(define (temporary->register temporary) - (let ((entry (assq temporary *temporary->register-map*))) - (if entry - (cdr entry) - (let ((register (rtl:make-pseudo-register))) - (set! *temporary->register-map* - (cons (cons temporary register) - *temporary->register-map*)) - register)))) \ No newline at end of file diff --git a/v7/src/compiler/rtlbase/rtlty1.scm b/v7/src/compiler/rtlbase/rtlty1.scm deleted file mode 100644 index 371394aeb..000000000 --- a/v7/src/compiler/rtlbase/rtlty1.scm +++ /dev/null @@ -1,172 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 1.2 1987/04/12 00:21:39 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Register Transfer Language Type Definitions - -(declare (usual-integrations)) - -(define-rtl-expression register % number) -(define-rtl-expression object->address rtl: register) -(define-rtl-expression object->datum rtl: register) -(define-rtl-expression object->type rtl: register) -(define-rtl-expression offset rtl: register number) -(define-rtl-expression pre-increment rtl: register number) -(define-rtl-expression post-increment rtl: register number) - -(define-rtl-expression cons-pointer rtl: type datum) -(define-rtl-expression constant rtl: value) -(define-rtl-expression entry:continuation rtl: continuation) -(define-rtl-expression entry:procedure rtl: procedure) -(define-rtl-expression offset-address rtl: register number) -(define-rtl-expression unassigned rtl:) - -(define-rtl-predicate eq-test % expression-1 expression-2) -(define-rtl-predicate true-test % expression) -(define-rtl-predicate type-test % expression type) -(define-rtl-predicate unassigned-test % expression) - -(define-rtl-statement assign % address expression) -(define-rtl-statement continuation-heap-check rtl: continuation) -(define-rtl-statement procedure-heap-check rtl: procedure) -(define-rtl-statement return rtl:) -(define-rtl-statement setup-lexpr rtl: procedure) - -(define-rtl-statement interpreter-call:access % environment name) -(define-rtl-statement interpreter-call:define % environment name value) -(define-rtl-statement interpreter-call:enclose rtl: size) -(define-rtl-statement interpreter-call:lookup % environment name) -(define-rtl-statement interpreter-call:set! % environment name value) -(define-rtl-statement interpreter-call:unassigned? % environment name) -(define-rtl-statement interpreter-call:unbound? % environment name) - -(define-rtl-statement invocation:apply rtl: pushed prefix continuation) -(define-rtl-statement invocation:jump % pushed prefix continuation procedure) -(define-rtl-statement invocation:lexpr rtl: pushed prefix continuation - procedure) -(define-rtl-statement invocation:lookup % pushed prefix continuation - environment name) -(define-rtl-statement invocation:primitive rtl: pushed prefix continuation - procedure) - -(define-rtl-statement message-sender:value rtl: size) -(define-rtl-statement message-receiver:closure rtl: size) -(define-rtl-statement message-receiver:stack rtl: size) -(define-rtl-statement message-receiver:subproblem rtl: continuation) - -(define-integrable rtl:expression-type first) -(define-integrable rtl:address-register second) -(define-integrable rtl:address-number third) -(define-integrable rtl:invocation-pushed second) -(define-integrable rtl:invocation-prefix third) -(define-integrable rtl:invocation-continuation fourth) -(define-integrable rtl:test-expression second) - -;;;; Locatives - -;;; Locatives are used as an intermediate form by the code generator -;;; to build expressions. Later, when the expressions are inserted -;;; into statements, any locatives they contain are eliminated by -;;; "simplifying" them into sequential instructions using pseudo -;;; registers. - -(define-integrable register:environment - 'ENVIRONMENT) - -(define-integrable register:stack-pointer - 'STACK-POINTER) - -(define-integrable register:value - 'VALUE) - -(define-integrable (rtl:interpreter-call-result:access) - (rtl:make-fetch 'INTERPRETER-CALL-RESULT:ACCESS)) - -(define-integrable (rtl:interpreter-call-result:enclose) - (rtl:make-fetch 'INTERPRETER-CALL-RESULT:ENCLOSE)) - -(define-integrable (rtl:interpreter-call-result:lookup) - (rtl:make-fetch 'INTERPRETER-CALL-RESULT:LOOKUP)) - -(define-integrable (rtl:interpreter-call-result:unassigned?) - (rtl:make-fetch 'INTERPRETER-CALL-RESULT:UNASSIGNED?)) - -(define-integrable (rtl:interpreter-call-result:unbound?) - (rtl:make-fetch 'INTERPRETER-CALL-RESULT:UNBOUND?)) - -(define (rtl:locative-offset locative offset) - (cond ((zero? offset) locative) - ((and (pair? locative) (eq? (car locative) 'OFFSET)) - `(OFFSET ,(cadr locative) ,(+ (caddr locative) offset))) - (else `(OFFSET ,locative ,offset)))) - -;;; Expressions that are used in the intermediate form. - -(define-integrable (rtl:make-fetch locative) - `(FETCH ,locative)) - -(define-integrable (rtl:make-address locative) - `(ADDRESS ,locative)) - -(define-integrable (rtl:make-cell-cons expression) - `(CELL-CONS ,expression)) - -(define-integrable (rtl:make-typed-cons:pair type car cdr) - `(TYPED-CONS:PAIR ,type ,car ,cdr)) - -;;; Linearizer Support - -(define-integrable (rtl:make-jump-statement label) - `(JUMP ,label)) - -(define-integrable (rtl:make-jumpc-statement predicate label) - `(JUMPC ,predicate ,label)) - -(define-integrable (rtl:make-label-statement label) - `(LABEL ,label)) - -(define-integrable (rtl:negate-predicate expression) - `(NOT ,expression)) - -;;; Stack - -(define-integrable (stack-locative-offset locative offset) - (rtl:locative-offset locative (stack->memory-offset offset))) - -(define-integrable (stack-push-address) - (rtl:make-pre-increment (interpreter-stack-pointer) - (stack->memory-offset -1))) - -(define-integrable (stack-pop-address) - (rtl:make-post-increment (interpreter-stack-pointer) -(define-rtl-statement message-receiver:subproblem % continuation) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/rgcomb.scm b/v7/src/compiler/rtlgen/rgcomb.scm deleted file mode 100644 index c9e3aa870..000000000 --- a/v7/src/compiler/rtlgen/rgcomb.scm +++ /dev/null @@ -1,548 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 1.9 1987/04/17 07:46:08 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; RTL Generation: Combinations - -(declare (usual-integrations)) - -(define-generator combination-tag - (lambda (combination offset rest-generator) - ((cond ((combination-constant? combination) combination:constant) - ((let ((operator (combination-known-operator combination))) - (and operator - (normal-primitive-constant? operator))) - combination:primitive) - (else combination:normal)) - combination offset rest-generator))) - -(define (combination:normal combination offset rest-generator) - ;; For the time being, all close-coded combinations will return - ;; their values in the value register. If the value of a - ;; combination is not a temporary, it is a value-ignore, which is - ;; alright. - (let ((value (combination-value combination))) - (if (temporary? value) - (let ((type (temporary-type value))) - (if type - (if (not (eq? 'VALUE type)) - (error "COMBINATION:NORMAL: Bad temporary type" type)) - (set-temporary-type! value 'VALUE))))) - (if (generate:next-is-null? (snode-next combination) rest-generator) - (combination:reduction combination offset) - (combination:subproblem combination offset rest-generator))) - -(define (combination:constant combination offset rest-generator) - (let ((value (combination-value combination)) - (next (snode-next combination))) - (cond ((value-temporary? value) - (generate-assignment (combination-block combination) - value - (combination-constant-value combination) - next - offset - rest-generator - rvalue->sexpression)) - ((value-ignore? value) - (generate:next next offset rest-generator)) - (else (error "Unknown combination value" value))))) - -(define (combination:primitive combination offset rest-generator) - (let ((open-coder - (assq (constant-value (combination-known-operator combination)) - primitive-open-coders))) - (or (and open-coder - ((cdr open-coder) combination offset rest-generator)) - (combination:normal combination offset rest-generator)))) - -(define (define-open-coder primitive open-coder) - (let ((entry (assq primitive primitive-open-coders))) - (if entry - (set-cdr! entry open-coder) - (set! primitive-open-coders - (cons (cons primitive open-coder) - primitive-open-coders)))) - primitive) - -(define primitive-open-coders - '()) - -(define-open-coder pair? - (lambda (combination offset rest-generator) - (and (combination-compiled-for-predicate? combination) - (open-code:type-test combination offset rest-generator - (ucode-type pair) 0)))) - -(define-open-coder primitive-type? - (lambda (combination offset rest-generator) - (and (combination-compiled-for-predicate? combination) - (operand->index combination 0 - (lambda (type) - (open-code:type-test combination offset rest-generator - type 1)))))) - -(define (open-code:type-test combination offset rest-generator type operand) - (let ((next (snode-next combination)) - (operand (list-ref (combination-operands combination) operand))) - (generate:subproblem operand offset - (lambda (offset) - (generate:predicate next offset rest-generator - (rvalue->pexpression (subproblem-value operand) offset - (lambda (expression) - (rtl:make-type-test (rtl:make-object->type expression) - type)))))))) - -(define-integrable (combination-compiled-for-predicate? combination) - (eq? 'PREDICATE (combination-compilation-type combination))) - -(define-open-coder car - (lambda (combination offset rest-generator) - (open-code:memory-reference combination offset rest-generator 0))) - -(define-open-coder cdr - (lambda (combination offset rest-generator) - (open-code:memory-reference combination offset rest-generator 1))) - -(define-open-coder cell-contents - (lambda (combination offset rest-generator) - (open-code:memory-reference combination offset rest-generator 0))) - -(define-open-coder vector-length - (lambda (combination offset rest-generator) - (open-code-expression-1 combination offset rest-generator - (lambda (operand) - (rtl:make-cons-pointer - (rtl:make-constant (ucode-type fixnum)) - (rtl:make-fetch (rtl:locative-offset operand 0))))))) - -(define-open-coder vector-ref - (lambda (combination offset rest-generator) - (operand->index combination 1 - (lambda (index) - (open-code:memory-reference combination offset rest-generator - (1+ index)))))) - -(define (open-code:memory-reference combination offset rest-generator index) - (open-code-expression-1 combination offset rest-generator - (lambda (operand) - (rtl:make-fetch (rtl:locative-offset operand index))))) - -(define (open-code-expression-1 combination offset rest-generator receiver) - (let ((operand (car (combination-operands combination)))) - (generate:subproblem operand offset - (lambda (offset) - (generate-assignment (combination-block combination) - (combination-value combination) - (subproblem-value operand) - (snode-next combination) - offset - rest-generator - (lambda (rvalue offset receiver*) - (rvalue->sexpression rvalue offset - (lambda (expression) - (receiver* (receiver expression)))))))))) - -(define (operand->index combination n receiver) - (let ((operand (list-ref (combination-operands combination) n))) - (and (subproblem-known-constant? operand) - (let ((value (subproblem-constant-value operand))) - (and (integer? value) - (not (negative? value)) - (receiver value)))))) - -;;;; Subproblems - -(define (combination:subproblem combination offset rest-generator) - (let ((block (combination-block combination)) - (finish - (lambda (offset delta call-prefix continuation-prefix) - (let ((continuation (make-continuation delta))) - (set-continuation-rtl-entry! - continuation - (scfg*node->node! - (scfg*scfg->scfg! - (rtl:make-continuation-heap-check continuation) - continuation-prefix) - (generate:next (snode-next combination) offset rest-generator))) - (scfg*node->node! (call-prefix continuation) - (combination:subproblem-body combination - (+ offset delta) - continuation)))))) - (cond ((ic-block? block) - ;; **** Actually, should only do this if the environment - ;; will be needed by the continuation. - (finish (1+ offset) 1 - (lambda (continuation) - (scfg*scfg->scfg! - (rtl:make-push (rtl:make-fetch register:environment)) - (rtl:make-push-return continuation))) - (rtl:make-pop register:environment))) - ((and (stack-block? block) - (let ((operator (combination-known-operator combination))) - (and operator - (procedure? operator) - (procedure/open-internal? operator)))) - (finish offset - (rtl:message-receiver-size:subproblem) - rtl:make-message-receiver:subproblem - (make-null-cfg))) - (else - (finish offset 1 rtl:make-push-return (make-null-cfg)))))) - -(define (combination:subproblem-body combination offset continuation) - ((let ((operator (combination-known-operator combination))) - (cond ((normal-primitive-constant? operator) make-call:primitive) - ((or (not operator) (not (procedure? operator))) make-call:unknown) - (else - (case (procedure/type operator) - ((OPEN-INTERNAL) make-call:stack-with-link) - ((OPEN-EXTERNAL) make-call:open-external) - ((CLOSURE) make-call:closure) - ((IC) make-call:ic) - (else (error "Unknown callee type" operator)))))) - combination offset invocation-prefix:null continuation)) - -;;;; Reductions - -(define (combination:reduction combination offset) - (let ((callee (combination-known-operator combination)) - (block (combination-block combination))) - (define (choose-generator ic external internal) - ((let ((caller (block-procedure block))) - (cond ((or (not caller) (procedure/ic? caller)) ic) - ((procedure/external? caller) external) - (else internal))) - combination offset)) - (cond ((normal-primitive-constant? callee) - (choose-generator reduction:ic->primitive - reduction:external->primitive - reduction:internal->primitive)) - ((or (not callee) - (not (procedure? callee))) - (choose-generator reduction:ic->unknown - reduction:external->unknown - reduction:internal->unknown)) - (else - (case (procedure/type callee) - ((IC) - (choose-generator reduction:ic->ic - reduction:external->ic - reduction:internal->ic)) - ((CLOSURE) - (choose-generator reduction:ic->closure - reduction:external->closure - reduction:internal->closure)) - ((OPEN-EXTERNAL) - (choose-generator reduction:ic->open-external - reduction:external->open-external - reduction:internal->open-external)) - ((OPEN-INTERNAL) - (choose-generator reduction:ic->child - reduction:external->child - (let ((block* (procedure-block callee))) - (cond ((block-child? block block*) - reduction:internal->child) - ((block-sibling? block block*) - reduction:internal->sibling) - (else - reduction:internal->ancestor))))) - (else (error "Unknown callee type" callee))))))) - -(define (reduction:ic->unknown combination offset) - (make-call:unknown combination offset invocation-prefix:null false)) - -(define (reduction:ic->ic combination offset) - (make-call:ic combination offset invocation-prefix:null false)) - -(define (reduction:ic->primitive combination offset) - (make-call:primitive combination offset invocation-prefix:null false)) - -(define (reduction:ic->closure combination offset) - (make-call:closure combination offset invocation-prefix:null false)) - -(define (reduction:ic->open-external combination offset) - (make-call:open-external combination offset invocation-prefix:null false)) - -(define (reduction:ic->child combination offset) - (error "Calling internal procedure from IC procedure")) - -(define (reduction:external->unknown combination offset) - (make-call:unknown combination offset invocation-prefix:move-frame-up false)) - -(define (reduction:external->ic combination offset) - (make-call:ic combination offset invocation-prefix:move-frame-up false)) - -(define (reduction:external->primitive combination offset) - (make-call:primitive combination offset invocation-prefix:move-frame-up - false)) - -(define (reduction:external->closure combination offset) - (make-call:closure combination offset invocation-prefix:move-frame-up false)) - -(define (reduction:external->open-external combination offset) - (make-call:open-external combination offset invocation-prefix:move-frame-up - false)) - -(define (reduction:external->child combination offset) - (make-call:child combination offset - rtl:make-message-receiver:closure - rtl:message-receiver-size:closure)) - -(define (reduction:internal->unknown combination offset) - (make-call:unknown combination offset invocation-prefix:internal->closure - false)) - -(define (reduction:internal->ic combination offset) - (make-call:ic combination offset invocation-prefix:internal->closure false)) - -(define (reduction:internal->primitive combination offset) - (make-call:primitive combination offset invocation-prefix:internal->closure - false)) - -(define (reduction:internal->closure combination offset) - (make-call:closure combination offset invocation-prefix:internal->closure - false)) - -(define (reduction:internal->open-external combination offset) - (make-call:open-external combination offset - invocation-prefix:internal->closure - false)) - -(define (reduction:internal->child combination offset) - (make-call:child combination offset - rtl:make-message-receiver:stack - rtl:message-receiver-size:stack)) - -(define (reduction:internal->sibling combination offset) - (make-call:stack combination offset invocation-prefix:internal->sibling - false)) - -(define (reduction:internal->ancestor combination offset) - (make-call:stack-with-link combination offset - invocation-prefix:internal->ancestor false)) - -;;;; Calls - -(define (make-call:apply combination offset invocation-prefix continuation) - (make-call:push-operator combination offset - (lambda (number-pushed) - (rtl:make-invocation:apply number-pushed - (invocation-prefix combination number-pushed) - continuation)))) - -(define (make-call:lookup combination offset invocation-prefix continuation) - (make-call:dont-push-operator combination offset - (lambda (number-pushed) - (let ((operator (subproblem-value (combination-operator combination)))) - (let ((block (reference-block operator)) - (name (variable-name (reference-variable operator)))) - (rtl:make-invocation:lookup - number-pushed - (invocation-prefix combination number-pushed) - continuation - (nearest-ic-block-expression block (+ offset number-pushed)) - (intern-scode-variable! block name))))))) - -(define (make-call:unknown combination offset invocation-prefix continuation) - (let ((operator (subproblem-value (combination-operator combination)))) - ((cond ((or (not (reference? operator)) - (reference-to-known-location? operator)) - make-call:apply) - ;; **** Need to add code for links here. - (else make-call:lookup)) - combination offset invocation-prefix continuation))) - -;;; For now, use apply. Later we can optimize for the cases where -;;; the callee's closing frame is easily available, such as calling a -;;; sibling, self-recursion, or an ancestor. - -(define make-call:ic make-call:apply) - -(define (make-call:primitive combination offset invocation-prefix continuation) - (make-call:dont-push-operator combination offset - (lambda (number-pushed) - (rtl:make-invocation:primitive - number-pushed - (invocation-prefix combination number-pushed) - continuation - (constant-value (combination-known-operator combination)))))) - -(define (make-call:closure combination offset invocation-prefix continuation) - (make-call:push-operator combination offset - (external-call combination invocation-prefix continuation))) - -(define (make-call:open-external combination offset invocation-prefix - continuation) - (scfg*node->node! - (rtl:make-push (rtl:make-fetch register:environment)) - (make-call:dont-push-operator combination offset - (external-call combination invocation-prefix continuation)))) - -(define (external-call combination invocation-prefix continuation) - (lambda (number-pushed) - (let ((operator (combination-known-operator combination))) - ((if (procedure-rest operator) - rtl:make-invocation:lexpr - rtl:make-invocation:jump) - number-pushed - (invocation-prefix combination number-pushed) - continuation - operator)))) - -(package (make-call:stack make-call:stack-with-link make-call:child) - -(define-export (make-call:stack combination offset invocation-prefix - continuation) - (stack-call combination offset invocation-prefix continuation 0)) - -(define-export (make-call:stack-with-link combination offset invocation-prefix - continuation) - (link-call combination offset invocation-prefix continuation 0)) - -(define-export (make-call:child combination offset make-receiver receiver-size) - (scfg*node->node! - (make-receiver (block-frame-size (combination-block combination))) - (let ((extra (receiver-size))) - (link-call combination (+ offset extra) invocation-prefix:null false - extra)))) - -(define (link-call combination offset invocation-prefix continuation extra) - (scfg*node->node! - (rtl:make-push - (rtl:make-address - (block-ancestor-or-self->locative - (combination-block combination) - (block-parent (procedure-block (combination-known-operator combination))) - offset))) - (stack-call combination (1+ offset) invocation-prefix continuation - (1+ extra)))) - -(define (stack-call combination offset invocation-prefix continuation extra) - (make-call:dont-push-operator combination offset - (lambda (number-pushed) - (let ((number-pushed (+ number-pushed extra)) - (operator (combination-known-operator combination))) - ((if (procedure-rest operator) - rtl:make-invocation:lexpr - rtl:make-invocation:jump) - number-pushed - (invocation-prefix combination number-pushed) - continuation - operator))))) - -) - -;;;; Prefixes - -(define (invocation-prefix:null combination number-pushed) - '(NULL)) - -(define (invocation-prefix:move-frame-up combination number-pushed) - `(MOVE-FRAME-UP ,number-pushed - ,(block-frame-size (combination-block combination)))) - -(define (invocation-prefix:internal->closure combination number-pushed) - ;; The message sender will shift the new stack frame down to the - ;; correct position when it is done, then reset the stack pointer. - `(APPLY-CLOSURE ,number-pushed - ,(+ number-pushed - (block-frame-size (combination-block combination))))) - -(define (invocation-prefix:internal->ancestor combination number-pushed) - (let ((block (combination-block combination))) - `(APPLY-STACK ,number-pushed - ,(+ number-pushed (block-frame-size block)) - ,(block-ancestor-distance - block - (block-parent - (procedure-block - (combination-known-operator combination))))))) - -(define (invocation-prefix:internal->sibling combination number-pushed) - `(MOVE-FRAME-UP ,number-pushed - ;; -1+ means reuse the existing static link. - ,(-1+ (block-frame-size (combination-block combination))))) - -;;;; Call Sequence Kernels - -(package (make-call:dont-push-operator make-call:push-operator) - -(define (make-call-maker generate:operator wrap-n) - (lambda (combination offset make-invocation) - (let ((operator (combination-known-operator combination)) - (operands (combination-operands combination))) - (let ((n-operands (length operands)) - (finish - (lambda (n offset) - (let operand-loop - ((operands (reverse operands)) - (offset offset)) - (if (null? operands) - (generate:operator (combination-operator combination) - offset - (lambda (offset) - (cfg-entry-node (make-invocation (wrap-n n))))) - (subproblem->push (car operands) offset - (lambda (offset) - (operand-loop (cdr operands) offset)))))))) - (if (and operator - (procedure? operator) - (not (procedure-rest operator)) - (stack-block? (procedure-block operator))) - (let ((n-parameters (+ (length (procedure-required operator)) - (length (procedure-optional operator))))) - (let ((delta (- n-parameters n-operands))) - (scfg*scfg->scfg! (scfg*->scfg! (push-n-unassigned delta)) - (finish n-parameters (+ offset delta))))) - (finish n-operands offset)))))) - -(define (push-n-unassigned n) - (if (zero? n) - '() - (cons (rtl:make-push (rtl:make-unassigned)) - (push-n-unassigned (-1+ n))))) - -(define (subproblem->push subproblem offset receiver) - (generate:subproblem subproblem offset - (lambda (offset) - (scfg*node->node! - (rvalue->sexpression (subproblem-value subproblem) offset rtl:make-push) - (receiver (1+ offset)))))) - -(define-export make-call:dont-push-operator - (make-call-maker generate:subproblem identity-procedure)) - -(define-export make-call:push-operator - (make-call-maker subproblem->push 1+)) - - ,(-1+ (block-frame-size (combination-block combination))))) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/rtlgen.scm b/v7/src/compiler/rtlgen/rtlgen.scm deleted file mode 100644 index d2968195a..000000000 --- a/v7/src/compiler/rtlgen/rtlgen.scm +++ /dev/null @@ -1,479 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 1.9 1987/04/12 01:14:46 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; RTL Generation - -(declare (usual-integrations)) - -(define *nodes*) - -(define (generate-rtl quotations procedures) - (with-new-node-marks - (lambda () - (fluid-let ((*nodes* '())) - (for-each (lambda (quotation) - (set-quotation-rtl-entry! - quotation - (generate:top-level (quotation-fg-entry quotation)))) - quotations) - (for-each generate:procedure procedures) - (for-each (lambda (rnode) - (node-property-remove! rnode generate:node)) - *nodes*))))) - -(define-integrable (generate:top-level expression) - (generate:node expression 0 false)) - -(define (generate:subproblem subproblem offset rest-generator) - (let ((cfg (subproblem-cfg subproblem))) - (if (cfg-null? cfg) - (and rest-generator (rest-generator offset)) - (generate:node (cfg-entry-node cfg) offset rest-generator)))) - -(define (generate:next node offset rest-generator) - (cond ((not node) (and rest-generator (rest-generator offset))) - ((node-marked? node) - (let ((memo (node-property-get node generate:node))) - (if (not (= (car memo) offset)) - (error "Node entered at different offsets" node)) - (cdr memo))) - (else (generate:node node offset rest-generator)))) - -(define (generate:node node offset rest-generator) - (node-mark! node) - (let ((cfg ((vector-method node generate:node) node offset rest-generator))) - (node-property-put! node generate:node (cons offset cfg)) - (set! *nodes* (cons node *nodes*)) - cfg)) - -(define-integrable (generate:next-is-null? next rest-generator) - (and (not next) (not rest-generator))) - -(define (generate:procedure procedure) - (set-procedure-rtl-entry! - procedure - (let ((body (generate:top-level (procedure-fg-entry procedure)))) - (if (procedure/ic? procedure) - body - (scfg*node->node! - (scfg*scfg->scfg! - ((if (or (procedure-rest procedure) - (and (procedure/closure? procedure) - (not (null? (procedure-optional procedure))))) - rtl:make-setup-lexpr - rtl:make-procedure-heap-check) - procedure) - (setup-stack-frame procedure)) - body))))) - -(define (setup-stack-frame procedure) - (let ((block (procedure-block procedure))) - (define (cellify-variables variables) - (scfg*->scfg! (map cellify-variable variables))) - - (define (cellify-variable variable) - (if (variable-in-cell? variable) - (let ((locative - (stack-locative-offset (rtl:make-fetch register:stack-pointer) - (variable-offset block variable)))) - (rtl:make-assignment - locative - (rtl:make-cell-cons (rtl:make-fetch locative)))) - (make-null-cfg))) - - (let ((names (procedure-names procedure)) - (values (procedure-values procedure))) - (scfg-append! (setup-bindings names values '()) - (setup-auxiliary (procedure-auxiliary procedure) '()) - (cellify-variables (procedure-required procedure)) - (cellify-variables (procedure-optional procedure)) - (let ((rest (procedure-rest procedure))) - (if rest - (cellify-variable rest) - (make-null-cfg))) - (scfg*->scfg! - (map (lambda (name value) - (if (and (procedure? value) - (procedure/closure? value)) - (letrec-close block name value) - (make-null-cfg))) - names values)))))) - -(define (setup-bindings names values pushes) - (if (null? names) - (scfg*->scfg! pushes) - (setup-bindings (cdr names) - (cdr values) - (cons (make-auxiliary-push (car names) - (letrec-value (car values))) - pushes)))) - -(define (letrec-value value) - (cond ((constant? value) - (rtl:make-constant (constant-value value))) - ((procedure? value) - (case (procedure/type value) - ((CLOSURE) - (make-closure-cons value (rtl:make-constant '()))) - ((IC) - (make-ic-cons value)) - ((OPEN-EXTERNAL OPEN-INTERNAL) - (error "Letrec value is open procedure" value)) - (else - (error "Unknown procedure type" value)))) - (else - (error "Unknown letrec binding value" value)))) - -(define (letrec-close block variable value) - (make-closure-environment value 0 scfg*scfg->scfg! - (lambda (environment) - (rtl:make-assignment - (closure-procedure-environment-locative - (find-variable block variable 0 - (lambda (locative) locative) - (lambda (nearest-ic-locative name) - (error "Missing closure variable" variable)))) - environment)))) - -(define (setup-auxiliary variables pushes) - (if (null? variables) - (scfg*->scfg! pushes) - (setup-auxiliary (cdr variables) - (cons (make-auxiliary-push (car variables) - (rtl:make-unassigned)) - pushes)))) - -(define (make-auxiliary-push variable value) - (rtl:make-push (if (variable-in-cell? variable) - (rtl:make-cell-cons value) - value))) - -;;;; Statements - -(define (define-generator tag generator) - (define-vector-method tag generate:node generator)) - -(define-generator definition-tag - (lambda (definition offset rest-generator) - (scfg*node->node! - (rvalue->sexpression (definition-rvalue definition) offset - (lambda (expression) - (find-variable (definition-block definition) - (definition-lvalue definition) - offset - (lambda (locative) - (error "Definition of compiled variable")) - (lambda (environment name) - (rtl:make-interpreter-call:define environment name expression))))) - (generate:next (snode-next definition) offset rest-generator)))) - -(define-generator assignment-tag - (lambda (assignment offset rest-generator) - (generate-assignment (assignment-block assignment) - (assignment-lvalue assignment) - (assignment-rvalue assignment) - (snode-next assignment) - offset - rest-generator - rvalue->sexpression))) - -(define (generate-assignment block lvalue rvalue next offset rest-generator - rvalue->sexpression) - ((vector-method lvalue generate-assignment) - block lvalue rvalue next offset rest-generator rvalue->sexpression)) - -(define (define-assignment tag generator) - (define-vector-method tag generate-assignment generator)) - -(define-assignment variable-tag - (lambda (block variable rvalue next offset rest-generator - rvalue->sexpression) - (scfg*node->node! (if (integrated-vnode? variable) - (make-null-cfg) - (rvalue->sexpression rvalue offset - (lambda (expression) - (find-variable block variable offset - (lambda (locative) - (rtl:make-assignment locative expression)) - (lambda (environment name) - (rtl:make-interpreter-call:set! - environment - (intern-scode-variable! block name) - expression)))))) - (generate:next next offset rest-generator)))) - -(define-assignment temporary-tag - (lambda (block temporary rvalue next offset rest-generator - rvalue->sexpression) - (case (temporary-type temporary) - ((#F) - (scfg*node->node! - (if (integrated-vnode? temporary) - (make-null-cfg) - (rvalue->sexpression rvalue offset - (lambda (expression) - (rtl:make-assignment temporary expression)))) - (generate:next next offset rest-generator))) - ((VALUE) - (assignment:value-register block rvalue next offset - rest-generator rvalue->sexpression)) - (else - (error "Unknown temporary type" temporary))))) - -(define (assignment:value-register block rvalue next offset - rest-generator rvalue->sexpression) - (if (not (generate:next-is-null? next rest-generator)) - (error "Return node has next")) - (scfg*node->node! - (scfg*scfg->scfg! (if (value-temporary? rvalue) - (make-null-cfg) - (rvalue->sexpression rvalue offset - (lambda (expression) - (rtl:make-assignment register:value expression)))) - (if (stack-block? block) - (if (stack-parent? block) - (rtl:make-message-sender:value - (+ offset (block-frame-size block))) - (scfg*scfg->scfg! - (rtl:make-pop-frame (block-frame-size block)) - (rtl:make-return))) - (rtl:make-return))) - (generate:next next offset rest-generator))) - -(define-assignment value-ignore-tag - (lambda (block value-ignore rvalue next offset rest-generator - rvalue->sexpression) - (if (not (generate:next-is-null? next rest-generator)) - (error "Return node has next")) - (generate:next next offset rest-generator))) - -;;;; Predicates - -(define (define-predicate-generator tag node-generator) - (define-generator tag - (lambda (pnode offset rest-generator) - (generate:predicate pnode offset rest-generator - (node-generator pnode offset))))) - -(define (generate:predicate pnode offset rest-generator pcfg) - (pcfg*node->node! - pcfg - (generate:next (pnode-consequent pnode) offset rest-generator) - (generate:next (pnode-alternative pnode) offset rest-generator))) - -(define-predicate-generator true-test-tag - (lambda (test offset) - (let ((rvalue (true-test-rvalue test))) - (if (rvalue-known-constant? rvalue) - (constant->pcfg (rvalue-constant-value rvalue)) - (rvalue->pexpression rvalue offset rtl:make-true-test))))) - -(define-predicate-generator unassigned-test-tag - (lambda (test offset) - (find-variable (unassigned-test-block test) - (unassigned-test-variable test) - offset - (lambda (locative) - (rtl:make-unassigned-test (rtl:make-fetch locative))) - (lambda (environment name) - (scfg*pcfg->pcfg! - (rtl:make-interpreter-call:unassigned? environment name) - (rtl:make-true-test (rtl:interpreter-call-result:unassigned?))))))) - -(define-predicate-generator unbound-test-tag - (lambda (test offset) - (let ((variable (unbound-test-variable test))) - (if (ic-block? (variable-block variable)) - (scfg*pcfg->pcfg! - (rtl:make-interpreter-call:unbound? - (nearest-ic-block-expression (unbound-test-block test) offset) - (variable-name variable)) - (rtl:make-true-test (rtl:interpreter-call-result:unbound?))) - (make-false-pcfg))))) - -;;;; Expressions - -(define (rvalue->sexpression rvalue offset receiver) - (rvalue->expression rvalue offset scfg*scfg->scfg! receiver)) - -(define (rvalue->pexpression rvalue offset receiver) - (rvalue->expression rvalue offset scfg*pcfg->pcfg! receiver)) - -(define (rvalue->expression rvalue offset scfg-append! receiver) - ((vector-method rvalue rvalue->expression) - rvalue offset scfg-append! receiver)) - -(define (define-rvalue->expression tag generator) - (define-vector-method tag rvalue->expression generator)) - -(define (constant->expression constant offset scfg-append! receiver) - (receiver (rtl:make-constant (constant-value constant)))) - -(define-rvalue->expression constant-tag constant->expression) - -(define-rvalue->expression block-tag - (lambda (block offset scfg-append! receiver) - (receiver (rtl:make-fetch register:environment)))) - -(define-rvalue->expression reference-tag - (lambda (reference offset scfg-append! receiver) - (reference->expression (reference-block reference) - (reference-variable reference) - offset - scfg-append! - receiver))) - -(define (reference->expression block variable offset scfg-append! receiver) - (if (vnode-known-constant? variable) - (constant->expression (vnode-known-value variable) offset scfg-append! - receiver) - (find-variable block variable offset - (lambda (locative) - (receiver (rtl:make-fetch locative))) - (lambda (environment name) - (scfg-append! (rtl:make-interpreter-call:lookup - environment - (intern-scode-variable! block name)) - (receiver (rtl:interpreter-call-result:lookup))))))) - -(define-rvalue->expression temporary-tag - (lambda (temporary offset scfg-append! receiver) - (if (vnode-known-constant? temporary) - (constant->expression (vnode-known-value temporary) offset scfg-append! - receiver) - (let ((type (temporary-type temporary))) - (cond ((not type) (receiver (rtl:make-fetch temporary))) - ((eq? type 'VALUE) (receiver (rtl:make-fetch register:value))) - (else (error "Illegal temporary reference" type))))))) - -(define-rvalue->expression access-tag - (lambda (*access offset scfg-append! receiver) - (rvalue->expression (access-environment *access) offset scfg-append! - (lambda (expression) - (scfg-append! (rtl:make-interpreter-call:access expression - (access-name *access)) - (receiver (rtl:interpreter-call-result:access))))))) - -(define-rvalue->expression procedure-tag - (lambda (procedure offset scfg-append! receiver) - (case (procedure/type procedure) - ((CLOSURE) - (make-closure-environment procedure offset scfg-append! - (lambda (environment) - (receiver (make-closure-cons procedure environment))))) - ((IC) - (receiver (make-ic-cons procedure))) - ((OPEN-EXTERNAL OPEN-INTERNAL) - (error "Reference to open procedure" procedure)) - (else - (error "Unknown procedure type" procedure))))) - -(define (make-ic-cons procedure) - ;; IC procedures have their entry points linked into their headers - ;; at load time by the linker. - (let ((header - (scode/make-lambda (variable-name (procedure-name procedure)) - (map variable-name (procedure-required procedure)) - (map variable-name (procedure-optional procedure)) - (let ((rest (procedure-rest procedure))) - (and rest (variable-name rest))) - (map variable-name - (append (procedure-auxiliary procedure) - (procedure-names procedure))) - '() - false))) - (set! *ic-procedure-headers* - (cons (cons procedure header) - *ic-procedure-headers*)) - (rtl:make-typed-cons:pair - (rtl:make-constant (scode/procedure-type-code header)) - (rtl:make-constant header) - ;; Is this right if the procedure is being closed - ;; inside another IC procedure? - (rtl:make-fetch register:environment)))) - -(define (make-closure-environment procedure offset scfg-append! receiver) - (let ((block (block-parent (procedure-block procedure)))) - (define (ic-locative closure-block block offset) - (let ((loser - (lambda (locative) - (error "Closure parent not IC block")))) - (find-block closure-block block offset loser loser - (lambda (locative nearest-ic-locative) locative)))) - (cond ((not block) - (receiver (rtl:make-constant false))) - ((ic-block? block) - (receiver - (let ((closure-block (procedure-closure-block procedure))) - (if (ic-block? closure-block) - (rtl:make-fetch register:environment) - (ic-locative closure-block block offset))))) - ((closure-block? block) - (let ((closure-block (procedure-closure-block procedure))) - (define (loop variables n receiver) - (if (null? variables) - (receiver offset n '()) - (loop (cdr variables) (1+ n) - (lambda (offset n pushes) - (receiver (1+ offset) n - (cons (rtl:make-push - (rtl:make-fetch - (find-closure-variable closure-block - (car variables) - offset))) - pushes)))))) - - (define (make-frame n pushes) - (scfg-append! (scfg*->scfg! - (reverse! - (cons (rtl:make-interpreter-call:enclose n) - pushes))) - (receiver (rtl:interpreter-call-result:enclose)))) - - (loop (block-bound-variables block) 0 - (lambda (offset n pushes) - (let ((parent (block-parent block))) - (if parent - (make-frame (1+ n) - (cons (rtl:make-push - (ic-locative closure-block parent - offset)) - pushes)) - (make-frame n pushes))))))) - (else (error "Unknown block type" block))))) - -(define (make-closure-cons procedure environment) - (rtl:make-typed-cons:pair (rtl:make-constant type-code:compiled-procedure) - (rtl:make-entry:procedure procedure) - "node rtl arguments") \ No newline at end of file diff --git a/v7/src/compiler/rtlopt/ralloc.scm b/v7/src/compiler/rtlopt/ralloc.scm deleted file mode 100644 index 7f53d09be..000000000 --- a/v7/src/compiler/rtlopt/ralloc.scm +++ /dev/null @@ -1,126 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/ralloc.scm,v 1.10 1987/03/19 00:46:34 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; Register Allocation -;;; Based on the GNU C Compiler - -(declare (usual-integrations)) - -(define (register-allocation bblocks) - ;; First, renumber all the registers remaining to be allocated. - (let ((next-renumber 0) - (register->renumber (make-vector *n-registers* false))) - (define (renumbered-registers n) - (if (< n *n-registers*) - (if (vector-ref register->renumber n) - (cons n (renumbered-registers (1+ n))) - (renumbered-registers (1+ n))) - '())) - (for-each-pseudo-register - (lambda (register) - (if (positive? (register-n-refs register)) - (begin (vector-set! register->renumber register next-renumber) - (set! next-renumber (1+ next-renumber)))))) - ;; Now create a conflict matrix for those registers and fill it. - (let ((conflict-matrix - (make-initialized-vector next-renumber - (lambda (i) - (make-regset next-renumber))))) - (for-each (lambda (bblock) - (let ((live (make-regset next-renumber))) - (for-each-regset-member (bblock-live-at-entry bblock) - (lambda (register) - (let ((renumber - (vector-ref register->renumber register))) - (if renumber - (regset-adjoin! live renumber))))) - (bblock-walk-forward bblock - (lambda (rnode next) - (for-each-regset-member live - (lambda (renumber) - (regset-union! (vector-ref conflict-matrix - renumber) - live))) - (for-each (lambda (register) - (let ((renumber - (vector-ref register->renumber - register))) - (if renumber - (regset-delete! live renumber)))) - (rnode-dead-registers rnode)) - (mark-births! live - (rnode-rtl rnode) - register->renumber))))) - bblocks) - - ;; Finally, sort the renumbered registers into an allocation - ;; order, and then allocate them into registers one at a time. - ;; Return the number of required real registers as a value. - (let ((next-allocation 0) - (allocated (make-vector next-renumber 0))) - (for-each (lambda (register) - (let ((renumber (vector-ref register->renumber register))) - (define (loop allocation) - (if (< allocation next-allocation) - (if (regset-disjoint? - (vector-ref conflict-matrix renumber) - (vector-ref allocated allocation)) - allocation - (loop (1+ allocation))) - (let ((allocation next-allocation)) - (set! next-allocation (1+ next-allocation)) - (vector-set! allocated allocation - (make-regset next-renumber)) - allocation))) - (let ((allocation (loop 0))) - (vector-set! *register-renumber* register allocation) - (regset-adjoin! (vector-ref allocated allocation) - renumber)))) - (sort (renumbered-registers number-of-machine-registers) - allocaterenumber) - (if (rtl:assign? rtl) - (let ((address (rtl:assign-address rtl))) - (if (rtl:register? address) - (let ((register (rtl:register-number address))) - (if (pseudo-register? register) - (regset-adjoin! live - (vector-ref register->renumber - register)))))))) \ No newline at end of file diff --git a/v7/src/compiler/rtlopt/rcse1.scm b/v7/src/compiler/rtlopt/rcse1.scm deleted file mode 100644 index ba8646118..000000000 --- a/v7/src/compiler/rtlopt/rcse1.scm +++ /dev/null @@ -1,552 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 1.101 1987/04/12 00:22:23 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; RTL Common Subexpression Elimination -;;; Based on the GNU C Compiler - -(declare (usual-integrations)) - -(define (common-subexpression-elimination blocks n-registers) - (fluid-let ((*next-quantity-number* 0)) - (state:initialize n-registers - (lambda () - (for-each walk-block blocks))))) - -(define (walk-block block) - (state:reset!) - (walk-rnode block)) - -(define (walk-rnode rnode) - (if (node-previous>1? rnode) (state:reset!)) ;Easy non-optimal solution. - ((vector-method rnode walk-rnode) rnode)) - -(define-vector-method rtl-snode-tag walk-rnode - (lambda (rnode) - (cse-statement (rnode-rtl rnode)) - (let ((next (snode-next rnode))) - (if next (walk-rnode next))))) - -(define-vector-method rtl-pnode-tag walk-rnode - (lambda (rnode) - (cse-statement (rnode-rtl rnode)) - (let ((consequent (pnode-consequent rnode)) - (alternative (pnode-alternative rnode))) - (if consequent - (if alternative - ;; Copy the world's state. - (let ((state (state:get))) - (walk-rnode consequent) - (state:set! state) - (walk-rnode alternative)) - (walk-rnode consequent)) - (if alternative - (walk-rnode alternative)))))) - -(define (cse-statement statement) - ((cdr (or (assq (rtl:expression-type statement) cse-methods) - (error "Missing CSE method" (car statement)))) - statement)) - -(define cse-methods '()) - -(define (define-cse-method type method) - (let ((entry (assq type cse-methods))) - (if entry - (set-cdr! entry method) - (set! cse-methods (cons (cons type method) cse-methods)))) - type) - -(define-cse-method 'ASSIGN - (lambda (statement) - (expression-replace! rtl:assign-expression rtl:set-assign-expression! - statement - (let ((address (rtl:assign-address statement))) - (cond ((rtl:register? address) - (lambda (volatile? insert-source!) - (register-expression-invalidate! address) - (if (not volatile?) - (insert-register-destination! address (insert-source!))))) - ((stack-reference? address) - (lambda (volatile? insert-source!) - (stack-reference-invalidate! address) - (if (not volatile?) - (insert-stack-destination! address (insert-source!))))) - (else - (lambda (volatile? insert-source!) - (let ((memory-invalidate! - (cond ((stack-push/pop? address) - (lambda () 'DONE)) - ((heap-allocate? address) - (lambda () - (register-expression-invalidate! - (rtl:address-register address)))) - (else - (memory-invalidator - (expression-varies? address)))))) - (full-expression-hash address - (lambda (hash volatile?* in-memory?*) - (cond (volatile?* (memory-invalidate!)) - ((not volatile?) - (let ((address - (find-cheapest-expression address hash - false))) - (let ((element (insert-source!))) - (memory-invalidate!) - (insert-memory-destination! - address - element - (modulo (+ (symbol-hash 'ASSIGN) hash) - n-buckets))))))))) - ;; **** Kludge. Works only because stack-pointer - ;; gets used in very fixed way by code generator. - (if (stack-push/pop? address) - (stack-pointer-adjust! - (rtl:address-number address)))))))))) - -(define (noop statement) 'DONE) - -(define (trivial-action volatile? insert-source!) - (if (not volatile?) (insert-source!))) - -(define ((normal-action thunk) volatile? insert-source!) - (thunk) - (if (not volatile?) (insert-source!))) - -(define (define-trivial-one-arg-method type get set) - (define-cse-method type - (lambda (statement) - (expression-replace! get set statement trivial-action)))) - -(define (define-trivial-two-arg-method type get-1 set-1 get-2 set-2) - (define-cse-method type - (lambda (statement) - (expression-replace! get-1 set-1 statement trivial-action) - (expression-replace! get-2 set-2 statement trivial-action)))) - -(define-trivial-two-arg-method 'EQ-TEST - rtl:eq-test-expression-1 rtl:set-eq-test-expression-1! - rtl:eq-test-expression-2 rtl:set-eq-test-expression-2!) - -(define-trivial-one-arg-method 'TRUE-TEST - rtl:true-test-expression rtl:set-true-test-expression!) - -(define-trivial-one-arg-method 'TYPE-TEST - rtl:type-test-expression rtl:set-type-test-expression!) - -(define-trivial-one-arg-method 'UNASSIGNED-TEST - rtl:type-test-expression rtl:set-unassigned-test-expression!) - -(define-cse-method 'RETURN noop) -(define-cse-method 'PROCEDURE-HEAP-CHECK noop) -(define-cse-method 'CONTINUATION-HEAP-CHECK noop) - -(define (define-stack-trasher type) - (define-cse-method type trash-stack)) - -(define (trash-stack statement) - (stack-invalidate!) - (stack-pointer-invalidate!)) - -(define-stack-trasher 'SETUP-LEXPR) -(define-stack-trasher 'MESSAGE-SENDER:VALUE) - -(define-cse-method 'INTERPRETER-CALL:ENCLOSE - (lambda (statement) - (let ((n (rtl:interpreter-call:enclose-size statement))) - (stack-region-invalidate! 0 n) - (stack-pointer-adjust! n)) - (expression-invalidate! (interpreter-register:enclose)))) - -(define (define-lookup-method type get-environment set-environment! register) - (define-cse-method type - (lambda (statement) - (expression-replace! get-environment set-environment! statement - (normal-action - (lambda () - (expression-invalidate! (register)) - (non-object-invalidate!))))))) - -(define-lookup-method 'INTERPRETER-CALL:ACCESS - rtl:interpreter-call:access-environment - rtl:set-interpreter-call:access-environment! - interpreter-register:access) - -(define-lookup-method 'INTERPRETER-CALL:LOOKUP - rtl:interpreter-call:lookup-environment - rtl:set-interpreter-call:lookup-environment! - interpreter-register:lookup) - -(define-lookup-method 'INTERPRETER-CALL:UNASSIGNED? - rtl:interpreter-call:unassigned?-environment - rtl:set-interpreter-call:unassigned?-environment! - interpreter-register:unassigned?) - -(define-lookup-method 'INTERPRETER-CALL:UNBOUND? - rtl:interpreter-call:unbound?-environment - rtl:set-interpreter-call:unbound?-environment! - interpreter-register:unbound?) - -(define (define-assignment-method type - get-environment set-environment! - get-value set-value!) - (define-cse-method type - (lambda (statement) - (expression-replace! get-value set-value! statement trivial-action) - (expression-replace! get-environment set-environment! statement - (normal-action - (lambda () - (memory-invalidate! true) - (non-object-invalidate!))))))) - -(define-assignment-method 'INTERPRETER-CALL:DEFINE - rtl:interpreter-call:define-environment - rtl:set-interpreter-call:define-environment! - rtl:interpreter-call:define-value - rtl:set-interpreter-call:define-value!) - -(define-assignment-method 'INTERPRETER-CALL:SET! - rtl:interpreter-call:set!-environment - rtl:set-interpreter-call:set!-environment! - rtl:interpreter-call:set!-value - rtl:set-interpreter-call:set!-value!) - -(define (define-invocation-method type) - (define-cse-method type - noop -#| This will be needed when the snode-next of an invocation - gets connected to the callee's entry node. - (lambda (statement) - (let ((prefix (rtl:invocation-prefix statement))) - (case (car prefix) - ((NULL) (continuation-adjustment statement)) - ((MOVE-FRAME-UP) - (let ((size (second prefix)) - (distance (third prefix))) - (stack-region-invalidate! 0 (+ size distance)) ;laziness - (stack-pointer-adjust! distance))) - ((APPLY-STACK APPLY-CLOSURE) (trash-stack statement)) - (else (error "Bad prefix type" prefix))))) -|# - )) - -(define (continuation-adjustment statement) - (let ((continuation (rtl:invocation-continuation statement))) - (if continuation - (stack-pointer-adjust! (+ (rtl:invocation-pushed statement) - (continuation-delta continuation)))))) - -(define-invocation-method 'INVOCATION:APPLY) -(define-invocation-method 'INVOCATION:JUMP) -(define-invocation-method 'INVOCATION:LEXPR) -(define-invocation-method 'INVOCATION:PRIMITIVE) - -(define-cse-method 'INVOCATION:LOOKUP - (lambda (statement) - (continuation-adjustment statement) - (expression-replace! rtl:invocation:lookup-environment - rtl:set-invocation:lookup-environment! - statement - trivial-action))) - -(define (define-message-receiver type size) - (define-cse-method type - (let ((size (delay (- (size))))) - (lambda (statement) - (stack-pointer-adjust! (force size)))))) - -(define-message-receiver 'MESSAGE-RECEIVER:CLOSURE - rtl:message-receiver-size:closure) - -(define-message-receiver 'MESSAGE-RECEIVER:STACK - rtl:message-receiver-size:closure) - -(define-message-receiver 'MESSAGE-RECEIVER:SUBPROBLEM - rtl:message-receiver-size:subproblem) - -;;;; Canonicalization - -(define (expression-replace! statement-expression set-statement-expression! - statement receiver) - ;; Replace the expression by its cheapest equivalent. Returns two - ;; values: (1) a flag which is true iff the expression is volatile; - ;; and (2) a thunk which, when called, will insert the expression in - ;; the hash table, returning the element. Do not call the thunk if - ;; the expression is volatile. - (let ((expression - (expression-canonicalize (statement-expression statement)))) - (full-expression-hash expression - (lambda (hash volatile? in-memory?) - (let ((element - (find-cheapest-valid-element expression hash volatile?))) - (define (finish expression hash volatile? in-memory?) - (set-statement-expression! statement expression) - (receiver - volatile? - (expression-inserter expression element hash in-memory?))) - (if element - (let ((expression (element-expression element))) - (full-expression-hash expression - (lambda (hash volatile? in-memory?) - (finish expression hash volatile? in-memory?)))) - (finish expression hash volatile? in-memory?))))))) - -(define ((expression-inserter expression element hash in-memory?)) - (or element - (begin (if (rtl:register? expression) - (set-register-expression! (rtl:register-number expression) - expression) - (mention-registers! expression)) - (let ((element* (hash-table-insert! hash expression false))) - (set-element-in-memory?! element* in-memory?) - (element-first-value element*))))) - -(define (expression-canonicalize expression) - (cond ((rtl:register? expression) - (or (register-expression - (quantity-first-register - (register-quantity (rtl:register-number expression)))) - expression)) - ((stack-reference? expression) - (let ((register - (quantity-first-register - (stack-reference-quantity expression)))) - (or (and register (register-expression register)) - expression))) - (else - (rtl:map-subexpressions expression expression-canonicalize)))) - -;;;; Invalidation - -(define (memory-invalidator variable?) - (let ((predicate (if variable? element-address-varies? element-in-memory?))) - (lambda () - (hash-table-delete-class! predicate)))) - -(define (memory-invalidate! variable?) - (hash-table-delete-class! - (if variable? element-address-varies? element-in-memory?))) - -(define (non-object-invalidate!) - (hash-table-delete-class! - (lambda (element) - (expression-not-object? (element-expression element))))) - -(define (element-address-varies? element) - (expression-address-varies? (element-expression element))) - -(define (expression-invalidate! expression) - ;; Delete any expression which refers to this expression from the - ;; table. - (if (rtl:register? expression) - (register-expression-invalidate! expression) - (hash-table-delete-class! - (lambda (element) - (expression-refers-to? (element-expression element) expression))))) - -(define (register-expression-invalidate! expression) - ;; Invalidate a register expression. These expressions are handled - ;; specially for efficiency -- the register is marked invalid but we - ;; delay searching the hash table for relevant expressions. - (register-invalidate! (rtl:register-number expression)) - (let ((hash (expression-hash expression))) - (hash-table-delete! hash (hash-table-lookup hash expression)))) - -(define (register-invalidate! register) - (let ((next (register-next-equivalent register)) - (previous (register-previous-equivalent register)) - (quantity (register-quantity register))) - (set-register-tick! register (1+ (register-tick register))) - (if next - (set-register-previous-equivalent! next previous) - (set-quantity-last-register! quantity previous)) - (if previous - (set-register-next-equivalent! previous next) - (set-quantity-first-register! quantity next)) - (set-register-quantity! register (new-quantity register)) - (set-register-next-equivalent! register false) - (set-register-previous-equivalent! register false))) - -;;;; Destination Insertion - -(define (insert-register-destination! expression element) - ;; Insert EXPRESSION, which should be a register expression, into - ;; the hash table as the destination of an assignment. ELEMENT is - ;; the hash table element for the value being assigned to - ;; EXPRESSION. - (let ((class (element->class element)) - (register (rtl:register-number expression))) - (define (register-equivalence! quantity) - (set-register-quantity! register quantity) - (let ((last (quantity-last-register quantity))) - (if last - (begin (set-register-next-equivalent! last register) - (set-register-previous-equivalent! register last)) - (begin (set-quantity-first-register! quantity register) - (set-quantity-last-register! quantity register)))) - (set-register-next-equivalent! register false) - (set-quantity-last-register! quantity register)) - - (set-register-expression! register expression) - (if class - (let ((expression (element-expression class))) - (cond ((rtl:register? expression) - (register-equivalence! - (register-quantity (rtl:register-number expression)))) - ((stack-reference? expression) - (register-equivalence! - (stack-reference-quantity expression)))))) - (set-element-in-memory?! - (hash-table-insert! (expression-hash expression) expression class) - false))) - -(define (insert-stack-destination! expression element) - (set-element-in-memory?! (hash-table-insert! (expression-hash expression) - expression - (element->class element)) - false)) - -(define (insert-memory-destination! expression element hash) - (let ((class (element->class element))) - (mention-registers! expression) - (set-element-in-memory?! (hash-table-insert! hash expression class) true))) - -(define (mention-registers! expression) - (if (rtl:register? expression) - (let ((register (rtl:register-number expression))) - (remove-invalid-references! register) - (set-register-in-table! register (register-tick register))) - (rtl:for-each-subexpression expression mention-registers!))) - -(define (remove-invalid-references! register) - ;; If REGISTER is invalid, delete all expressions which refer to it - ;; from the hash table. - (if (let ((in-table (register-in-table register))) - (and (not (negative? in-table)) - (not (= in-table (register-tick register))))) - (let ((expression (register-expression register))) - (hash-table-delete-class! - (lambda (element) - (let ((expression* (element-expression element))) - (and (not (rtl:register? expression*)) - (expression-refers-to? expression* expression)))))))) - -;;;; Table Search - -(define (find-cheapest-expression expression hash volatile?) - ;; Find the cheapest equivalent expression for EXPRESSION. - (let ((element (find-cheapest-valid-element expression hash volatile?))) - (if element - (element-expression element) - expression))) - -(define (find-cheapest-valid-element expression hash volatile?) - ;; Find the cheapest valid hash table element for EXPRESSION. - ;; Returns false if no such element exists or if EXPRESSION is - ;; VOLATILE?. - (and (not volatile?) - (let ((element (hash-table-lookup hash expression))) - (and element - (let ((element* (element-first-value element))) - (if (eq? element element*) - element - (let loop ((element element*)) - (and element - (let ((expression (element-expression element))) - (if (or (rtl:register? expression) - (expression-valid? expression)) - element - (loop (element-next-value element)))))))))))) - -(define (expression-valid? expression) - ;; True iff all registers mentioned in EXPRESSION have valid values - ;; in the hash table. - (if (rtl:register? expression) - (let ((register (rtl:register-number expression))) - (= (register-in-table register) (register-tick register))) - (rtl:all-subexpressions? expression expression-valid?))) - -(define (element->class element) - ;; Return the cheapest element in the hash table which has the same - ;; value as ELEMENT. This is necessary because ELEMENT may have - ;; been deleted due to register or memory invalidation. - (and element - ;; If ELEMENT has been deleted from the hash table, - ;; CLASS will be false. [ref crock-1] - (let ((class (element-first-value element))) - (or class - (element->class (element-next-value element)))))) - -;;;; Expression Hash - -(define (expression-hash expression) - (full-expression-hash expression - (lambda (hash do-not-record? hash-arg-in-memory?) - hash))) - -(define (full-expression-hash expression receiver) - (let ((do-not-record? false) - (hash-arg-in-memory? false)) - (define (loop expression) - (let ((type (rtl:expression-type expression))) - (+ (symbol-hash type) - (case type - ((REGISTER) - (quantity-number - (register-quantity (rtl:register-number expression)))) - ((OFFSET) - ;; Note that stack-references do not get treated as - ;; memory for purposes of invalidation. This is because - ;; (supposedly) no one ever accesses the stack directly - ;; except the compiler's output, which is explicit. - (let ((register (rtl:offset-register expression))) - (if (interpreter-stack-pointer? register) - (quantity-number (stack-reference-quantity expression)) - (begin (set! hash-arg-in-memory? true) - (continue expression))))) - ((PRE-INCREMENT POST-INCREMENT) - (set! hash-arg-in-memory? true) - (set! do-not-record? true) - 0) - (else (continue expression)))))) - - (define (continue expression) - (rtl:reduce-subparts expression + 0 loop hash-object)) - - (let ((hash (loop expression))) - (receiver (modulo hash n-buckets) do-not-record? hash-arg-in-memory?)))) - -(define (hash-object object) - (cond ((integer? object) object) - ((symbol? object) (symbol-hash object)) - rtl:set-interpreter-call:set!-value!) \ No newline at end of file diff --git a/v7/src/compiler/rtlopt/rcseep.scm b/v7/src/compiler/rtlopt/rcseep.scm deleted file mode 100644 index e480eb028..000000000 --- a/v7/src/compiler/rtlopt/rcseep.scm +++ /dev/null @@ -1,108 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseep.scm,v 1.2 1987/03/20 05:12:44 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; RTL Common Subexpression Elimination: Expression Predicates -;;; Based on the GNU C Compiler - -(declare (usual-integrations)) - -(define (expression-equivalent? x y validate?) - ;; If VALIDATE? is true, assume that Y comes from the hash table and - ;; should have its register references validated. - (define (loop x y) - (let ((type (rtl:expression-type x))) - (and (eq? type (rtl:expression-type y)) - (case type - ((REGISTER) - (register-equivalent? x y)) - ((OFFSET) - (let ((rx (rtl:offset-register x))) - (and (register-equivalent? rx (rtl:offset-register y)) - (if (interpreter-stack-pointer? rx) - (eq? (stack-reference-quantity x) - (stack-reference-quantity y)) - (= (rtl:offset-number x) - (rtl:offset-number y)))))) - (else - (rtl:match-subexpressions x y loop)))))) - - (define (register-equivalent? x y) - (let ((x (rtl:register-number x)) - (y (rtl:register-number y))) - (and (eq? (register-quantity x) (register-quantity y)) - (or (not validate?) - (= (register-in-table y) (register-tick y)))))) - - (loop x y)) - -(define (expression-refers-to? x y) - ;; True iff any subexpression of X matches Y. - (define (loop x) - (or (eq? x y) - (if (eq? (rtl:expression-type x) (rtl:expression-type y)) - (expression-equivalent? x y false) - (rtl:any-subexpression? x loop)))) - (loop x)) - -(define (expression-address-varies? expression) - (if (memq (rtl:expression-type expression) - '(OFFSET PRE-INCREMENT POST-INCREMENT)) - (register-expression-varies? (rtl:address-register expression)) - (rtl:any-subexpression? expression expression-address-varies?))) - -(define (expression-varies? expression) - ;; This procedure should not be called on a register expression. - (let ((type (rtl:expression-type expression))) - (or (memq type '(OFFSET PRE-INCREMENT POST-INCREMENT)) - (if (eq? type 'REGISTER) - (register-expression-varies? expression) - (rtl:any-subexpression? expression expression-varies?))))) - -(define (register-expression-varies? expression) - (not (= regnum:regs-pointer (rtl:register-number expression)))) - -(define (stack-push/pop? expression) - (and (pre/post-increment? expression) - (interpreter-stack-pointer? (rtl:address-register expression)))) - -(define (heap-allocate? expression) - (and (pre/post-increment? expression) - (interpreter-free-pointer? (rtl:address-register expression)))) - -(define-integrable (pre/post-increment? expression) - (memq (rtl:expression-type expression) '(PRE-INCREMENT POST-INCREMENT))) - -(define-integrable (expression-not-object? expression) - (memq (rtl:expression-type expression) - (loop x)) \ No newline at end of file diff --git a/v7/src/compiler/rtlopt/rcseht.scm b/v7/src/compiler/rtlopt/rcseht.scm deleted file mode 100644 index 570313df9..000000000 --- a/v7/src/compiler/rtlopt/rcseht.scm +++ /dev/null @@ -1,173 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseht.scm,v 1.1 1987/03/19 00:49:04 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; RTL Common Subexpression Elimination: Hash Table Abstraction -;;; Based on the GNU C Compiler - -(declare (usual-integrations)) - -(define n-buckets 31) - -(define (make-hash-table) - (make-vector n-buckets false)) - -(define *hash-table*) - -(define-integrable (hash-table-ref hash) - (vector-ref *hash-table* hash)) - -(define-integrable (hash-table-set! hash element) - (vector-set! *hash-table* hash element)) - -(define element-tag (make-vector-tag false 'ELEMENT)) -(define element? (tagged-vector-predicate element-tag)) - -(define-vector-slots element 1 - expression cost in-memory? - next-hash previous-hash - next-value previous-value first-value) - -(define (make-element expression) - (vector element-tag expression false false false false false false false)) - -(define (hash-table-lookup hash expression) - (define (loop element) - (and element - (if (let ((expression* (element-expression element))) - (or (eq? expression expression*) - (expression-equivalent? expression expression* true))) - element - (loop (element-next-hash element))))) - (loop (hash-table-ref hash))) - -(define (hash-table-insert! hash expression class) - (let ((element (make-element expression)) - (cost (rtl:expression-cost expression))) - (set-element-cost! element cost) - (let ((next (hash-table-ref hash))) - (set-element-next-hash! element next) - (if next (set-element-previous-hash! next element))) - (hash-table-set! hash element) - (cond ((not class) - (set-element-first-value! element element)) - ((< cost (element-cost class)) - (set-element-next-value! element class) - (set-element-previous-value! class element) - (let loop ((x element)) - (if x - (begin (set-element-first-value! x element) - (loop (element-next-value x)))))) - (else - (set-element-first-value! element class) - (let loop ((previous class) - (next (element-next-value class))) - (cond ((not next) - (set-element-next-value! element false) - (set-element-next-value! previous element) - (set-element-previous-value! element previous)) - ((<= cost (element-cost next)) - (set-element-next-value! element next) - (set-element-previous-value! next element) - (set-element-next-value! previous element) - (set-element-previous-value! element previous)) - (else - (loop next (element-next-value next))))))) - element)) - -(define (hash-table-delete! hash element) - (if element - (begin - ;; **** Mark this element as removed. [ref crock-1] - (set-element-first-value! element false) - (let ((next (element-next-value element)) - (previous (element-previous-value element))) - (if next (set-element-previous-value! next previous)) - (if previous - (set-element-next-value! previous next) - (let loop ((element next)) - (if element - (begin (set-element-first-value! element next) - (loop (element-next-value element))))))) - (let ((next (element-next-hash element)) - (previous (element-previous-hash element))) - (if next (set-element-previous-hash! next previous)) - (if previous - (set-element-next-hash! previous next) - (hash-table-set! hash next)))))) - -(define (hash-table-delete-class! predicate) - (let table-loop ((i 0)) - (if (< i n-buckets) - (let bucket-loop ((element (hash-table-ref i))) - (if element - (begin (if (predicate element) - (hash-table-delete! i element)) - (bucket-loop (element-next-hash element))) - (table-loop (1+ i))))))) - -(package (hash-table-copy) - -(define *elements*) - -(define-export (hash-table-copy table) - (fluid-let ((*elements* '())) - (vector-map table element-copy))) - -(define (element-copy element) - (and element - (let ((entry (assq element *elements*))) - (if entry - (cdr entry) - (let ((new (make-element (element-expression element)))) - (set! *elements* (cons (cons element new) *elements*)) - (set-element-cost! new (element-cost element)) - (set-element-in-memory?! new (element-in-memory? element)) - (set-element-next-hash! - new - (element-copy (element-next-hash element))) - (set-element-previous-hash! - new - (element-copy (element-previous-hash element))) - (set-element-next-value! - new - (element-copy (element-next-value element))) - (set-element-previous-value! - new - (element-copy (element-previous-value element))) - (set-element-first-value! - new - (element-copy (element-first-value element))) - new))))) - - (list->vector elements*)))))) \ No newline at end of file diff --git a/v7/src/compiler/rtlopt/rcserq.scm b/v7/src/compiler/rtlopt/rcserq.scm deleted file mode 100644 index 84d960f3f..000000000 --- a/v7/src/compiler/rtlopt/rcserq.scm +++ /dev/null @@ -1,67 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcserq.scm,v 1.1 1987/03/19 00:49:07 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; RTL Common Subexpression Elimination: Register/Quantity Abstractions -;;; Based on the GNU C Compiler - -(declare (usual-integrations)) - -(define quantity-tag (make-vector-tag false 'QUANTITY)) -(define quantity? (tagged-vector-predicate quantity-tag)) -(define-vector-slots quantity 1 number first-register last-register) - -(define *next-quantity-number*) - -(define (generate-quantity-number) - (let ((n *next-quantity-number*)) - (set! *next-quantity-number* (1+ *next-quantity-number*)) - n)) - -(define (make-quantity number first-register last-register) - (vector quantity-tag number first-register last-register)) - -(define (new-quantity register) - (make-quantity (generate-quantity-number) register register)) - -(define (quantity-copy quantity) - (make-quantity (quantity-number quantity) - (quantity-first-register quantity) - (quantity-last-register quantity))) - -(define-register-references quantity) -(define-register-references next-equivalent) -(define-register-references previous-equivalent) -(define-register-references expression) -(define-register-references tick) -(define-register-references in-table) \ No newline at end of file diff --git a/v7/src/compiler/rtlopt/rcsesr.scm b/v7/src/compiler/rtlopt/rcsesr.scm deleted file mode 100644 index 0871bb7e6..000000000 --- a/v7/src/compiler/rtlopt/rcsesr.scm +++ /dev/null @@ -1,84 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcsesr.scm,v 1.1 1987/03/19 00:49:12 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; RTL Common Subexpression Elimination: Stack References -;;; Based on the GNU C Compiler - -(declare (usual-integrations)) - -(define *stack-offset*) -(define *stack-reference-quantities*) - -(define (stack-reference? expression) - (and (eq? (rtl:expression-type expression) 'OFFSET) - (interpreter-stack-pointer? (rtl:address-register expression)))) - -(define (stack-reference-quantity expression) - (let ((n (+ *stack-offset* (rtl:offset-number expression)))) - (let ((entry (ass= n *stack-reference-quantities*))) - (if entry - (cdr entry) - (let ((quantity (new-quantity false))) - (set! *stack-reference-quantities* - (cons (cons n quantity) - *stack-reference-quantities*)) - quantity))))) - -(define-integrable (stack-pointer-adjust! offset) - (set! *stack-offset* (+ (stack->memory-offset offset) *stack-offset*)) - (stack-pointer-invalidate!)) - -(define-integrable (stack-pointer-invalidate!) - (register-expression-invalidate! (interpreter-stack-pointer))) - -(define-integrable (stack-invalidate!) - (set! *stack-reference-quantities* '())) - -(define (stack-region-invalidate! start end) - (let ((end (+ *stack-offset* end))) - (define (loop i quantities) - (if (< i end) - (loop (1+ i) - (del-ass=! i quantities)) - (set! *stack-reference-quantities* quantities))) - (loop (+ *stack-offset* start) *stack-reference-quantities*))) - -(define (stack-reference-invalidate! expression) - (expression-invalidate! expression) - (set! *stack-reference-quantities* - (del-ass=! (+ *stack-offset* (rtl:offset-number expression)) - *stack-reference-quantities*))) - -(define ass= (association-procedure = car)) -(define del-ass=! (delete-association-procedure list-deletor! = car)) \ No newline at end of file diff --git a/v7/src/compiler/rtlopt/rlife.scm b/v7/src/compiler/rtlopt/rlife.scm deleted file mode 100644 index f5cdb0c4b..000000000 --- a/v7/src/compiler/rtlopt/rlife.scm +++ /dev/null @@ -1,277 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rlife.scm,v 1.55 1987/03/19 00:47:19 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; RTL Register Lifetime Analysis -;;; Based on the GNU C Compiler - -(declare (usual-integrations)) - -;;;; Lifetime Analysis - -(define (lifetime-analysis bblocks) - (let ((changed? false)) - (define (loop first-pass?) - (for-each (lambda (bblock) - (let ((live-at-entry (bblock-live-at-entry bblock)) - (live-at-exit (bblock-live-at-exit bblock)) - (new-live-at-exit (bblock-new-live-at-exit bblock))) - (if (or first-pass? - (not (regset=? live-at-exit new-live-at-exit))) - (begin (set! changed? true) - (regset-copy! live-at-exit new-live-at-exit) - (regset-copy! live-at-entry live-at-exit) - (propagate-block bblock) - (for-each-previous-node (bblock-entry bblock) - (lambda (rnode) - (regset-union! (bblock-new-live-at-exit - (node-bblock rnode)) - live-at-entry))))))) - bblocks) - (if changed? - (begin (set! changed? false) - (loop false)) - (for-each (lambda (bblock) - (regset-copy! (bblock-live-at-entry bblock) - (bblock-live-at-exit bblock)) - (propagate-block&delete! bblock)) - bblocks))) - (loop true))) - -(define (propagate-block bblock) - (propagation-loop bblock - (lambda (old dead live rtl rnode) - (update-live-registers! old dead live rtl false)))) - -(define (propagate-block&delete! bblock) - (for-each-regset-member (bblock-live-at-entry bblock) - (lambda (register) - (set-register-bblock! register 'NON-LOCAL))) - (propagation-loop bblock - (lambda (old dead live rtl rnode) - (if (rtl:invocation? rtl) - (for-each-regset-member old register-crosses-call!)) - (if (instruction-dead? rtl old) - (snode-delete! rnode) - (begin (update-live-registers! old dead live rtl rnode) - (for-each-regset-member old - increment-register-live-length!)))))) - -(define (propagation-loop bblock procedure) - (let ((old (bblock-live-at-entry bblock)) - (dead (regset-allocate *n-registers*)) - (live (regset-allocate *n-registers*))) - (bblock-walk-backward bblock - (lambda (rnode previous) - (regset-clear! dead) - (regset-clear! live) - (procedure old dead live (rnode-rtl rnode) rnode))))) - -(define (update-live-registers! old dead live rtl rnode) - (mark-set-registers! old dead rtl rnode) - (mark-used-registers! old live rtl rnode) - (regset-difference! old dead) - (regset-union! old live)) - -(define (instruction-dead? rtl needed) - (and (rtl:assign? rtl) - (let ((address (rtl:assign-address rtl))) - (and (rtl:register? address) - (let ((register (rtl:register-number address))) - (and (pseudo-register? register) - (not (regset-member? needed register)))))))) - -(define (mark-set-registers! needed dead rtl rnode) - ;; **** This code safely ignores PRE-INCREMENT and POST-INCREMENT - ;; modes, since they are only used on the stack pointer. - (if (rtl:assign? rtl) - (let ((address (rtl:assign-address rtl))) - (if (interesting-register? address) - (let ((register (rtl:register-number address))) - (regset-adjoin! dead register) - (if rnode - (let ((rnode* (register-next-use register))) - (record-register-reference register rnode) - (if (and (regset-member? needed register) - rnode* - (eq? (node-bblock rnode) (node-bblock rnode*))) - (set-rnode-logical-link! rnode* rnode))))))))) - -(define (mark-used-registers! needed live rtl rnode) - (define (loop expression) - (if (interesting-register? expression) - (let ((register (rtl:register-number expression))) - (regset-adjoin! live register) - (if rnode - (begin (record-register-reference register rnode) - (set-register-next-use! register rnode) - (if (and (not (regset-member? needed register)) - (not (rnode-dead-register? rnode register))) - (begin (set-rnode-dead-registers! - rnode - (cons register - (rnode-dead-registers rnode))) - (increment-register-n-deaths! register)))))) - (rtl:for-each-subexpression expression loop))) - (if (and (rtl:assign? rtl) - (rtl:register? (rtl:assign-address rtl))) - (if (let ((register (rtl:register-number (rtl:assign-address rtl)))) - (or (machine-register? register) - (regset-member? needed register))) - (loop (rtl:assign-expression rtl))) - (rtl:for-each-subexpression rtl loop))) - -(define (record-register-reference register rnode) - (let ((bblock (node-bblock rnode)) - (bblock* (register-bblock register))) - (cond ((not bblock*) - (set-register-bblock! register bblock)) - ((not (eq? bblock bblock*)) - (set-register-bblock! register 'NON-LOCAL))) - (increment-register-n-refs! register))) - -(define (interesting-register? expression) - (and (rtl:register? expression) - (pseudo-register? (rtl:register-number expression)))) - -;;;; Dead Code Elimination - -(define (dead-code-elimination bblocks) - (for-each (lambda (bblock) - (if (not (eq? (bblock-entry bblock) (bblock-exit bblock))) - (let ((live (regset-copy (bblock-live-at-entry bblock))) - (births (make-regset *n-registers*))) - (bblock-walk-forward bblock - (lambda (rnode next) - (if next - (begin (optimize-rtl live rnode next) - (regset-clear! births) - (mark-set-registers! live - births - (rnode-rtl rnode) - false) - (for-each (lambda (register) - (regset-delete! live register)) - (rnode-dead-registers rnode)) - (regset-union! live births)))))))) - bblocks)) - -(define (optimize-rtl live rnode next) - (let ((rtl (rnode-rtl rnode))) - (if (rtl:assign? rtl) - (let ((address (rtl:assign-address rtl))) - (if (rtl:register? address) - (let ((register (rtl:register-number address))) - (if (and (pseudo-register? register) - (= 2 (register-n-refs register)) - (rnode-dead-register? next register) - (rtl:any-subexpression? (rnode-rtl next) - (lambda (expression) - (and (rtl:register? expression) - (= (rtl:register-number expression) - register))))) - (begin - (let ((dead (rnode-dead-registers rnode))) - (for-each increment-register-live-length! dead) - (set-rnode-dead-registers! - next - (eqv-set-union dead - (delv! register - (rnode-dead-registers next))))) - (for-each-regset-member live - decrement-register-live-length!) - (rtl:modify-subexpressions (rnode-rtl next) - (lambda (expression set-expression!) - (if (and (rtl:register? expression) - (= (rtl:register-number expression) - register)) - (set-expression! (rtl:assign-expression rtl))))) - (snode-delete! rnode) - (reset-register-n-refs! register) - (reset-register-n-deaths! register) - (reset-register-live-length! register) - (set-register-next-use! register false) - (set-register-bblock! register false))))))))) - -;;;; Debugging Output - -(define (dump-register-info) - (for-each-pseudo-register - (lambda (register) - (if (positive? (register-n-refs register)) - (begin (newline) - (write register) - (write-string ": renumber ") - (write (register-renumber register)) - (write-string "; nrefs ") - (write (register-n-refs register)) - (write-string "; length ") - (write (register-live-length register)) - (write-string "; ndeaths ") - (write (register-n-deaths register)) - (let ((bblock (register-bblock register))) - (cond ((eq? bblock 'NON-LOCAL) - (if (register-crosses-call? register) - (write-string "; crosses calls") - (write-string "; multiple blocks"))) - (bblock - (write-string "; block ") - (write (unhash bblock))) - (else - (write-string "; no block!"))))))))) - -(define (dump-block-info bblocks) - (let ((null-set (make-regset *n-registers*)) - (machine-regs (make-regset *n-registers*))) - (for-each-machine-register - (lambda (register) - (regset-adjoin! machine-regs register))) - (for-each (lambda (bblock) - (newline) - (newline) - (write bblock) - (let ((exit (bblock-exit bblock))) - (let loop ((rnode (bblock-entry bblock))) - (pp (rnode-rtl rnode)) - (if (not (eq? rnode exit)) - (loop (snode-next rnode))))) - (let ((live-at-exit (bblock-live-at-exit bblock))) - (regset-difference! live-at-exit machine-regs) - (if (not (regset=? null-set live-at-exit)) - (begin (newline) - (write-string "Registers live at end:") - (for-each-regset-member live-at-exit - (lambda (register) - (write-string " ") - (write register))))))) - (pseudo-register? (rtl:register-number expression)))) \ No newline at end of file diff --git a/v7/src/microcode/array.c b/v7/src/microcode/array.c deleted file mode 100644 index ec3464906..000000000 --- a/v7/src/microcode/array.c +++ /dev/null @@ -1,1153 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/array.c,v 9.21 1987/01/22 14:14:32 jinx Rel $ */ - -/* CONTAINS: */ -/* Scheme_Array constructors, and selectors */ -/* Also procedures for converting between C_Array, and Scheme_Vector */ - -/* See array.h for definition using NM_VECTOR, */ -/* and for many useful EXTERN */ -/* ARRAY = SEQUENCE OF REALS */ - -#include "scheme.h" -#include "primitive.h" -#include "flonum.h" -#include "array.h" -#include - -/* first a useful procedure */ - -int Scheme_Number_To_REAL(Arg, Cell) Pointer Arg; REAL *Cell; -/* 0 means conversion ok, 1 means too big, 2 means not a number */ -{ long Value; - switch (Type_Code(Arg)) { - case TC_FIXNUM: - if (Get_Integer(Arg) == 0) - *Cell = 0.0; - else - { long Value; - Sign_Extend(Arg, Value); - *Cell = ((REAL) Value); - } - break; - case TC_BIG_FLONUM: - *Cell = ((REAL) Get_Float(Arg)); - break; - case TC_BIG_FIXNUM: - { Pointer Result = Big_To_Float(Arg); - if (Type_Code(Result) == TC_BIG_FLONUM) - *Cell = ((REAL) Get_Float(Result)); - else return (1); - } - break; - default: return (2); - break; - } - return (0); -} - -int Scheme_Number_To_Double(Arg, Cell) Pointer Arg; double *Cell; -/* 0 means conversion ok, 1 means too big, 2 means not a number */ -{ long Value; - switch (Type_Code(Arg)) { - case TC_FIXNUM: - if (Get_Integer(Arg) == 0) - *Cell = 0.0; - else - { long Value; - Sign_Extend(Arg, Value); - *Cell = ((double) Value); - } - break; - case TC_BIG_FLONUM: - *Cell = ((double) Get_Float(Arg)); - break; - case TC_BIG_FIXNUM: - { Pointer Result = Big_To_Float(Arg); - if (Type_Code(Result) == TC_BIG_FLONUM) - *Cell = ((double) Get_Float(Result)); - else return (1); - } - break; - default: return (2); - break; - } - return (0); -} - -void C_Array_Copy(From_Array, To_Array, Length) REAL *From_Array, *To_Array; long Length; -{ long i; - REAL *To_Here, *From_Here; - To_Here = To_Array; - From_Here = From_Array; - for (i=0; i < Length; i++) { - *To_Here++ = ((REAL) *From_Here++) ; - } -} - - -/**** Scheme Primitives *****/ - -/* I think this is not needed, can be done at s-code ... -Define_Primitive(Prim_Array_Predicate, 1, "ARRAY?") -{ Primitive_1_Args(); - if (Type_Code(Arg1)==TC_ARRAY) return TRUE; - else return NIL; -} -*/ - -Define_Primitive(Prim_Vector_To_Array, 1, "VECTOR->ARRAY") -{ Pointer Scheme_Vector_To_Scheme_Array(); - Primitive_1_Args(); - Arg_1_Type(TC_VECTOR); - return Scheme_Vector_To_Scheme_Array(Arg1); -} - -Define_Primitive(Prim_Array_To_Vector, 1, "ARRAY->VECTOR") -{ Pointer Scheme_Array_To_Scheme_Vector(); - Primitive_1_Args(); - Arg_1_Type(TC_ARRAY); - return Scheme_Array_To_Scheme_Vector(Arg1); -} - -Define_Primitive(Prim_Array_Cons, 2, "ARRAY-CONS") -{ long Length, i, allocated_cells; - REAL Init_Value, *Next; - int Error_Number; - Pointer Result; - - Primitive_2_Args(); - Arg_1_Type(TC_FIXNUM); - Range_Check(Length, Arg1, 0, ARRAY_MAX_LENGTH, ERR_ARG_1_BAD_RANGE); - - Error_Number = Scheme_Number_To_REAL(Arg2, &Init_Value); - if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE); - if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE); - - Allocate_Array(Result,Length,allocated_cells); - Next = Scheme_Array_To_C_Array(Result); - - for (i=0; i < Length; i++) { - *Next++ = Init_Value; - } - return Result; -} - -Define_Primitive(Prim_Array_Length, 1, "ARRAY-LENGTH") -{ Primitive_1_Args(); - Arg_1_Type(TC_ARRAY); - return Make_Pointer(TC_FIXNUM, Array_Length(Arg1)); -} - -Define_Primitive(Prim_Array_Ref, 2, "ARRAY-REF") -{ long Index; - REAL *Array, value; - Pointer *Result; - Primitive_2_Args(); - Arg_1_Type(TC_ARRAY); - Arg_2_Type(TC_FIXNUM); - Range_Check(Index, Arg2, 0, Array_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE); - Array = Scheme_Array_To_C_Array(Arg1); - value = Array[Index]; - Reduced_Flonum_Result((double) value); -} - -Define_Primitive(Prim_Array_Set, 3, "ARRAY-SET!") -{ long Index; - REAL *Array, Old_Value; - int Error_Number; - - Primitive_3_Args(); - Arg_1_Type(TC_ARRAY); - Arg_2_Type(TC_FIXNUM); - Range_Check(Index, Arg2, 0, Array_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE); - Array = Scheme_Array_To_C_Array(Arg1); - Old_Value = Array[Index]; - - Error_Number = Scheme_Number_To_REAL(Arg3, &Array[Index]); - if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE); - if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE); - - Reduced_Flonum_Result((double) Old_Value); -} - -Define_Primitive(Prim_Array_Copy, 1, "ARRAY-COPY") -{ long Length, i, allocated_cells; - REAL *To_Array, *From_Array; - Pointer Result; - - Primitive_1_Args(); - Arg_1_Type(TC_ARRAY); - Length = Array_Length(Arg1); - - Allocate_Array(Result, Length, allocated_cells); - From_Array = Scheme_Array_To_C_Array(Arg1); - To_Array = Scheme_Array_To_C_Array(Result); - - C_Array_Copy(From_Array, To_Array, Length); - return Result; -} - -Define_Primitive(Prim_SubArray, 3, "SUBARRAY") -{ long Length, i, allocated_cells, Start, End, New_Length; - REAL *To_Here, *From_Here; - Pointer Result; - - Primitive_3_Args(); - Arg_1_Type(TC_ARRAY); - Arg_2_Type(TC_FIXNUM); - Arg_3_Type(TC_FIXNUM); - Length = Array_Length(Arg1); - Range_Check(Start, Arg2, 0, Array_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE); - Range_Check(End, Arg3, 0, Array_Length(Arg1)-1, ERR_ARG_3_BAD_RANGE); - if (Start>End) Primitive_Error(ERR_ARG_3_BAD_RANGE); - - New_Length = (End - Start) + 1; - Allocate_Array(Result, New_Length, allocated_cells); - From_Here = Nth_Array_Loc(Arg1, Start); - To_Here = Scheme_Array_To_C_Array(Result); - - C_Array_Copy(From_Here, To_Here, New_Length); - return Result; -} - -Define_Primitive(Prim_Array_Set_SubArray, 4, "ARRAY-SET-SUBARRAY!") -{ long Length, i, Start, End, New_Length; - REAL *To_Here, *From_Here; - Pointer Result; - - Primitive_4_Args(); - Arg_1_Type(TC_ARRAY); - Arg_2_Type(TC_FIXNUM); - Arg_3_Type(TC_FIXNUM); - Arg_4_Type(TC_ARRAY); - Length = Array_Length(Arg1); - Range_Check(Start, Arg2, 0, Array_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE); - Range_Check(End, Arg3, 0, Array_Length(Arg1)-1, ERR_ARG_3_BAD_RANGE); - if (Start>End) Primitive_Error(ERR_ARG_3_BAD_RANGE); - - New_Length = (End - Start) + 1; - if (New_Length!=Array_Length(Arg4)) Primitive_Error(ERR_ARG_4_BAD_RANGE); - From_Here = Scheme_Array_To_C_Array(Arg4); - To_Here = Nth_Array_Loc(Arg1, Start); - - C_Array_Copy(From_Here, To_Here, New_Length); - return Arg1; -} - -Define_Primitive(Prim_Array_Append, 2, "ARRAY-APPEND") -{ long Length, Length1, Length2, i, allocated_cells; - REAL *To_Here, *From_Here; - Pointer Result; - - Primitive_2_Args(); - Arg_1_Type(TC_ARRAY); - Arg_2_Type(TC_ARRAY); - Length1 = Array_Length(Arg1); - Length2 = Array_Length(Arg2); - Length = Length1 + Length2; - - Allocate_Array(Result, Length, allocated_cells); - To_Here = Scheme_Array_To_C_Array(Result); - From_Here = Scheme_Array_To_C_Array(Arg1); - - for (i=0; i < Length1; i++) { - *To_Here++ = *From_Here; - From_Here++ ; - } - - From_Here = Scheme_Array_To_C_Array(Arg2); - for (i=0; i < Length2; i++) { - *To_Here++ = *From_Here; - From_Here++ ; - } - - return Result; -} - -Define_Primitive(Prim_Array_Reverse, 1, "ARRAY-REVERSE!") -{ long Length, i,j, Half_Length; - REAL *Array, Temp; - Primitive_1_Args(); - Arg_1_Type(TC_ARRAY); - Length = Array_Length(Arg1); - Half_Length = Length/2; - Array = Scheme_Array_To_C_Array(Arg1); - - for (i=0, j=Length-1; i0) - { - do { - if(*x < xmin) { - nnmin = count++ ; - xmin = *x++ ; - } else if(*x > xmax) { - nnmax = count++ ; - xmax = *x++ ; - } else { - count++ ; - x++ ; - } - } while( --n > 0 ) ; - } - *nmin = nnmin ; - *nmax = nnmax ; -} - -Define_Primitive(Prim_Array_Find_Average, 1, "ARRAY-AVERAGE") -{ long Length; REAL average; - Primitive_1_Args(); - Arg_1_Type(TC_ARRAY); - Length = Array_Length(Arg1); - - C_Array_Find_Average( Scheme_Array_To_C_Array(Arg1), Length, &average); - Reduced_Flonum_Result((double) average); -} - -void C_Array_Find_Average(Array, Length, pAverage) - long Length; REAL *Array, *pAverage; -{ long i; - long array_index; - REAL average_n, sum; - - average_n = 0.0; - array_index = 0; - while (array_indexxmax) Primitive_Error(ERR_ARG_3_BAD_RANGE); - - for (i=0; i < Length; i++) { - if ((*From_Here)xmax) *To_Here++ = xmax; - else *To_Here++ = *From_Here; - From_Here++ ; - } - return Result; -} - -void C_Array_Clip(Length, From_Here, To_Here, Min_Val, Max_Val) - long Length; REAL *From_Here, *To_Here, Min_Val, Max_Val; -{ long i; - for (i=0; i < Length; i++) { - if ((*From_Here)Max_Val) *To_Here++ = Max_Val; - else *To_Here++ = *From_Here; - From_Here++ ; - } -} - - -Define_Primitive(Prim_Array_Make_Polar, 2, "ARRAY-MAKE-POLAR!") -{ long Length, i; - REAL *To_Here_Mag, *To_Here_Phase; - REAL *From_Here_Real, *From_Here_Imag; - Pointer Result_Mag, Result_Phase, answer; - - Primitive_2_Args(); - Arg_1_Type(TC_ARRAY); - Arg_2_Type(TC_ARRAY); - Length = Array_Length(Arg1); - if (Length != Array_Length(Arg2)) Primitive_Error(ERR_ARG_1_BAD_RANGE); - - Result_Mag = Arg1; - Result_Phase = Arg2; - - From_Here_Real = Scheme_Array_To_C_Array(Arg1); - From_Here_Imag = Scheme_Array_To_C_Array(Arg2); - To_Here_Mag = Scheme_Array_To_C_Array(Result_Mag); - To_Here_Phase = Scheme_Array_To_C_Array(Result_Phase); - - for (i=0; i < Length; i++) { - C_Make_Polar(*From_Here_Real, *From_Here_Imag, *To_Here_Mag, *To_Here_Phase); - From_Here_Real++ ; - From_Here_Imag++ ; - To_Here_Mag++ ; - To_Here_Phase++ ; - } - - Primitive_GC_If_Needed(4); - answer = Make_Pointer(TC_LIST, Free); - *Free++ = Result_Mag; - *Free = Make_Pointer(TC_LIST, Free+1); - Free += 1; - *Free++ = Result_Phase; - *Free++ = NIL; - return answer; -} - -Define_Primitive(Prim_Array_Find_Magnitude, 2, "ARRAY-FIND-MAGNITUDE") -{ long Length, i, allocated_cells; - REAL *From_Here_Real, *From_Here_Imag, *To_Here; - Pointer Result; - - Primitive_2_Args(); - Arg_1_Type(TC_ARRAY); - Arg_2_Type(TC_ARRAY); - Length = Array_Length(Arg1); - if (Length != Array_Length(Arg2)) Primitive_Error(ERR_ARG_1_BAD_RANGE); - - Allocate_Array(Result, Length, allocated_cells); - To_Here = Scheme_Array_To_C_Array(Result); - From_Here_Real = Scheme_Array_To_C_Array(Arg1); - From_Here_Imag = Scheme_Array_To_C_Array(Arg2); - for (i=0; i0.0)) return(.08 + .46 * (1 - t_bar)); - else return (0); -} - -double hanning(t, length) double t, length; -{ double twopi = 6.28318530717958; - double pi = twopi/2.; - double t_bar = cos(twopi * (t / length)); - if ((t0.0)) return(.5 * (1 - t_bar)); - else return (0); -} - -double unit_square_wave(t) double t; -{ double twopi = 6.28318530717958; - double fmod(), fabs(); - double pi = twopi/2.; - double t_bar = ((REAL) fabs(fmod( ((double) t), twopi))); - if (t_bar < pi) return(1); - else return(-1); -} - -double unit_triangle_wave(t) double t; -{ double twopi = 6.28318530717958; - double pi = twopi/2.; - double pi_half = pi/2.; - double three_pi_half = pi+pi_half; - double t_bar = ((double) fabs(fmod( ((double) t), twopi))); - - if (t_bar fabs(*(a+m+(k-1)*n-1))) - m = i; - *(pvt+k-1) = m; - if (m != k) - *(pvt+n-1) = - *(pvt+n-1); - p = *(a+m+(k-1)*n-1); - *(a+m+(k-1)*n-1) = *(a+k+(k-1)*n-1); - *(a+k+(k-1)*n-1) = p; - if (p != 0.0) { - for (i=k+1; i<=n; i++) - *(a+i+(k-1)*n-1) = - *(a+i+(k-1)*n-1) / p; - for (j=k+1; j<=n; j++) { - t = *(a+m+(j-1)*n-1); - *(a+m+(j-1)*n-1) = *(a+k+(j-1)*n-1); - *(a+k+(j-1)*n-1) = t; - if (t != 0.0) - for (i=k+1; i<=n; i++) - *(a+i+(j-1)*n-1) = *(a+i+(j-1)*n-1) + *(a+i+(k-1)*n-1) * t; - } - } - } - for (k=1; kHigh)) Primitive_Error(Error_Message); \ - variable = ((float) value); \ -} - -#define REAL_Range_Check(variable, Scheme_Pointer, Low, High, Error_Message) \ -{ REAL value; \ - int err; \ - err = Scheme_Number_To_REAL(Scheme_Pointer, &value); \ - if ((err == 1) || (err == 2)) Primitive_Error(Error_Message); \ - if ((valueHigh)) Primitive_Error(Error_Message); \ - else variable = value; \ -} - -#define C_Make_Polar(Real, Imag, Mag_Cell, Phase_Cell) \ -{ double double_Real=((double) Real), double_Imag=((double) Imag); \ - Mag_Cell = (REAL) sqrt((double_Real*double_Real)+(double_Imag*double_Imag)); \ - Phase_Cell = (REAL) atan2(double_Imag, double_Real); \ -} -/* atan has no problem with division by zero */ - -#define Linear_Map(slope,offset,From,To) { (To) = (((slope)*(From))+offset); } - -#define C_Find_Magnitude(Real, Imag, Mag_Cell) \ -{ double double_Real=((double) Real), double_Imag=((double) Imag); \ - Mag_Cell = (REAL) sqrt((double_Real*double_Real)+(double_Imag*double_Imag)); \ -} - -#define mabs(x) (((x)<0) ? -(x) : (x)) -#define max(x,y) (((x)<(y)) ? (y) : (x)) -#define min(x,y) (((x)<(y)) ? (x) : (y)) - - -/* FROM ARRAY.C */ -extern int Scheme_Number_To_REAL(); -extern int Scheme_Number_To_Double(); -extern void C_Array_Copy(); /* REAL *From_Array,*To_Array; long Length; */ - -extern void C_Array_Find_Min_Max(); /* Find the index of the minimum (*nmin), maximum (*nmax). */ -extern void C_Array_Find_Average(); -extern void C_Array_Make_Histogram(); /* REAL *Array,*Histogram; long Length,npoints */ - - -/* DATATYPE CONVERSIONS */ - -/* macro: REAL *Scheme_Array_To_C_Array(); */ -extern Pointer C_Array_To_Scheme_Array(); -/* there is also a macro: Allocate_Array(Result,Length,allocated_cells); - */ - -extern Pointer Scheme_Vector_To_Scheme_Array(); -extern Pointer Scheme_Array_To_Scheme_Vector(); - -extern Pointer C_Array_To_Scheme_Vector(); -extern void Scheme_Vector_To_C_Array(); -/* Pointer Scheme_Vector; REAL *Array; - */ - - -/* FROM BOB-XT.C */ -extern void Find_Offset_Scale_For_Linear_Map(); /* REAL Min,Max, New_Min,New_Max, *Offset,*Scale; */ - - -#define My_Store_Flonum_Result(Ans, Value_Cell) \ - (Value_Cell) = (Allocate_Float( ((double) Ans))); - -#define My_Store_Reduced_Flonum_Result(Ans, Value_Cell) \ -{ double Number = ((double) Ans); \ - double floor(); \ - Pointer result; \ - if (floor(Number) != Number) \ - { My_Store_Flonum_Result(Number, Value_Cell); \ - } \ - else if (Number == 0) \ - (Value_Cell) = Make_Unsigned_Fixnum(0); \ - if ((floor(Number) == Number) && (Number != 0)) \ - { int exponent; \ - double frexp(); \ - frexp(Number, &exponent); \ - if (exponent <= FIXNUM_LENGTH) \ - { double_into_fixnum(Number, result); \ - (Value_Cell) = result; \ - } \ - /* Since the float has no fraction, we will not gain \ - precision if its mantissa has enough bits to support \ - the exponent. */ \ - else if (exponent <= FLONUM_MANTISSA_BITS) \ - { result = Float_To_Big(Number); \ - (Value_Cell) = result; \ - } \ - else if (Number != 0) \ - { My_Store_Flonum_Result( (Ans), (Value_Cell)); \ - } \ - } \ -} diff --git a/v7/src/microcode/bchdmp.c b/v7/src/microcode/bchdmp.c deleted file mode 100644 index 7696af558..000000000 --- a/v7/src/microcode/bchdmp.c +++ /dev/null @@ -1,102 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchdmp.c,v 9.28 1987/04/16 14:35:15 jinx Exp $ */ - -/* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag, - purify, and fasdump, respectively, to provide garbage collection - and related utilities to disk. -*/ - -#include "scheme.h" -#include "primitive.h" -#define In_Fasdump -#include "bchgcc.h" -#include "dump.c" - -extern Pointer Make_Prim_Exts(); - -/* (PRIMITIVE-FASDUMP object-to-dump file-name flag) - Not implemented yet. -*/ - -Built_In_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP", 0x56) -{ - Primitive_3_Args(); - - Primitive_Error(ERR_UNIMPLEMENTED_PRIMITIVE); - /*NOTREACHED*/ -} - -/* (DUMP-BAND PROCEDURE FILE-NAME) - Saves all of the heap and pure space on FILE-NAME. When the - file is loaded back using BAND_LOAD, PROCEDURE is called with an - argument of NIL. -*/ -Built_In_Primitive(Prim_Band_Dump, 2, "DUMP-BAND", 0xB7) -{ - Pointer Combination, Ext_Prims; - long Arg1Type; - Primitive_2_Args(); - - Band_Dump_Permitted(); - Arg1Type = Type_Code(Arg1); - if ((Arg1Type != TC_CONTROL_POINT) && - (Arg1Type != TC_PRIMITIVE) && - (Arg1Type != TC_PRIMITIVE_EXTERNAL) && - (Arg1Type != TC_EXTENDED_PROCEDURE)) Arg_1_Type(TC_PROCEDURE); - Arg_2_Type(TC_CHARACTER_STRING); - if (!Open_Dump_File(Arg2, WRITE_FLAG)) - Primitive_Error(ERR_ARG_2_BAD_RANGE); - /* Free cannot be saved around this code since Make_Prim_Exts will - intern the undefined externals and potentially allocate space. - */ - Ext_Prims = Make_Prim_Exts(); - Combination = Make_Pointer(TC_COMBINATION_1, Free); - Free[COMB_1_FN] = Arg1; - Free[COMB_1_ARG_1] = NIL; - Free += 2; - *Free++ = Combination; - *Free++ = return_to_interpreter; - *Free = Make_Pointer(TC_LIST, Free-2); - Free++; /* Some compilers are TOO clever about this and increment Free - before calculating Free-2! */ - *Free++ = Ext_Prims; - /* Aligning here confuses some of the counts computed. - Align_Float(Free); - */ - Write_File(((long) (Free-Heap_Bottom)), Heap_Bottom, Free-2, - ((long) (Free_Constant-Constant_Space)), - Constant_Space, Free-1); - fclose(File_Handle); - return TRUTH; -} diff --git a/v7/src/microcode/bchgcc.h b/v7/src/microcode/bchgcc.h deleted file mode 100644 index f916712b4..000000000 --- a/v7/src/microcode/bchgcc.h +++ /dev/null @@ -1,53 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcc.h,v 9.26 1987/02/12 01:17:47 jinx Exp $ */ - -#include "gccode.h" - -/* All of these are in objects (Pointer), not bytes. */ - -#define GC_EXTRA_BUFFER_SIZE 512 -#define GC_DISK_BUFFER_SIZE 4096 -#define GC_BUFFER_SPACE (GC_DISK_BUFFER_SIZE + GC_EXTRA_BUFFER_SIZE) -#define GC_BUFFER_BYTES (GC_DISK_BUFFER_SIZE * sizeof(Pointer)) - -#define GC_FILE_MASK 0644 /* Everyone reads, owner writes */ -#define GC_DEFAULT_FILE_NAME "/tmp/GCXXXXXX" - -extern Pointer *scan_buffer_top; -extern Pointer *free_buffer_top; -extern Pointer *dump_and_reload_scan_buffer(); -extern Pointer *dump_and_reset_free_buffer(); -extern void dump_free_directly(); - -extern Pointer *GCLoop(); diff --git a/v7/src/microcode/bchgcl.c b/v7/src/microcode/bchgcl.c deleted file mode 100644 index a7b0c2226..000000000 --- a/v7/src/microcode/bchgcl.c +++ /dev/null @@ -1,251 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcl.c,v 9.28 1987/04/16 02:06:42 jinx Exp $ */ - -/* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag, - purify, and fasdump, respectively, to provide garbage collection - and related utilities to disk. -*/ - -#include "scheme.h" -#include "bchgcc.h" - -/* Some utility macros */ - -#define copy_cell() \ -{ *To++ = *Old; \ -} - -#define copy_pair() \ -{ *To++ = *Old++; \ - *To++ = *Old; \ -} - -#define copy_weak_pair() \ -{ long Car_Type; \ - \ - Car_Type = Type_Code(*Old); \ - *To++ = Make_New_Pointer(TC_NULL, *Old); \ - Old += 1; \ - *To++ = *Old; \ - *Old = Make_New_Pointer(Car_Type, Weak_Chain); \ - Weak_Chain = Temp; \ -} - -#define copy_triple() \ -{ *To++ = *Old++; \ - *To++ = *Old++; \ - *To++ = *Old; \ -} - -#define copy_quadruple() \ -{ *To++ = *Old++; \ - *To++ = *Old++; \ - *To++ = *Old++; \ - *To++ = *Old; \ -} - -/* Transporting vectors is done in 3 parts: - - Finish filling the current free buffer, dump it, and get a new one. - - Dump the middle of the vector directly by bufferfulls. - - Copy the end of the vector to the new buffer. - The last piece of code is the only one executed when the vector does - not overflow the current buffer. -*/ - -#define copy_vector() \ -{ Pointer *Saved_Scan = Scan; \ - unsigned long real_length = 1 + Get_Integer(*Old); \ - \ - To_Address += real_length; \ - Scan = To + real_length; \ - if (Scan >= free_buffer_top) \ - { unsigned long overflow; \ - \ - overflow = Scan - free_buffer_top; \ - while (To != free_buffer_top) *To++ = *Old++; \ - To = dump_and_reset_free_buffer(0); \ - real_length = (overflow / GC_DISK_BUFFER_SIZE); \ - if (real_length > 0) dump_free_directly(Old, real_length); \ - Old += (real_length * GC_DISK_BUFFER_SIZE); \ - Scan = To + (overflow % GC_DISK_BUFFER_SIZE); \ - } \ - while (To != Scan) *To++ = *Old++; \ - Scan = Saved_Scan; \ -} - -#define relocate_normal_setup() \ -{ \ - Old = Get_Pointer(Temp); \ - if (Old >= Low_Constant) continue; \ - if (Type_Code(*Old) == TC_BROKEN_HEART) \ - { *Scan = Make_New_Pointer(Type_Code(Temp), *Old); \ - continue; \ - } \ - New_Address = Make_Broken_Heart(C_To_Scheme(To_Address)); \ -} - -#define relocate_normal_transport(copy_code, length) \ -{ copy_code; \ - To_Address += (length); \ - if (To >= free_buffer_top) \ - To = dump_and_reset_free_buffer(To - free_buffer_top); \ -} - -#define relocate_normal_end() \ -{ *Get_Pointer(Temp) = New_Address; \ - *Scan = Make_New_Pointer(Type_Code(Temp), New_Address); \ - continue; \ -} - -#define relocate_normal_pointer(copy_code, length) \ -{ relocate_normal_setup(); \ - relocate_normal_transport(copy_code, length); \ - relocate_normal_end(); \ -} - -Pointer -*GCLoop(Scan, To_ptr, To_Address_ptr) -fast Pointer *Scan; -Pointer **To_ptr, **To_Address_ptr; -{ fast Pointer *To, *Old, Temp, *Low_Constant, *To_Address, New_Address; - - To = *To_ptr; - To_Address = *To_Address_ptr; - Low_Constant = Constant_Space; - - for ( ; Scan != To; Scan++) - { Temp = *Scan; - Switch_by_GC_Type(Temp) - { case TC_BROKEN_HEART: - if (Scan != (Get_Pointer(Temp))) - { fprintf(stderr, "GC: Broken heart in scan.\n"); - Microcode_Termination(TERM_BROKEN_HEART); - } - if (Scan != scan_buffer_top) goto end_gcloop; - /* The -1 is here because of the Scan++ in the for header. */ - Scan = dump_and_reload_scan_buffer(0) - 1; - continue; - - case TC_MANIFEST_NM_VECTOR: - case TC_MANIFEST_SPECIAL_NM_VECTOR: - /* Check whether this bumps over current buffer, - and if so we need a new bufferfull. */ - Scan += Get_Integer(Temp); - if (Scan < scan_buffer_top) - break; - else - { unsigned long overflow; - /* The + & -1 are here because of the Scan++ in the for header. */ - overflow = (Scan - scan_buffer_top) + 1; - Scan = ((dump_and_reload_scan_buffer(overflow / GC_DISK_BUFFER_SIZE) + - (overflow % GC_DISK_BUFFER_SIZE)) - 1); - break; - } - - case_Non_Pointer: - break; - - case_compiled_entry_point: - Old = Get_Pointer(Temp); - if (Old >= Low_Constant) continue; - Old = Get_Compiled_Block(Old); - if (Type_Code(*Old) == TC_BROKEN_HEART) - { *Scan = Relocate_Compiled(Temp, Get_Pointer(*Old), Old); - continue; - } - else - { Pointer *Saved_Old = Old; - New_Address = Make_Broken_Heart(C_To_Scheme(To_Address)); - copy_vector(); - *Saved_Old = New_Address; - *Scan = Relocate_Compiled(Temp, Get_Pointer(New_Address), Saved_Old); - continue; - } - - case_Cell: - relocate_normal_pointer(copy_cell(), 1); - - case TC_REFERENCE_TRAP: - if (Datum(Temp) <= TRAP_MAX_IMMEDIATE) - { - /* It is a non pointer. */ - break; - } - /* It is a pair, fall through. */ - case_Pair: - relocate_normal_pointer(copy_pair(), 2); - - case TC_VARIABLE: - case_Triple: - relocate_normal_pointer(copy_triple(), 3); - - case_Quadruple: - relocate_normal_pointer(copy_quadruple(), 4); - -#ifdef FLOATING_ALIGNMENT - case TC_BIG_FLONUM: - /* This must be fixed. */ -#include "error: bchgcl does not handle floating alignment." -#else - case TC_BIG_FLONUM: - /* Fall through */ -#endif - case_Vector: - relocate_normal_setup(); - Move_Vector: - copy_vector(); - relocate_normal_end(); - - case TC_FUTURE: - relocate_normal_setup(); - if (!(Future_Spliceable(Temp))) goto Move_Vector; - *Scan = Future_Value(Temp); - Scan -= 1; - continue; - - case TC_WEAK_CONS: - relocate_normal_pointer(copy_weak_pair(), 2); - - default: - fprintf(stderr, - "GCLoop: Bad type code = 0x%02x\n", - Type_Code(Temp)); - Invalid_Type_Code(); - } - } -end_gcloop: - *To_ptr = To; - *To_Address_ptr = To_Address; - return Scan; -} diff --git a/v7/src/microcode/bchmmg.c b/v7/src/microcode/bchmmg.c deleted file mode 100644 index 03c6e869e..000000000 --- a/v7/src/microcode/bchmmg.c +++ /dev/null @@ -1,677 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.28 1987/04/16 02:06:52 jinx Exp $ */ - -/* Memory management top level. Garbage collection to disk. - - The algorithm is basically the same as for the 2 space collector, - except that new space is on the disk, and there are two windows to - it (the scan and free buffers). For information on the 2 space - collector, read the comments in the replaced files. - - The memory management code is spread over 3 files: - - bchmmg.c: initialization and top level. Replaces memmag.c - - bchgcl.c: main garbage collector loop. Replaces gcloop.c - - bchpur.c: constant/pure space hacking. Replaces purify.c - - bchdmp.c: object world image dumping. Replaces fasdump.c - - Problems with this implementation right now: - - It only works on Unix (or systems which support Unix i/o calls). - - Purify is not implemented. - - Fasdump is not implemented. - - Floating alignment is not implemented. - - Dumpworld will not work because the file is not closed at dump time. - - Command line supplied gc files are not locked, so two processes can try - to share them. - - Compiled code handling in bchgcl is not generic, may only work for 68k - family processors. -*/ - -#include "scheme.h" -#include "primitive.h" -#include "bchgcc.h" -#include - -/* Exports */ - -extern void Clear_Memory(), Setup_Memory(), Reset_Memory(); - -/* Memory Allocation, sequential processor, - garbage collection to disk version: - - ------------------------------------------ - | GC Buffer Space | - | | - ------------------------------------------ - | Control Stack || | - | \/ | - ------------------------------------------ - | Constant + Pure Space /\ | - | || | - ------------------------------------------ - | Heap Space | - | | - ------------------------------------------ - - Each area has a pointer to its starting address and a pointer to - the next free cell. The GC buffer space contains two equal size - buffers used during the garbage collection process. Usually one is - the scan buffer and the other is the free buffer, and they are - dumped and loaded from disk as necessary. Sometimes during the - garbage collection (especially at the beginning and at the end) - both buffers are identical, since transporting will occur into the - area being scanned. -*/ - -/* Local declarations */ - -static long scan_position, free_position; -static Pointer *gc_disk_buffer_1, *gc_disk_buffer_2; -Pointer *scan_buffer_top, *scan_buffer_bottom, *scan_buffer; -Pointer *free_buffer_top, *free_buffer_bottom, *free_buffer; - -/* Hacking the gc file */ - -extern char *mktemp(); - -static int gc_file; -static char *gc_file_name; -static char gc_default_file_name[FILE_NAME_LENGTH] = GC_DEFAULT_FILE_NAME; - -void -open_gc_file() -{ - int position; - int flags; - - (void) mktemp(gc_default_file_name); - flags = (O_RDWR | O_CREAT | O_SYNCIO); - - position = Parse_Option("-gcfile", Saved_argc, Saved_argv, true); - if ((position != NOT_THERE) && - (position != (Saved_argc - 1))) - { - gc_file_name = Saved_argv[position + 1]; - } - else - { - gc_file_name = gc_default_file_name; - flags |= O_EXCL; - } - - while(true) - { - gc_file = open(gc_file_name, flags, GC_FILE_MASK); - if (gc_file != -1) - break; - if (gc_file_name != gc_default_file_name) - { - fprintf(stderr, - "%s: GC file \"%s\" cannot be opened; ", - Saved_argv[0]), gc_file_name; - gc_file_name = gc_default_file_name; - fprintf(stderr, - "Using \"%s\" instead.\n", - gc_file_name); - flags |= O_EXCL; - continue; - } - fprintf(stderr, - "%s: GC file \"%s\" cannot be opened; ", - Saved_argv[0]), gc_file_name; - fprintf(stderr, "Aborting.\n"); - exit(1); - } - return; -} - -void -close_gc_file() -{ - if (close(gc_file) == -1) - fprintf(stderr, - "%s: Problems closing GC file \"%s\".\n", - Saved_argv[0], gc_file_name); - if (gc_file_name == gc_default_file_name) - unlink(gc_file_name); - return; -} - -void -Clear_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size) - int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size; -{ - Heap_Top = Heap_Bottom + Our_Heap_Size; - Set_Mem_Top(Heap_Top - GC_Reserve); - Free = Heap_Bottom; - Free_Constant = Constant_Space; - Set_Pure_Top(); - Initialize_Stack(); - return; -} - -void -Setup_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size) - int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size; -{ - int Real_Stack_Size; - - Real_Stack_Size = Stack_Allocation_Size(Our_Stack_Size); - - /* Consistency check 1 */ - if (Our_Heap_Size == 0) - { - fprintf(stderr, "Configuration won't hold initial data.\n"); - exit(1); - } - - /* Allocate. - The two GC buffers are not included in the valid Scheme memory. - */ - Highest_Allocated_Address = - Allocate_Heap_Space(Real_Stack_Size + Our_Heap_Size + - Our_Constant_Size + (2 * GC_BUFFER_SPACE) + - HEAP_BUFFER_SPACE); - - /* Consistency check 2 */ - if (Heap == NULL) - { - fprintf(stderr, "Not enough memory for this configuration.\n"); - exit(1); - } - - /* Trim the system buffer space. */ - - Highest_Allocated_Address -= (2 * GC_BUFFER_SPACE); - Heap += HEAP_BUFFER_SPACE; - Initial_Align_Float(Heap); - - Constant_Space = Heap + Our_Heap_Size; - gc_disk_buffer_1 = Constant_Space + Our_Constant_Size + Real_Stack_Size; - gc_disk_buffer_2 = (gc_disk_buffer_1 + GC_BUFFER_SPACE); - - /* Consistency check 3 */ - if (((C_To_Scheme(Highest_Allocated_Address)) & TYPE_CODE_MASK) != 0) - { - fprintf(stderr, - "Largest address does not fit in datum field of Pointer.\n"); - fprintf(stderr, - "Allocate less space or re-compile without Heap_In_Low_Memory.\n"); - exit(1); - } - - Heap_Bottom = Heap; - Clear_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size); - - open_gc_file(); - return; -} - -void -Reset_Memory() -{ - close_gc_file(); - return; -} - -void -dump_buffer(from, position, nbuffers, name) - Pointer *from; - long *position, nbuffers; - char *name; -{ - long bytes_written; - - if (lseek(gc_file, *position, 0) == -1) - { - fprintf(stderr, - "\nCould not position GC file to write the %s buffer.\n", - name); - Microcode_Termination(TERM_EXIT); - /*NOTREACHED*/ - } - if ((bytes_written = write(gc_file, from, (nbuffers * GC_BUFFER_BYTES))) == - -1) - { - fprintf(stderr, "\nCould not write out the %s buffer.\n", name); - Microcode_Termination(TERM_EXIT); - /*NOTREACHED*/ - } - - *position += bytes_written; - return; -} - -void -load_buffer(position, to, nbytes, name) - long position; - Pointer *to; - long nbytes; - char *name; -{ - long bytes_read; - - if (lseek(gc_file, position, 0) == -1) - { - fprintf(stderr, "\nCould not position GC file to read %s.\n", name); - Microcode_Termination(TERM_EXIT); - /*NOTREACHED*/ - } - if ((bytes_read = read(gc_file, to, nbytes)) != nbytes) - { - fprintf(stderr, "\nCould not read into %s.\n", name); - Microcode_Termination(TERM_EXIT); - /*NOTREACHED*/ - } - return; -} - -void -reload_scan_buffer() -{ - if (scan_position == free_position) - { - scan_buffer_bottom = free_buffer_bottom; - scan_buffer_top = free_buffer_top; - scan_buffer = scan_buffer_bottom; - return; - } - scan_buffer_bottom = ((free_buffer_bottom == gc_disk_buffer_1) ? - gc_disk_buffer_2 : - gc_disk_buffer_1); - load_buffer(scan_position, scan_buffer_bottom, - GC_BUFFER_BYTES, "the scan buffer"); - scan_buffer_top = scan_buffer_bottom + GC_DISK_BUFFER_SIZE; - *scan_buffer_top = Make_Pointer(TC_BROKEN_HEART, scan_buffer_top); - return; -} - -void -initialize_scan_buffer() -{ - scan_position = 0; - reload_scan_buffer(); - scan_buffer = scan_buffer_bottom; - return; -} - -/* This hacks the scan buffer also so that Scan is always below - scan_buffer_top until the scan buffer is initialized. -*/ -void -initialize_free_buffer() -{ - free_position = 0; - free_buffer_bottom = gc_disk_buffer_1; - free_buffer_top = free_buffer_bottom + GC_DISK_BUFFER_SIZE; - free_buffer = free_buffer_bottom; - scan_position = -1; - scan_buffer_bottom = gc_disk_buffer_2; - scan_buffer_top = scan_buffer_bottom + GC_DISK_BUFFER_SIZE; - return; -} - -Pointer * -dump_and_reload_scan_buffer(number_to_skip) - long number_to_skip; -{ - dump_buffer(scan_buffer_bottom, &scan_position, 1, "scan"); - if (number_to_skip != 0) - scan_position += (number_to_skip * GC_BUFFER_BYTES); - reload_scan_buffer(); - return scan_buffer_bottom; -} - -Pointer * -dump_and_reset_free_buffer(overflow) - fast long overflow; -{ - fast Pointer *into, *from; - - from = free_buffer_top; - if (free_buffer_bottom == scan_buffer_bottom) - { - /* No need to dump now, it will be dumped when scan is dumped. - Does this work? - We may need to dump the buffer anyway so we can dump the next one. - It may not be possible to lseek past the end of file. - */ - free_position += GC_BUFFER_BYTES; - free_buffer_bottom = ((scan_buffer_bottom == gc_disk_buffer_1) ? - gc_disk_buffer_2 : - gc_disk_buffer_1); - free_buffer_top = free_buffer_bottom + GC_DISK_BUFFER_SIZE; - } - else - dump_buffer(free_buffer_bottom, &free_position, 1, "free"); - - for (into = free_buffer_bottom; --overflow >= 0; ) - *into++ = *from++; - - /* This only needs to be done when they were the same buffer, - but it does not hurt. - */ - *scan_buffer_top = Make_Pointer(TC_BROKEN_HEART, scan_buffer_top); - - return into; -} - -void -dump_free_directly(from, nbuffers) - Pointer *from; - long nbuffers; -{ - dump_buffer(from, &free_position, nbuffers, "free"); - return; -} - -static long current_buffer_position; - -void -initialize_new_space_buffer() -{ - current_buffer_position = -1; - return; -} - -void -flush_new_space_buffer() -{ - if (current_buffer_position == -1) - return; - dump_buffer(gc_disk_buffer_1, ¤t_buffer_position, - 1, "weak pair buffer"); - current_buffer_position = -1; - return; -} - -Pointer * -guarantee_in_memory(addr) - Pointer *addr; -{ - long position, offset; - - position = (addr - Heap_Bottom); - offset = (position % GC_DISK_BUFFER_SIZE); - position = (position / GC_DISK_BUFFER_SIZE); - position *= GC_BUFFER_BYTES; - if (position != current_buffer_position) - { - flush_new_space_buffer(); - load_buffer(position, gc_disk_buffer_1, - GC_BUFFER_BYTES, "the weak pair buffer"); - current_buffer_position = position; - } - return &gc_disk_buffer_1[offset]; -} - -/* For a description of the algorithm, see memmag.c. - This has been modified only to account for the fact that new space - is on disk. Old space is in memory. -*/ - -Pointer Weak_Chain; - -void -Fix_Weak_Chain() -{ - fast Pointer *Old_Weak_Cell, *Scan, Old_Car, Temp, *Old, *Low_Constant; - - initialize_new_space_buffer(); - Low_Constant = Constant_Space; - while (Weak_Chain != NIL) - { - Old_Weak_Cell = Get_Pointer(Weak_Chain); - Scan = guarantee_in_memory(Get_Pointer(*Old_Weak_Cell++)); - Weak_Chain = *Old_Weak_Cell; - Old_Car = *Scan; - Temp = Make_New_Pointer(Type_Code(Weak_Chain), Old_Car); - Weak_Chain = Make_New_Pointer(TC_NULL, Weak_Chain); - - switch(GC_Type(Temp)) - { case GC_Non_Pointer: - *Scan = Temp; - continue; - - case GC_Special: - if (Type_Code(Temp) != TC_REFERENCE_TRAP) - { - /* No other special type makes sense here. */ - goto fail; - } - if (Datum(Temp) <= TRAP_MAX_IMMEDIATE) - { - *Scan = Temp; - continue; - } - /* Otherwise, it is a pointer. Fall through */ - - /* Normal pointer types, the broken heart is in the first word. - Note that most special types are treated normally here. - The BH code updates *Scan if the object has been relocated. - Otherwise it falls through and we replace it with a full NIL. - Eliminating this assignment would keep old data (pl. of datum). - */ - case GC_Cell: - case GC_Pair: - case GC_Triple: - case GC_Quadruple: - case GC_Vector: - /* Old is still a pointer to old space */ - Old = Get_Pointer(Old_Car); - if (Old >= Low_Constant) - { - *Scan = Temp; - continue; - } - if (Type_Code(*Old) == TC_BROKEN_HEART) - { - *Scan = Make_New_Pointer(Type_Code(Temp), *Old); - continue; - } - *Scan = NIL; - continue; - - case GC_Compiled: - /* Old is still a pointer to old space */ - Old = Get_Pointer(Old_Car); - if (Old >= Low_Constant) - { - *Scan = Temp; - continue; - } - /* Ditto */ - Old = Get_Compiled_Block(Old); - if (Type_Code(*Old) == TC_BROKEN_HEART) - { - *Scan = Relocate_Compiled(Temp, Get_Pointer(*Old), Old); - continue; - } - *Scan = NIL; - continue; - - case GC_Undefined: - default: /* Non Marked Headers and Broken Hearts */ - fail: - fprintf(stderr, - "\nFix_Weak_Chain: Bad Object: Type = 0x%02x; Datum = %x\n", - Type_Code(Temp), Datum(Temp)); - Microcode_Termination(TERM_INVALID_TYPE_CODE); - /*NOTREACHED*/ - } - } - flush_new_space_buffer(); - return; -} - -void -GC() -{ - Pointer *Root, *Result, *end_of_constant_area, - The_Precious_Objects, *Root2; - - initialize_free_buffer(); - Free = Heap_Bottom; - Set_Mem_Top(Heap_Top - GC_Reserve); - Weak_Chain = NIL; - - /* Save the microcode registers so that they can be relocated */ - Terminate_Old_Stacklet(); - Terminate_Constant_Space(end_of_constant_area); - - Root = Free; - The_Precious_Objects = Get_Fixed_Obj_Slot(Precious_Objects); - Set_Fixed_Obj_Slot(Precious_Objects, NIL); - Set_Fixed_Obj_Slot(Lost_Objects_Base, NIL); - - *free_buffer++ = Fixed_Objects; - *free_buffer++ = Make_Pointer(TC_HUNK3, History); - *free_buffer++ = Undefined_Externals; - *free_buffer++ = Get_Current_Stacklet(); - *free_buffer++ = ((Prev_Restore_History_Stacklet == NULL) ? - NIL : - Make_Pointer(TC_CONTROL_POINT, - Prev_Restore_History_Stacklet)); - *free_buffer++ = Current_State_Point; - *free_buffer++ = Fluid_Bindings; - Free += (free_buffer - free_buffer_bottom); - if (free_buffer >= free_buffer_top) - free_buffer = dump_and_reset_free_buffer(free_buffer - free_buffer_top); - - /* The 4 step GC */ - Result = GCLoop(Constant_Space, &free_buffer, &Free); - if (Result != end_of_constant_area) - { - fprintf(stderr, "\nGC: Constant Scan ended too early.\n"); - Microcode_Termination(TERM_EXIT); - /*NOTREACHED*/ - } - initialize_scan_buffer(); - Result = GCLoop(scan_buffer, &free_buffer, &Free); - if (free_buffer != Result) - { - fprintf(stderr, "\nGC-1: Heap Scan ended too early.\n"); - Microcode_Termination(TERM_EXIT); - /*NOTREACHED*/ - } - Root2 = Free; - *free_buffer++ = The_Precious_Objects; - Free += (free_buffer - Result); - if (free_buffer >= free_buffer_top) - free_buffer = dump_and_reset_free_buffer(free_buffer - free_buffer_top); - Result = GCLoop(Result, &free_buffer, &Free); - if (free_buffer != Result) - { - fprintf(stderr, "\nGC-2: Heap Scan ended too early.\n"); - Microcode_Termination(TERM_EXIT); - /*NOTREACHED*/ - } - dump_buffer(scan_buffer_bottom, &scan_position, 1, "scan"); - free_position = scan_position; - Fix_Weak_Chain(); - load_buffer(0, Heap_Bottom, - ((Free - Heap_Bottom) * sizeof(Pointer)), - "new space"); - - /* Make the microcode registers point to the copies in new-space. */ - - Fixed_Objects = *Root++; - Set_Fixed_Obj_Slot(Precious_Objects, *Root2); - Set_Fixed_Obj_Slot(Lost_Objects_Base, Make_Pointer(TC_ADDRESS, Root2)); - - History = Get_Pointer(*Root++); - Undefined_Externals = *Root++; - Set_Current_Stacklet(*Root); - Root += 1; /* Set_Current_Stacklet is sometimes a No-Op! */ - if (*Root == NIL) - { - Prev_Restore_History_Stacklet = NULL; - Root += 1; - } - else - Prev_Restore_History_Stacklet = Get_Pointer(*Root++); - Current_State_Point = *Root++; - Fluid_Bindings = *Root++; - Free_Stacklets = NULL; - return; -} - -/* (GARBAGE-COLLECT SLACK) - Requests a garbage collection leaving the specified amount of slack - for the top of heap check on the next GC. The primitive ends by invoking - the GC daemon if there is one. -*/ - -Built_In_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT", 0x3A) -{ - Pointer GC_Daemon_Proc; - Primitive_1_Arg(); - - Arg_1_Type(TC_FIXNUM); - if (Free > Heap_Top) - { - fprintf(stderr, - "\nGC has been delayed too long; You are truly out of room!\n"); - fprintf(stderr, - "Free = 0x%x, MemTop = 0x%x, Heap_Top = 0x%x\n", - Free, MemTop, Heap_Top); - Microcode_Termination(TERM_NO_SPACE); - /*NOTREACHED*/ - } - GC_Reserve = Get_Integer(Arg1); - GC(); - IntCode &= ~INT_GC; - if (GC_Check(GC_Space_Needed)) - { - fprintf(stderr, "\nGC just ended.\n"); - fprintf(stderr, - "Free = 0x%x; MemTop = 0x%x; GC_Space_Needed = 0x%x.\n", - Free, MemTop, GC_Space_Needed); - Microcode_Termination(TERM_NO_SPACE); - /*NOTREACHED*/ - } - GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon); - if (GC_Daemon_Proc == NIL) - return Make_Unsigned_Fixnum(MemTop - Free); - Pop_Primitive_Frame(1); - Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1)); - Store_Return(RC_NORMAL_GC_DONE); - Store_Expression(Make_Unsigned_Fixnum(MemTop - Free)); - Save_Cont(); - Push(GC_Daemon_Proc); - Push(STACK_FRAME_HEADER); - Pushed(); - longjmp(*Back_To_Eval, PRIM_APPLY); - /* The following comment is by courtesy of LINT, your friendly sponsor. */ - /*NOTREACHED*/ -} diff --git a/v7/src/microcode/bchpur.c b/v7/src/microcode/bchpur.c deleted file mode 100644 index 8c86fd7b9..000000000 --- a/v7/src/microcode/bchpur.c +++ /dev/null @@ -1,64 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.27 1987/04/16 02:07:10 jinx Exp $ - * - * This file contains the code for primitives dealing with pure - * and constant space. Garbage collection to disk version. - * - * Currently this is not implemented. These are just stubs. - * - */ - -#include "scheme.h" -#include "primitive.h" -#include "bchgcc.h" - -/* Stub. Terminates Scheme if invoked. */ - -Pointer -Purify_Pass_2(info) -Pointer info; -{ - fprintf(stderr, "\nPurify_Pass_2 invoked!\n"); - Microcode_Termination(TERM_EXIT); - /*NOTREACHED*/ -} - -/* Stub. Make it look as if it had succeeded. */ - -Built_In_Primitive(Prim_Primitive_Purify, 2, "PRIMITIVE-PURIFY", 0xB4) -{ - Primitive_2_Args(); - - return TRUTH; -} diff --git a/v7/src/microcode/bignum.c b/v7/src/microcode/bignum.c deleted file mode 100644 index b39c5a96a..000000000 --- a/v7/src/microcode/bignum.c +++ /dev/null @@ -1,1101 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bignum.c,v 9.23 1987/04/16 02:08:22 jinx Rel $ - - This file contains the procedures for handling BIGNUM Arithmetic. -*/ - -#include "scheme.h" -#include -#include "primitive.h" -#include "bignum.h" -#include "flonum.h" -#include "zones.h" - -/* General Purpose Utilities */ - -Pointer -return_bignum_zero() -{ - bigdigit *REG; - long Align_0 = Align(0); - Primitive_GC_If_Needed(Align_0); - REG = BIGNUM(Free); - Prepare_Header(REG, 0, POSITIVE); - Free += Align_0; - return Make_Pointer(TC_BIG_FIXNUM, Free-Align_0); -} - -void -trim_bignum(ARG) - bigdigit *ARG; -{ - fast bigdigit *SCAN; - fast bigdigit size; - bigdigit sign; - - sign = SIGN(ARG); - size = LEN(ARG); - - for (SCAN = Bignum_Top(ARG); ((size != 0) && (*SCAN == 0)); SCAN--) - size -= 1; - - if (size == 0) - sign = POSITIVE; - Prepare_Header(ARG, size, sign); - return; -} - -void -copy_bignum(SOURCE, TARGET) - fast bigdigit *SOURCE, *TARGET; -{ - fast bigdigit *LIMIT; - - LIMIT = Bignum_Top(SOURCE); - while (LIMIT >= SOURCE) - *TARGET++ = *SOURCE++; - return; -} - -long -Find_Length(pradix, length) - fast long pradix; - bigdigit length; -{ - fast int log_pradix; - - log_pradix = 0; - while (pradix != 1) - { - pradix = pradix >> 1; - log_pradix += 1; - } - return (((SHIFT / log_pradix) + 1) * length); -} - -/* scale() and unscale() used by Division and Listify */ - -void -scale(SOURCE, DEST, how_much) - fast bigdigit *SOURCE, *DEST; - fast long how_much; -{ - fast unsigned bigdouble prod = 0; - bigdigit *LIMIT; - - if (how_much == 1) - { - if (SOURCE != DEST) - copy_bignum(SOURCE, DEST); - Prepare_Header(DEST, (LEN(SOURCE) + 1), SIGN(SOURCE)); - *Bignum_Top(DEST) = 0; - return; - } - - /* This must happen before the Prepare_Header if DEST = SOURCE */ - - LIMIT = Bignum_Top(SOURCE); - Prepare_Header(DEST, (LEN(SOURCE) + 1), SIGN(SOURCE)); - SOURCE = Bignum_Bottom(SOURCE); - DEST = Bignum_Bottom(DEST); - while (LIMIT >= SOURCE) - { - prod = *SOURCE++ * how_much + Get_Carry(prod); - *DEST++ = Get_Digit(prod); - } - *DEST = Get_Carry(prod); - return; -} - -/* returns remainder */ - -long -unscale(SOURCE, DEST, how_much) - bigdigit *SOURCE; - fast bigdigit *DEST; - fast long how_much; -{ - bigdigit carry = 0; - fast unsigned bigdouble digits; - fast bigdigit *SCAN; - - if (how_much == 1) - { - if (SOURCE != DEST) - copy_bignum(SOURCE, DEST); - return 0; - } - Prepare_Header(DEST, LEN(SOURCE), SIGN(DEST)); - SCAN = Bignum_Top(SOURCE); - DEST = Bignum_Top(DEST); - SOURCE = Bignum_Bottom(SOURCE); - while (SCAN >= SOURCE) - { - /* Bug fix by JMiller */ - fast unsigned bigdouble digits, temp; - - digits = Mul_Radix(carry) + *SCAN--; - temp = digits / how_much; - *DEST-- = temp; - temp = temp * how_much; - carry = digits - temp; - } - return carry; -} - -/* Bignum Comparison utilities */ - -/* big_compare_unsigned() compares the magnitudes of two BIGNUM's. - * Called by big_compare() and minus_unsigned_bignum(). - */ - -int -big_compare_unsigned(ARG1, ARG2) - fast bigdigit *ARG1, *ARG2; -{ - fast bigdigit *LIMIT; - - if ((LEN(ARG1)) > (LEN(ARG2))) return ONE_BIGGER; - if ((LEN(ARG1)) < (LEN(ARG2))) return TWO_BIGGER; - if ((LEN(ARG1)) == 0) return EQUAL; - LIMIT = Bignum_Bottom(ARG1); - ARG1 = Bignum_Top(ARG1); - ARG2 = Bignum_Top(ARG2); - while (ARG1 >= LIMIT) - { if (*ARG1 > *ARG2) return ONE_BIGGER; - if (*ARG1 < *ARG2) return TWO_BIGGER; - ARG1 -= 1; - ARG2 -= 1; - } - return EQUAL; -} - -/* big_compare() will return either of three cases, determining whether - * ARG1 is bigger, smaller, or equal to ARG2. - */ - -Pointer -big_compare(ARG1, ARG2) - bigdigit *ARG1, *ARG2; -{ - switch(Categorize_Sign(ARG1, ARG2)) - { case BOTH_NEGATIVE : return big_compare_unsigned(ARG2, ARG1); - case BOTH_POSITIVE : return big_compare_unsigned(ARG1, ARG2); - case ARG1_NEGATIVE : return TWO_BIGGER; - case ARG2_NEGATIVE : return ONE_BIGGER; - default: Sign_Error("big_compare()"); - } - /*NOTREACHED*/ -} - -Pointer -Fix_To_Big(Arg1) - Pointer Arg1; -{ - fast bigdigit *Answer, *SCAN, *size; - long Length, ARG1; - - if (Type_Code(Arg1) != TC_FIXNUM) Primitive_Error(ERR_ARG_1_WRONG_TYPE); - if (Get_Integer(Arg1) == 0) - { long Align_0 = Align(0); - bigdigit *REG; - Primitive_GC_If_Needed(2); - REG = BIGNUM(Free); - Prepare_Header(REG, 0, POSITIVE); - Free += Align_0; - return Make_Pointer(TC_BIG_FIXNUM, Free-Align_0); - } - Length = Align(FIXNUM_LENGTH_AS_BIGNUM); - Primitive_GC_If_Needed(Length); - Sign_Extend(Arg1, ARG1); - Answer = BIGNUM(Free); - Prepare_Header(Answer, 0, (ARG1 >= 0) ? POSITIVE : NEGATIVE); - size = &LEN(Answer); - if (ARG1 < 0) ARG1 = - ARG1; - for (SCAN = Bignum_Bottom(Answer); ARG1 != 0; *size += 1) - { *SCAN++ = Rem_Radix(ARG1); - ARG1 = Div_Radix(ARG1); - } - Length = Align(*size); - *((Pointer *) Answer) = Make_Header(Length); - Free += Length; - Debug_Test(Free-Length); - return Make_Pointer(TC_BIG_FIXNUM, Free-Length); -} - -Pointer -Big_To_Fix (bignum_object) - Pointer bignum_object; -{ - fast bigdigit *bptr, *scan; - fast long result, i; - long Length; - - if ((Type_Code (bignum_object)) != TC_BIG_FIXNUM) - return (bignum_object); - bptr = BIGNUM (Get_Pointer (bignum_object)); - Length = LEN (bptr); - if (Length == 0) - return (Make_Unsigned_Fixnum(0)); - if (Length > FIXNUM_LENGTH_AS_BIGNUM) - return (bignum_object); - - scan = Bignum_Top (bptr); - result = *scan--; - - if (result < 0) - return (bignum_object); - - if (Length == FIXNUM_LENGTH_AS_BIGNUM) - { - long saved_result, length_in_bits; - - saved_result = result; - - for (i = 0; result != 0; i+= 1) - result = result >> 1; - - length_in_bits = i + ((Length == 0) ? 0 : ((Length - 1) * SHIFT)); - - if (length_in_bits > FIXNUM_LENGTH) - return (bignum_object); - - result = (saved_result & - ((1 << ((FIXNUM_LENGTH + 1) - - ((FIXNUM_LENGTH + 1) % SHIFT))) - 1)); - - } - - for (i = (Length - 1); (i > 0); i -= 1) - result = (Mul_Radix (result) + *scan--); - - if (result < 0) - return (bignum_object); - if (NEG_BIGNUM (bptr)) - result = (- result); - return (Fixnum_Fits (result) - ? Make_Signed_Fixnum (result) - : bignum_object); -} - -Boolean -Fits_Into_Flonum(Bignum) - bigdigit *Bignum; -{ - fast int k; - quick bigdigit top_digit; - - k = (LEN(Bignum) - 1) * SHIFT; - for (top_digit = *Bignum_Top(Bignum); top_digit != 0; k++) - top_digit >>= 1; - -/* If precision should not be lost, - if (k <= FLONUM_MANTISSA_BITS) return true; - Otherwise, -*/ - - if (k <= MAX_FLONUM_EXPONENT) return true; - return false; -} - -Pointer -Big_To_Float(Arg1) - Pointer Arg1; -{ - fast bigdigit *ARG1, *LIMIT; - fast double F = 0.0; - - ARG1 = BIGNUM(Get_Pointer(Arg1)); - if (!Fits_Into_Flonum(ARG1)) return Arg1; - Primitive_GC_If_Needed(FLONUM_SIZE+1); - LIMIT = Bignum_Bottom(ARG1); - ARG1 = Bignum_Top(ARG1); - while (ARG1 >= LIMIT) F = (F * ((double) RADIX)) + ((double) *ARG1--); - if (NEG_BIGNUM(BIGNUM(Get_Pointer(Arg1)))) F = -F; - return Allocate_Float(F); -} - - -#ifdef HAS_FREXP -extern double frexp(), ldexp(); -#else -#include "missing.c" -#endif - -Pointer -Float_To_Big(flonum) - double flonum; -{ - fast double mantissa; - fast bigdigit *Answer, size; - int exponent; - long Align_size; - - if (flonum == 0.0) - return return_bignum_zero(); - mantissa = frexp(flonum, &exponent); - if (flonum < 0) mantissa = -mantissa; - if (mantissa >= 1.0) - { mantissa = mantissa/2.0; - exponent += 1; - } - size = (exponent + (SHIFT - 1)) / SHIFT; - exponent = exponent % SHIFT; - mantissa = ldexp(mantissa, (exponent == 0) ? 0: exponent - SHIFT); - Align_size = Align(size); - Primitive_GC_If_Needed(Align_size); - Answer = BIGNUM(Free); - Prepare_Header(Answer, size, (flonum < 0) ? NEGATIVE : POSITIVE); - Answer = Bignum_Top(Answer)+1; - while ((size > 0) && (mantissa != 0)) - { - long temporary; - - mantissa = mantissa * ((double) RADIX); - /* explicit intermediate required by compiler bug. -- cph */ - temporary = ((long) mantissa); - *--Answer = ((bigdigit) temporary); - mantissa = mantissa - ((double) *Answer); - size -= 1; - } - while (size-- != 0) *--Answer = (bigdigit) 0; - Free += Align_size; - Debug_Test(Free-Align_size); - return Make_Pointer(TC_BIG_FIXNUM, Free-Align_size); -} - -Pointer -plus_unsigned_bignum(ARG1, ARG2, sign) - fast bigdigit *ARG1, *ARG2; - bigdigit sign; -{ - fast unsigned bigdouble Sum; - long Size; - fast bigdigit *Answer; - fast bigdigit *TOP2, *TOP1; - - /* Swap ARG1 and ARG2 so that ARG1 is always longer */ - - if (LEN(ARG1) < LEN(ARG2)) - { - Answer = ARG1; - ARG1 = ARG2; - ARG2 = Answer; - } - - /* Allocate Storage and do GC if needed */ - - Size = Align(LEN(ARG1) + 1); - Primitive_GC_If_Needed(Size); - Answer = BIGNUM(Free); - Prepare_Header(Answer, (LEN(ARG1) + 1), sign); - - /* Prepare Scanning Pointers and delimiters */ - - TOP1 = Bignum_Top(ARG1); - TOP2 = Bignum_Top(ARG2); - ARG1 = Bignum_Bottom(ARG1); - ARG2 = Bignum_Bottom(ARG2); - Answer = Bignum_Bottom(Answer); - Sum = 0; - - /* Starts Looping */ - - while (TOP2 >= ARG2) - { - Sum = *ARG1++ + *ARG2++ + Get_Carry(Sum); - *Answer++ = Get_Digit(Sum); - } - - /* Let remaining carry propagate */ - - while ((TOP1 >= ARG1) && (Get_Carry(Sum) != 0)) - { - Sum = *ARG1++ + 1; - *Answer++ = Get_Digit(Sum); - } - - /* Copy rest of ARG1 into Answer */ - while (TOP1 >= ARG1) - *Answer++ = *ARG1++; - *Answer = Get_Carry(Sum); - - /* Trims Answer. The trim function is not used because there is at - * most one leading zero. - */ - - if (*Answer == 0) - { - Answer = BIGNUM(Free); - LEN(Answer) -= 1; - *((Pointer *) Answer) = Make_Header(Align(LEN(Answer))); - } - Free += Size; - return Make_Pointer(TC_BIG_FIXNUM, Free-Size); -} - -Pointer -minus_unsigned_bignum(ARG1, ARG2, sign) - fast bigdigit *ARG1, *ARG2; - bigdigit sign; -{ - fast bigdouble Diff; - fast bigdigit *Answer, *TOP2, *TOP1; - long Size; - - if (big_compare_unsigned(ARG1, ARG2) == TWO_BIGGER) - { - Answer = ARG1; - ARG1 = ARG2; - ARG2 = Answer; - sign = !sign; - } - - Size = Align(LEN(ARG1)); - Primitive_GC_If_Needed(Size); - Answer = BIGNUM(Free); - Prepare_Header(Answer, LEN(ARG1), sign); - - TOP1 = Bignum_Top(ARG1); - TOP2 = Bignum_Top(ARG2); - ARG1 = Bignum_Bottom(ARG1); - ARG2 = Bignum_Bottom(ARG2); - Answer = Bignum_Bottom(Answer); - Diff = RADIX; - - /* Main loops for minus_unsigned_bignum */ - - while (TOP2 >= ARG2) - { - Diff = *ARG1++ + (MAX_DIGIT_SIZE - *ARG2++) + Get_Carry(Diff); - *Answer++ = Get_Digit(Diff); - } - - while ((TOP1 >= ARG1) && (Get_Carry(Diff) == 0)) - { - Diff = *ARG1++ + MAX_DIGIT_SIZE; - *Answer++ = Get_Digit(Diff); - } - - while (TOP1 >= ARG1) - *Answer++ = *ARG1++; - trim_bignum((bigdigit *) Free); - Free += Size; - return Make_Pointer(TC_BIG_FIXNUM, Free-Size); -} - -/* Addition */ - -Pointer -plus_signed_bignum(ARG1, ARG2) - bigdigit *ARG1, *ARG2; -{ /* Special Case for answer being zero */ - if (ZERO_BIGNUM(ARG1) && ZERO_BIGNUM(ARG2)) - return return_bignum_zero(); - switch(Categorize_Sign(ARG1, ARG2)) - { case BOTH_POSITIVE : return(plus_unsigned_bignum(ARG1, ARG2, POSITIVE)); - case ARG1_NEGATIVE : return(minus_unsigned_bignum(ARG2, ARG1, POSITIVE)); - case ARG2_NEGATIVE : return(minus_unsigned_bignum(ARG1, ARG2, POSITIVE)); - case BOTH_NEGATIVE : return(plus_unsigned_bignum(ARG1, ARG2, NEGATIVE)); - default : Sign_Error("plus_bignum()"); - } - /*NOTREACHED*/ -} - -/* Subtraction */ - -Pointer -minus_signed_bignum(ARG1, ARG2) - bigdigit *ARG1, *ARG2; -{ - /* Special Case for answer being zero */ - - if (ZERO_BIGNUM(ARG1) && ZERO_BIGNUM(ARG2)) - return return_bignum_zero(); - - /* Dispatches According to Sign of Args */ - - switch(Categorize_Sign(ARG1, ARG2)) - { case BOTH_POSITIVE : return(minus_unsigned_bignum(ARG1, ARG2, POSITIVE)); - case ARG1_NEGATIVE : return(plus_unsigned_bignum(ARG1, ARG2, NEGATIVE)); - case ARG2_NEGATIVE : return(plus_unsigned_bignum(ARG1, ARG2, POSITIVE)); - case BOTH_NEGATIVE : return(minus_unsigned_bignum(ARG2, ARG1, POSITIVE)); - default : Sign_Error("minus_bignum()"); - } - /*NOTREACHED*/ -} - -/* Multiplication */ - -Pointer -multiply_unsigned_bignum(ARG1, ARG2, sign) - fast bigdigit *ARG1, *ARG2; - bigdigit sign; -{ - bigdigit *TOP1, *TOP2; - fast bigdigit *Answer; - fast bigdouble Prod; - fast int size; - long Size; - - Prod = LEN(ARG1) + LEN(ARG2); - Size = Align(Prod); - Primitive_GC_If_Needed(Size); - Answer = BIGNUM(Free); - Prepare_Header(Answer, Prod, sign); - TOP1 = Bignum_Top(Answer); - TOP2 = Bignum_Bottom(Answer); - while (TOP1 >= TOP2) - *TOP2++ = 0; - - /* Main loops for MULTIPLY */ - - size = LEN(ARG2); - Answer = Bignum_Bottom(Answer) + size; - TOP1 = Bignum_Top(ARG1); - TOP2 = Bignum_Top(ARG2); - ARG2 = TOP2; - - for (ARG1 = Bignum_Bottom(ARG1); TOP1 >= ARG1; ARG1++, Answer++) - { - if (*ARG1 != 0) - { - Prod = 0; - Answer -= size; - for (ARG2 = TOP2 - size + 1; TOP2 >= ARG2; ++ARG2) - { - Prod = *ARG1 * *ARG2 + *Answer + Get_Carry(Prod); - *Answer++ = Get_Digit(Prod); - } - *Answer = Get_Carry(Prod); - } - } - - /* Trims Answer */ - - Answer = BIGNUM(Free); - if (*(Bignum_Top(Answer)) == 0) - { - LEN(Answer) -= 1; - *((Pointer *) Answer) = Make_Header(Align(LEN(Answer))); - } - Free += Size; - return Make_Pointer(TC_BIG_FIXNUM, Free-Size); -} - -Pointer -multiply_signed_bignum(ARG1, ARG2) - bigdigit *ARG1, *ARG2; -{ - if (ZERO_BIGNUM(ARG1) || ZERO_BIGNUM(ARG2)) - return return_bignum_zero(); - - switch(Categorize_Sign(ARG1,ARG2)) - { case BOTH_POSITIVE : - case BOTH_NEGATIVE : - return multiply_unsigned_bignum(ARG1, ARG2, POSITIVE); - case ARG1_NEGATIVE : - case ARG2_NEGATIVE : - return multiply_unsigned_bignum(ARG1, ARG2, NEGATIVE); - default : Sign_Error("multiply_bignum()"); - } - /*NOTREACHED*/ -} - -/* This is the guts of the division algorithm. The storage - * allocation and other hairy prep work is done in the superior - * routines. ARG1 and ARG2 are fresh copies, ARG1 will - * ultimately become the Remainder. Storage already - * allocated for all four parameters. - */ - -static Pointer BIG_A[TEMP_SIZE], BIG_B[TEMP_SIZE]; - -Pointer -div_internal(ARG1, ARG2, Quotient) - bigdigit *ARG1, *ARG2, *Quotient; -{ - fast bigdigit *SCAN,*PROD; - fast bigdouble Digit, Prod; - fast bigdouble guess, dvsr2, dvsr1; - fast bigdigit *LIMIT, *QUOT_SCAN; - bigdigit *Big_A, *Big_B; - - Big_A = BIGNUM(BIG_A); - Big_B = BIGNUM(BIG_B); - SCAN = Bignum_Top(ARG2); - if (*SCAN == 0) - { LEN(ARG2) -= 1; - SCAN -= 1; - } - dvsr1 = *SCAN--; - dvsr2 = *SCAN; - - Prepare_Header(Quotient, (LEN(ARG1)-LEN(ARG2)), POSITIVE); - - QUOT_SCAN = Bignum_Top(Quotient); - ARG1 = Bignum_Top(ARG1); - SCAN = ARG1 - LEN(ARG2); - Quotient = Bignum_Bottom(Quotient); - - /* Main Loop for div_internal() */ - - while (QUOT_SCAN >= Quotient) - { - if (dvsr1 <= *ARG1) guess = RADIX - 1; - else - { /* This should be - * guess = (Mul_Radix(*ARG1) + *(ARG1 - 1)) / dvsr1; - * but because of overflow problems ... - */ - - Prepare_Header(Big_A, 2, POSITIVE); - *Bignum_Top(Big_A) = *ARG1; - *Bignum_Bottom(Big_A) = *(ARG1-1); - unscale(Big_A, Big_A, dvsr1); - guess = *Bignum_Bottom(Big_A); - } - guess += 1; /* To counter first decrementing below. */ - do - { - guess -= 1; - Prepare_Header(Big_A, 3, POSITIVE); - LIMIT = Bignum_Top(Big_A); - *LIMIT-- = *ARG1; - *LIMIT-- = *(ARG1-1); - *LIMIT = *(ARG1-2); - Prepare_Header(Big_B, 2, POSITIVE); - *Bignum_Top(Big_B) = dvsr1; - *Bignum_Bottom(Big_B) = dvsr2; - scale(Big_B, Big_B, guess); - if ((*Bignum_Top(Big_B)) == 0) LEN(Big_B) -= 1; - } while (big_compare_unsigned(Big_B, Big_A) == ONE_BIGGER); - - LIMIT = Bignum_Top(ARG2); - PROD = Bignum_Bottom(ARG2); - Digit = RADIX + *SCAN; - while (LIMIT >= PROD) - { - Prod = *PROD++ * guess; - Digit = Digit - Get_Digit(Prod); - *SCAN++ = Get_Digit(Digit); - Digit = ((*SCAN - Get_Carry(Prod)) + - (MAX_DIGIT_SIZE + - ((Digit < 0) ? -1 : Get_Carry(Digit)))); - } - *SCAN++ = Get_Digit(Digit); - - if (Get_Carry(Digit) == 0) - { - /* Guess is one too big, add back. */ - - Digit = 0; - guess -= 1; - LIMIT = Bignum_Top(ARG2); - SCAN = SCAN - LEN(ARG2); - PROD = Bignum_Bottom(ARG2); - while (LIMIT >= PROD) - { - Digit = *SCAN + *PROD++ + Get_Carry(Digit); - *SCAN++ = Get_Digit(Digit); - } - *SCAN = 0; - } - *QUOT_SCAN-- = guess; - ARG1 -= 1; - SCAN = ARG1 - LEN(ARG2); - } -} - -/* div_signed_bignum() differentiates between all the possible - * cases and allocates storage for the quotient, remainder, and - * any intrmediate storage needed. - */ - -Pointer -div_signed_bignum(ARG1, ARG2) - bigdigit *ARG1, *ARG2; -{ - bigdigit *SARG2; - bigdigit *QUOT, *REMD; - Pointer *Cons_Cell; - - if (ZERO_BIGNUM(ARG2)) - Primitive_Error(ERR_ARG_2_BAD_RANGE); - Primitive_GC_If_Needed(2); - Cons_Cell = Free; - Free += 2; - - if (big_compare_unsigned(ARG1, ARG2) == TWO_BIGGER) - { - /* Trivial Solution for ARG1 > ARG2 - * Quotient is zero and the remainder is just a copy of Arg_1. - */ - - Primitive_GC_If_Needed(Align(0)+Align(LEN(ARG1))); - QUOT = BIGNUM(Free); - Free += Align(0); - Prepare_Header(QUOT, 0, POSITIVE); - REMD = BIGNUM(Free); - Free += Align(LEN(ARG1)); - copy_bignum(ARG1, REMD); - } - else if (LEN(ARG2)==1) - { - /* Divisor is only one digit long. - * unscale() is used to divide out Arg_1 and the remainder is the - * single digit returned by unscale(), coerced to a bignum. - */ - - Primitive_GC_If_Needed(Align(LEN(ARG1))+Align(1)); - QUOT = BIGNUM(Free); - Free += Align(LEN(ARG1)); - REMD = BIGNUM(Free); - Free += Align(1); - Prepare_Header(QUOT, LEN(ARG1), POSITIVE); - Prepare_Header(REMD, 1, POSITIVE); - *(Bignum_Bottom(REMD)) = - unscale(ARG1, QUOT, (long) *(Bignum_Bottom(ARG2))); - trim_bignum(REMD); - trim_bignum(QUOT); - } - else - - { - /* Usual case. div_internal() is called. A normalized copy of Arg_1 - * resides in REMD, which ultimately becomes the remainder. The - * normalized copy of Arg_2 is in SARG2. - */ - - bigdouble temp; - - temp = (Align(LEN(ARG1)-LEN(ARG2)+1) + Align(LEN(ARG1)+1) - + Align(LEN(ARG2)+1)); - Primitive_GC_If_Needed(temp); - QUOT = BIGNUM(Free); - *Free = Make_Header(Align(LEN(ARG1)-LEN(ARG2)+1)); - Free += Align(LEN(ARG1)-LEN(ARG2)+1); - REMD = BIGNUM(Free); - *Free = Make_Header(Align(LEN(ARG1)+1)); - Free += Align(LEN(ARG1)+1); - SARG2 = BIGNUM(Free); - *Free = Make_Header(Align(LEN(ARG2)+1)); - Free += Align(LEN(ARG2)+1); - - temp = RADIX / (1 + *(Bignum_Top(ARG2))); - scale(ARG1, REMD, temp); - scale(ARG2, SARG2, temp); - div_internal(REMD, SARG2, QUOT); - unscale(REMD, REMD, temp); - trim_bignum(REMD); - trim_bignum(QUOT); - } - -/* Determines sign of the quotient and remainder */ - - SIGN(REMD) = POSITIVE; - SIGN(QUOT) = POSITIVE; - switch(Categorize_Sign(ARG1,ARG2)) - { case ARG2_NEGATIVE : - SIGN(QUOT) = NEGATIVE; - break; - case ARG1_NEGATIVE : - SIGN(QUOT) = NEGATIVE; - case BOTH_NEGATIVE : - SIGN(REMD) = NEGATIVE; - break; - case BOTH_POSITIVE : break; - default : Sign_Error("divide_bignum()"); - } - /* Glue the two results in a list and return as answer */ - Cons_Cell[CONS_CAR] = Make_Pointer(TC_BIG_FIXNUM, (Pointer *) QUOT); - Cons_Cell[CONS_CDR] = Make_Pointer(TC_BIG_FIXNUM, (Pointer *) REMD); - return Make_Pointer(TC_LIST, Cons_Cell); -} - -/* Utility for debugging */ - -#ifdef ENABLE_DEBUGGING_TOOLS -void -print_digits(name, num, how_many) - char *name; - bigdigit *num; - int how_many; -{ - int NDigits = LEN(num); - int limit; - - printf("\n%s = 0x%08x", name, num); - printf("\n Sign: %c, Vector length: %d, # Digits: %d", - ((SIGN(num) == NEGATIVE) ? '-' : - ((SIGN(num) == POSITIVE) ? '+' : '?')), - Datum(((Pointer *) num)[VECTOR_LENGTH]), - NDigits); - if (how_many == -1) - limit = NDigits; - else - limit = ((how_many < NDigits) ? how_many : NDigits); - num = Bignum_Bottom(num); - while (--how_many >= 0) - printf("\n 0x%04x", *num++); - if (limit < NDigits) - printf("\n ..."); - printf("\n"); - return; -} -#endif - -/* Top level bignum primitives */ -/* Coercion primitives. */ - -/* (COERCE-FIXNUM-TO-BIGNUM FIXNUM) - Returns its argument if FIXNUM isn't a fixnum. Otherwise - it returns the corresponding bignum. -*/ -Built_In_Primitive(Prim_Fix_To_Big, 1, "COERCE-FIXNUM-TO-BIGNUM", 0x67) -{ - Primitive_1_Arg(); - - Arg_1_Type(TC_FIXNUM); - return Fix_To_Big(Arg1); -} - -/* (COERCE-BIGNUM-TO-FIXNUM BIGNUM) - When given a bignum, returns the equivalent fixnum if there is - one. If BIGNUM is out of range, or isn't a bignum, returns - BIGNUM. */ - -Built_In_Primitive (Prim_Big_To_Fix, 1, "COERCE-BIGNUM-TO-FIXNUM", 0x68) -{ - Primitive_1_Arg (); - - Arg_1_Type (TC_BIG_FIXNUM); - return (Big_To_Fix (Arg1)); -} - -/* (LISTIFY-BIGNUM BIGNUM RADIX) - Returns a list of numbers, in the range 0 through RADIX-1, which - represent the BIGNUM in that radix. -*/ -Built_In_Primitive(Prim_Listify_Bignum, 2, "LISTIFY-BIGNUM", 0x50) -{ - fast bigdigit *TOP1, *size; - quick Pointer *RFree; - fast bigdigit *ARG1; - fast long pradix; - Primitive_2_Args(); - - Arg_1_Type(TC_BIG_FIXNUM); - Arg_2_Type(TC_FIXNUM); - Set_Time_Zone(Zone_Math); - - ARG1 = BIGNUM(Get_Pointer(Arg1)); - size = &LEN(ARG1); - if (*size == 0) - { - Primitive_GC_If_Needed(2); - *Free++ = Make_Unsigned_Fixnum(0); - *Free++ = NIL; - return Make_Pointer(TC_LIST, Free-2); - } - Sign_Extend(Arg2, pradix); - Primitive_GC_If_Needed(Find_Length(pradix, *size)+Align(*size)); - ARG1 = BIGNUM(Free); - copy_bignum(BIGNUM(Get_Pointer(Arg1)), ARG1); - Free += Align(*size); - RFree = Free; - size = &LEN(ARG1); - TOP1 = Bignum_Top(ARG1); - while (*size > 0) - { - *RFree++ = Make_Unsigned_Fixnum(unscale(ARG1, ARG1, pradix)); - *RFree = Make_Pointer(TC_LIST, RFree-3); - RFree += 1; - if (*TOP1 == 0) - { - *size -= 1; - TOP1--; - } - } - Free[CONS_CDR] = NIL; - Free = RFree; - return Make_Pointer(TC_LIST, RFree-2); -} - -/* All the binary bignum primitives take two arguments and return NIL - if either of them is not a bignum. If both arguments are bignums, - the perform the operation and return the answer. -*/ - -#define Binary_Primitive(Op) \ -{ \ - Pointer Result, *Orig_Free; \ - Primitive_2_Args(); \ - \ - Arg_1_Type(TC_BIG_FIXNUM); \ - Arg_2_Type(TC_BIG_FIXNUM); \ - Set_Time_Zone(Zone_Math); \ - Orig_Free = Free; \ - Result = Op(BIGNUM(Get_Pointer(Arg1)), BIGNUM(Get_Pointer(Arg2))); \ - if (Consistency_Check && (Get_Pointer(Result) != Orig_Free)) \ - { \ - fprintf(stderr, "\nBignum operation result at 0x%x, Free was 0x%x\n", \ - Address(Result), Free); \ - Microcode_Termination(TERM_EXIT); \ - } \ - Free = Nth_Vector_Loc(Result, Vector_Length(Result)+1); \ - if (Consistency_Check && (Free > Heap_Top)) \ - { \ - fprintf(stderr, "\nBignum operation result at 0x%x, length 0x%x\n", \ - Address(Result), Vector_Length(Result)); \ - Microcode_Termination(TERM_EXIT); \ - } \ - return Result; \ -} - -Built_In_Primitive(Prim_Plus_Bignum, 2, "PLUS-BIGNUM", 0x4C) -Binary_Primitive(plus_signed_bignum) - -Built_In_Primitive(Prim_Minus_Bignum, 2, "MINUS-BIGNUM", 0x4D) -Binary_Primitive(minus_signed_bignum) - -Built_In_Primitive(Prim_Multiply_Bignum, 2, "MULTIPLY-BIGNUM", 0x4E) -Binary_Primitive(multiply_signed_bignum) - -/* (DIVIDE-BIGNUM ONE-BIGNUM ANOTHER_BIGNUM) - * returns a cons of the bignum quotient and remainder of both arguments. - */ - -Built_In_Primitive(Prim_Divide_Bignum, 2, "DIVIDE-BIGNUM", 0x4F) -{ - Pointer Result, *End_Of_First, *First, *Second, *Orig_Free=Free; - Primitive_2_Args(); - - Arg_1_Type(TC_BIG_FIXNUM); - Arg_2_Type(TC_BIG_FIXNUM); - Set_Time_Zone(Zone_Math); - Result = div_signed_bignum(BIGNUM(Get_Pointer(Arg1)), - BIGNUM(Get_Pointer(Arg2))); - if (Bignum_Debug) - printf("\nResult=0x%x [%x %x]\n", - Result, Fast_Vector_Ref(Result, 0), Fast_Vector_Ref(Result, 1)); - First = Get_Pointer(Fast_Vector_Ref(Result, CONS_CAR)); - Second = Get_Pointer(Fast_Vector_Ref(Result, CONS_CDR)); - if (Bignum_Debug) - printf("\nFirst=0x%x [%x %x]; Second=0x%x [%x %x]\n", - First, First[0], First[1], Second, Second[0], Second[1]); - if (Consistency_Check) - { if (First > Second) - { - fprintf(stderr, "\nBignum_Divide: results swapped.\n"); - Microcode_Termination(TERM_EXIT); - } - else if (First != Orig_Free+2) - { - fprintf(stderr, "\nBignum Divide: hole at start\n"); - Microcode_Termination(TERM_EXIT); - } - } - End_Of_First = First + 1 + Get_Integer(First[0]); - if (Bignum_Debug) - printf("\nEnd_Of_First=0x%x\n", End_Of_First); - if (End_Of_First != Second) - { - *End_Of_First = - Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Second-End_Of_First)-1); - if (Bignum_Debug) - printf("\nGap=0x%x\n", (Second-End_Of_First)-1); - } - Free = Second + 1 + Get_Integer(Second[0]); - if (Bignum_Debug) - printf("\nEnd=0x%x\n", Free); - return Result; -} - -/* All the unary bignum predicates take one argument and return NIL if - it is not a bignum. Otherwise, they return a fixnum 1 if the - predicate is true or a fixnum 0 if it is false. This convention of - NIL/0/1 is used for all numeric predicates so that the generic - dispatch can detect "inapplicable" as distinct from "false" answer. -*/ - -#define Unary_Predicate(Test) \ -{ \ - bigdigit *ARG; \ - Primitive_1_Arg(); \ - \ - Arg_1_Type(TC_BIG_FIXNUM); \ - Set_Time_Zone(Zone_Math); \ - ARG = BIGNUM(Get_Pointer(Arg1)); \ - return Make_Unsigned_Fixnum(((Test) ? 1 : 0)); \ -} - -Built_In_Primitive(Prim_Zero_Bignum, 1, "ZERO-BIGNUM?", 0x6F) -Unary_Predicate(LEN(ARG) == 0) - -Built_In_Primitive(Prim_Positive_Bignum, 1, "POSITIVE-BIGNUM?", 0x53) -Unary_Predicate((LEN(ARG) != 0) && POS_BIGNUM(ARG)) - -Built_In_Primitive(Prim_Negative_Bignum, 1, "NEGATIVE-BIGNUM?", 0x80) -Unary_Predicate((LEN(ARG) != 0) && NEG_BIGNUM(ARG)) - -/* All the binary bignum predicates take two arguments and return NIL - if either of them is not a bignum. Otherwise, they return an - answer as described above for the unary predicates. -*/ - -#define Binary_Predicate(Code) \ -{ \ - int result; \ - Primitive_2_Args(); \ - \ - Arg_1_Type(TC_BIG_FIXNUM); \ - Arg_2_Type(TC_BIG_FIXNUM); \ - Set_Time_Zone(Zone_Math); \ - if (big_compare(BIGNUM(Get_Pointer(Arg1)), \ - BIGNUM(Get_Pointer(Arg2))) == Code) \ - result = 1; \ - else \ - result = 0; \ - return Make_Unsigned_Fixnum(result); \ -} - -Built_In_Primitive(Prim_Equal_Bignum, 2, "EQUAL-BIGNUM?", 0x51) -Binary_Predicate(EQUAL) - -Built_In_Primitive(Prim_Greater_Bignum, 2, "GREATER-THAN-BIGNUM?", 0x82) -Binary_Predicate(ONE_BIGGER) - -Built_In_Primitive(Prim_Less_Bignum, 2, "LESS-THAN-BIGNUM?", 0x52) -Binary_Predicate(TWO_BIGGER) diff --git a/v7/src/microcode/bignum.h b/v7/src/microcode/bignum.h deleted file mode 100644 index 4da4ec1d2..000000000 --- a/v7/src/microcode/bignum.h +++ /dev/null @@ -1,178 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bignum.h,v 9.23 1987/04/11 15:17:09 jinx Rel $ - - Head file for bignums. This is shared by bignum.c and generic.c. -*/ - -#ifdef ENABLE_DEBUGGING_TOOLS -#define Debug_Test(Res) \ -{ Pointer R = Make_Pointer(TC_BIG_FIXNUM, Res); \ - if (Nth_Vector_Loc(R, Vector_Length(R)) != (Free-1)) \ - { printf("\nResult=%x -> %x %x %x, Length=%d, Free=%x\n", \ - R, Fast_Vector_Ref(R, 0), \ - Fast_Vector_Ref(R, 1), Fast_Vector_Ref(R, 2), \ - Vector_Length(R), Free); \ - Microcode_Termination(TERM_EXIT); \ - } \ -} -#else -#define Debug_Test(Res) { } -#endif - -#define POSITIVE 1 -#define NEGATIVE 0 - -/* The representation of a BIGNUM is machine dependent. For a VAX-11 - * it is as follows: - */ - -#ifdef pdp10 -typedef unsigned int bigdigit; -typedef long bigdouble; -#define SHIFT 16 -#define factor 1 -#else -#if ((USHORT_SIZE * 2) <= ULONG_SIZE) -#define bigdigit unsigned short -#define bigdouble long /* Should be unsigned */ -#define SHIFT USHORT_SIZE -#define factor (sizeof(Pointer)/sizeof(bigdigit)) -#else -#if ((CHAR_SIZE * 2) <= ULONG_SIZE) -#define bigdigit unsigned char -#define bigdouble long /* Should be unsigned */ -#define SHIFT CHAR_SIZE -#define factor (sizeof(Pointer)/sizeof(bigdigit)) -#else -#include "Cannot compile bignums. All types too large. See bignum.h" -#endif -#endif -#endif - -#define DELTA \ - ((sizeof(bigdouble)-sizeof(bigdigit))*CHAR_SIZE) -#define SIGN(Bignum) (Bignum[factor]) -#define LEN(Bignum) (Bignum[factor+1]) -#define Bignum_Bottom(Bignum) (&(Bignum)[factor+2]) -#define Bignum_Top(Bignum) (&(Bignum)[factor+1+LEN(Bignum)]) -#define Align(ndigits) ((((ndigits) + factor + 1) / factor) + 1) - -/* For temporary bignums */ - -#define TEMP_SIZE Align(4) - -/* Macros for making BIGNUM headers */ - -#define Make_Header(l) Make_Non_Pointer(TC_MANIFEST_NM_VECTOR,(l-1)) -#define Prepare_Header(Bignum,Length,Sign) \ - { *((Pointer *) Bignum) = Make_Header(Align(Length)); \ - SIGN(Bignum) = Sign; \ - LEN(Bignum) = Length; \ - } - -/* Predicates coded as macros for determining the sign of BIGNUM's */ - -#define POS_BIGNUM(Bignum) (SIGN(Bignum) == POSITIVE) -#define NEG_BIGNUM(Bignum) (SIGN(Bignum) == NEGATIVE) -#define ZERO_BIGNUM(Bignum) (LEN(Bignum) == 0) -#define NON_ZERO_BIGNUM(Bignum) (LEN(Bignum) != 0) - - -/* Coerces a C pointer to point to BIGNUM digits */ - -#define BIGNUM(ptr) ((bigdigit *) ptr) - -/* Macros for manipulating long BIGNUM digits */ - -#define RADIX (1<> SHIFT) & DIGIT_MASK) -#define Get_Digit(lw) (lw & DIGIT_MASK) -#define Mul_Radix(sw) (sw << SHIFT) -#define Div_Radix(lw) ((lw >> SHIFT) & DIV_MASK) -#define Rem_Radix(lw) (lw & DIGIT_MASK) - -/* Length of the BIGNUM that contains the largest FIXNUM */ - -#define FIXNUM_LENGTH_AS_BIGNUM ((FIXNUM_LENGTH + (SHIFT - 1)) / SHIFT) -#define C_INTEGER_LENGTH_AS_BIGNUM ((POINTER_LENGTH + (SHIFT - 1)) / SHIFT) - -/* Cases returned by the comparison function big_compare() */ - -#define EQUAL 0 -#define ONE_BIGGER 1 -#define TWO_BIGGER 2 - -/* Categorize_Sign() takes two bignum's and classify them according - * to four possible cases, depending on each's sign. Depends on - * definition of POSITIVE and NEGATIVE, earlier!!! - */ - -#define Categorize_Sign(ARG1, ARG2) ((SIGN(ARG1) << 1) | SIGN(ARG2)) -#define BOTH_NEGATIVE 0 -#define ARG1_NEGATIVE 1 -#define ARG2_NEGATIVE 2 -#define BOTH_POSITIVE 3 -#define Sign_Error(proc) \ - { printf(proc); \ - printf(" -- Sign Determination Error\n"); \ - printf("Possibly Uncanonicalized Bignum\n"); \ - return ERR_UNDEFINED_PRIMITIVE; \ - } - -#define Fetch_Bignum(big) BIGNUM(Get_Pointer(big)) - -#define Bignum_Operation(Object, Result) \ - Result = (Object); \ - Free = Nth_Vector_Loc(Result, Vector_Length(Result)+1); \ - Result = Big_To_Fix(Result); - -#define Divide_Bignum_Operation(Object, Result) \ -{ Pointer *End_Of_First, *First, *Second; \ - Result = (Object); \ - First = Get_Pointer(Vector_Ref(Result, CONS_CAR)); \ - Second = Get_Pointer(Vector_Ref(Result, CONS_CDR)); \ - End_Of_First = First+1+Get_Integer(First[0]); \ - if (End_Of_First != Second) \ - { *End_Of_First = \ - Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Second-End_Of_First)-1); \ - if (Bignum_Debug) printf("\nGap=0x%x\n", (Second-End_Of_First)-1); \ - } \ - Free = Second+1+Get_Integer(Second[0]); \ - Vector_Set(Result,CONS_CAR,Big_To_Fix(Vector_Ref(Result,CONS_CAR))); \ - Vector_Set(Result,CONS_CDR,Big_To_Fix(Vector_Ref(Result,CONS_CDR))); \ -} diff --git a/v7/src/microcode/bintopsb.c b/v7/src/microcode/bintopsb.c deleted file mode 100644 index d7fe0c671..000000000 --- a/v7/src/microcode/bintopsb.c +++ /dev/null @@ -1,838 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bintopsb.c,v 9.25 1987/04/16 15:30:25 jinx Exp $ - * - * This File contains the code to translate internal format binary - * files to portable format. - * - */ - -/* Cheap renames */ - -#define Internal_File Input_File -#define Portable_File Output_File - -#include "translate.h" -#include "trap.h" - -static Boolean Shuffle_Bytes = false; -static Boolean upgrade_traps = false; - -static Pointer *Mem_Base; -static long Heap_Relocation, Constant_Relocation; -static long Free, Scan, Free_Constant, Scan_Constant; -static long Objects, Constant_Objects; -static long NFlonums, NIntegers, NStrings; -static long NBits, NChars; -static Pointer *Free_Objects, *Free_Cobjects; - -Load_Data(Count, To_Where) -long Count; -char *To_Where; -{ fread(To_Where, sizeof(Pointer), Count, Internal_File); -} - -#define Reloc_or_Load_Debug false - -#include "load.c" - -/* Utility macros and procedures - Pointer Objects handled specially in the portable format. -*/ - -#ifndef isalpha -/* Just in case the stdio library atypically contains the character - macros, just like the C book claims. */ -#include -#endif - -#ifndef ispunct -/* This is in some libraries but not others */ -static char punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!"; - -Boolean ispunct(c) -fast char c; -{ fast char *s = &punctuation[0]; - while (*s != '\0') if (*s++ == c) return true; - return false; -} -#endif - -#define OUT(s) \ -fprintf(Portable_File, s); \ -break - -void -print_a_char(c, name) - fast char c; - char *name; -{ - switch(c) - { case '\n': OUT("\\n"); - case '\t': OUT("\\t"); - case '\b': OUT("\\b"); - case '\r': OUT("\\r"); - case '\f': OUT("\\f"); - case '\\': OUT("\\\\"); - case '\0': OUT("\\0"); - case ' ' : OUT(" "); - default: - if ((isalpha(c)) || (isdigit(c)) || (ispunct(c))) - putc(c, Portable_File); - else - { fprintf(stderr, - "%s: %s: File may not be portable: c = 0x%x\n", - Program_Name, name, ((int) c)); - /* This does not follow C conventions, but eliminates ambiguity */ - fprintf(Portable_File, "\X%x ", ((int) c)); - } - } -} - -#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \ -{ \ - Old_Address += (Rel); \ - Old_Contents = *Old_Address; \ - if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ - Mem_Base[(Scn)] = \ - Make_New_Pointer((Code), Old_Contents); \ - else \ - { \ - fast long i; \ - \ - Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \ - *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \ - (Obj) += 1; \ - *(FObj)++ = Make_Non_Pointer(TC_CHARACTER_STRING, 0); \ - *(FObj)++ = Old_Contents; \ - i = Get_Integer(Old_Contents); \ - NStrings += 1; \ - NChars += pointer_to_char(i-1); \ - while(--i >= 0) \ - *(FObj)++ = *Old_Address++; \ - } \ -} - -void -print_a_string(from) - Pointer *from; -{ fast long len; - fast char *string; - long maxlen; - - maxlen = pointer_to_char((Get_Integer(*from++))-1); - len = Get_Integer(*from++); - fprintf(Portable_File, "%02x %ld %ld ", - TC_CHARACTER_STRING, - (Compact_P ? len : maxlen), - len); - string = ((char *) from); - if (Shuffle_Bytes) - { while(len > 0) - { - print_a_char(string[3], "print_a_string"); - if (len > 1) - print_a_char(string[2], "print_a_string"); - if (len > 2) - print_a_char(string[1], "print_a_string"); - if (len > 3) - print_a_char(string[0], "print_a_string"); - len -= 4; - string += 4; - } - } - else while(--len >= 0) print_a_char(*string++, "print_a_string"); - putc('\n', Portable_File); - return; -} - -void -print_a_fixnum(val) - long val; -{ - fast long size_in_bits; - fast unsigned long temp; - - temp = ((val < 0) ? -val : val); - for (size_in_bits = 0; temp != 0; size_in_bits += 1) - temp = temp >> 1; - fprintf(Portable_File, "%02x %c ", - TC_FIXNUM, - (val < 0 ? '-' : '+')); - if (val == 0) - fprintf(Portable_File, "0\n"); - else - { - fprintf(Portable_File, "%ld ", size_in_bits); - temp = ((val < 0) ? -val : val); - while (temp != 0) - { fprintf(Portable_File, "%01lx", (temp % 16)); - temp = temp >> 4; - } - fprintf(Portable_File, "\n"); - } - return; -} - -#define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj) \ -{ Old_Address += (Rel); \ - Old_Contents = *Old_Address; \ - if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ - Mem_Base[(Scn)] = \ - Make_New_Pointer((Code), Old_Contents); \ - else \ - { fast long length; \ - Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \ - NIntegers += 1; \ - NBits += bignum_to_bits(LEN(BIGNUM(Old_Address))); \ - *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \ - (Obj) += 1; \ - *(FObj)++ = Make_Non_Pointer(TC_BIG_FIXNUM, 0); \ - *(FObj)++ = Old_Contents; \ - for (length = Get_Integer(Old_Contents); \ - --length >= 0; ) \ - *(FObj)++ = *Old_Address++; \ - } \ -} - -void -print_a_bignum(from) - Pointer *from; -{ - fast bigdigit *the_number, *the_top; - fast long size_in_bits; - fast unsigned long temp; /* Potential signed problems */ - - the_number = BIGNUM(from); - temp = LEN(the_number); - if (temp == 0) - fprintf(Portable_File, "%02x + 0\n", - (Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM)); - else - { fast long tail; - for (size_in_bits = ((temp - 1) * SHIFT), - temp = ((long) (*Bignum_Top(the_number))); - temp != 0; - size_in_bits += 1) - temp = temp >> 1; - - fprintf(Portable_File, "%02x %c %ld ", - (Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM), - (NEG_BIGNUM(the_number) ? '-' : '+'), - size_in_bits); - tail = size_in_bits % SHIFT; - if (tail == 0) tail = SHIFT; - temp = 0; - size_in_bits = 0; - the_top = Bignum_Top(the_number); - for(the_number = Bignum_Bottom(the_number); - the_number <= the_top; - the_number += 1) - { temp |= (((unsigned long) (*the_number)) << size_in_bits); - for (size_in_bits += ((the_number != the_top) ? SHIFT : tail); - size_in_bits > 3; - size_in_bits -= 4) - { fprintf(Portable_File, "%01lx", temp % 16); - temp = temp >> 4; - } - } - if (size_in_bits > 0) fprintf(Portable_File, "%01lx\n", temp); - else fprintf(Portable_File, "\n"); - } - return; -} - -#define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj) \ -{ Old_Address += (Rel); \ - Old_Contents = *Old_Address; \ - if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ - Mem_Base[(Scn)] = \ - Make_New_Pointer((Code), Old_Contents); \ - else \ - { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \ - Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \ - (Obj) += 1; \ - *(FObj)++ = Make_Non_Pointer(TC_BIG_FLONUM, 0); \ - *((double *) (FObj)) = *((double *) Old_Address); \ - (FObj) += float_to_pointer; \ - NFlonums += 1; \ - } \ -} - -print_a_flonum(val) -double val; -{ fast long size_in_bits; - fast double mant, temp; - int expt; - extern double frexp(); - - fprintf(Portable_File, "%02x %c ", - TC_BIG_FLONUM, - ((val < 0.0) ? '-' : '+')); - if (val == 0.0) - { fprintf(Portable_File, "0\n"); - return; - } - mant = frexp(((val < 0.0) ? -val : val), &expt); - size_in_bits = 1; - for(temp = ((mant * 2.0) - 1.0); - temp != 0; - size_in_bits += 1) - { temp *= 2.0; - if (temp >= 1.0) temp -= 1.0; - } - fprintf(Portable_File, "%ld %ld ", expt, size_in_bits); - for (size_in_bits = hex_digits(size_in_bits); - size_in_bits > 0; - size_in_bits -= 1) - { fast unsigned int digit = 0; - for (expt = 4; --expt >= 0;) - { mant *= 2.0; - digit = digit << 1; - if (mant >= 1.0) - { mant -= 1.0; - digit += 1; - } - } - fprintf(Portable_File, "%01x", digit); - } - fprintf(Portable_File, "\n"); - return; -} - -/* Normal Objects */ - -#define Do_Cell(Code, Rel, Fre, Scn, Obj, FObj) \ -{ Old_Address += (Rel); \ - Old_Contents = *Old_Address; \ - if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ - Mem_Base[(Scn)] = \ - Make_New_Pointer(Type_Code(This), Old_Contents); \ - else \ - { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \ - Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \ - Mem_Base[(Fre)++] = Old_Contents; \ - } \ -} - -#define Do_Pair(Code, Rel, Fre, Scn, Obj, FObj) \ -{ Old_Address += (Rel); \ - Old_Contents = *Old_Address; \ - if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ - Mem_Base[(Scn)] = \ - Make_New_Pointer(Type_Code(This), Old_Contents); \ - else \ - { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \ - Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \ - Mem_Base[(Fre)++] = Old_Contents; \ - Mem_Base[(Fre)++] = *Old_Address++; \ - } \ -} - -#define Do_Triple(Code, Rel, Fre, Scn, Obj, FObj) \ -{ Old_Address += (Rel); \ - Old_Contents = *Old_Address; \ - if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ - Mem_Base[(Scn)] = \ - Make_New_Pointer(Type_Code(This), Old_Contents); \ - else \ - { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \ - Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \ - Mem_Base[(Fre)++] = Old_Contents; \ - Mem_Base[(Fre)++] = *Old_Address++; \ - Mem_Base[(Fre)++] = *Old_Address++; \ - } \ -} - -#define Do_Vector(Code, Rel, Fre, Scn, Obj, FObj) \ -{ Old_Address += (Rel); \ - Old_Contents = *Old_Address; \ - if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ - Mem_Base[(Scn)] = \ - Make_New_Pointer(Type_Code(This), Old_Contents); \ - else \ - { fast long len = Get_Integer(Old_Contents); \ - *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \ - Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \ - Mem_Base[(Fre)++] = Old_Contents; \ - while (len > 0) \ - { Mem_Base[(Fre)++] = *Old_Address++; \ - len -= 1; \ - } \ - } \ -} - -/* Common Pointer Code */ - -#define Do_Pointer(Scn, Action) \ -Old_Address = Get_Pointer(This); \ -if (Datum(This) < Const_Base) \ - Action(HEAP_CODE, Heap_Relocation, Free, \ - Scn, Objects, Free_Objects) \ -else if (Datum(This) < Dumped_Constant_Top) \ -Action(CONSTANT_CODE, Constant_Relocation, Free_Constant, \ - Scn, Constant_Objects, Free_Cobjects) \ -else \ -{ fprintf(stderr, \ - "%s: File is not portable: Pointer to stack.\n", \ - Program_Name); \ - exit(1); \ -} \ -(Scn) += 1; \ -break - -/* Processing of a single area */ - -#define Do_Area(Code, Area, Bound, Obj, FObj) \ - Process_Area(Code, &Area, &Bound, &Obj, &FObj) - -Process_Area(Code, Area, Bound, Obj, FObj) -int Code; -fast long *Area, *Bound; -fast long *Obj; -fast Pointer **FObj; -{ fast Pointer This, *Old_Address, Old_Contents; - while(*Area != *Bound) - { This = Mem_Base[*Area]; - Switch_by_GC_Type(This) - { case TC_MANIFEST_NM_VECTOR: - if (Null_NMV) - { fast int i = Get_Integer(This); - *Area += 1; - for ( ; --i >= 0; *Area += 1) - Mem_Base[*Area] = NIL; - break; - } - /* else, Unknown object! */ - fprintf(stderr, "%s: File is not portable: NMH found\n", - Program_Name); - *Area += 1 + Get_Integer(This); - break; - - case TC_BROKEN_HEART: - /* [Broken Heart 0] is the cdr of fasdumped symbols. */ - if (Get_Integer(This) != 0) - { fprintf(stderr, "%s: Broken Heart found in scan.\n", - Program_Name); - exit(1); - } - *Area += 1; - break; - - case_compiled_entry_point: - fprintf(stderr, - "%s: File is not portable: Compiled code.\n", - Program_Name); - exit(1); - - case TC_FIXNUM: - NIntegers += 1; - NBits += fixnum_to_bits; - /* Fall Through */ - case TC_CHARACTER: - Process_Character: - Mem_Base[*Area] = Make_Non_Pointer(Code, *Obj); - *Obj += 1; - **FObj = This; - *FObj += 1; - /* Fall through */ - case TC_MANIFEST_SPECIAL_NM_VECTOR: - case TC_PRIMITIVE_EXTERNAL: - case_simple_Non_Pointer: - *Area += 1; - break; - - case_Cell: - Do_Pointer(*Area, Do_Cell); - - case TC_REFERENCE_TRAP: - { - long kind; - - kind = Datum(This); - - if (upgrade_traps) - { - /* It is an old UNASSIGNED object. */ - if (kind == 0) - { - Mem_Base[*Area] = UNASSIGNED_OBJECT; - *Area += 1; - break; - } - if (kind == 1) - { - Mem_Base[*Area] = UNBOUND_OBJECT; - *Area += 1; - break; - } - fprintf(stderr, - "%s: Bad old unassigned object. 0x%x.\n", - Program_Name, This); - exit(1); - } - if (kind <= TRAP_MAX_IMMEDIATE) - { - /* It is a non pointer. */ - - *Area += 1; - break; - } - } - /* Fall through */ - - case TC_WEAK_CONS: - case_Pair: - Do_Pointer(*Area, Do_Pair); - - case TC_VARIABLE: - case_Triple: - Do_Pointer(*Area, Do_Triple); - - case TC_BIG_FLONUM: - Do_Pointer(*Area, Do_Flonum); - - case TC_BIG_FIXNUM: - Do_Pointer(*Area, Do_Bignum); - - case TC_CHARACTER_STRING: - Do_Pointer(*Area, Do_String); - - case TC_ENVIRONMENT: - if (upgrade_traps) - { - fprintf(stderr, - "%s: Cannot upgrade environments.\n", - Program_Name); - exit(1); - } - /* Fall through */ - case TC_FUTURE: - case_simple_Vector: - Do_Pointer(*Area, Do_Vector); - - default: - Bad_Type: - fprintf(stderr, "%s: Unknown Type Code 0x%x found.\n", - Program_Name, Type_Code(This)); - exit(1); - } - } -} - -/* Output macros */ - -#define print_an_object(obj) \ -fprintf(Portable_File, "%02x %lx\n", \ - Type_Code(obj), Get_Integer(obj)) - -#define print_external_object(from) \ -{ switch(Type_Code(*from)) \ - { case TC_FIXNUM: \ - { long Value; \ - Sign_Extend(*from++, Value); \ - print_a_fixnum(Value); \ - break; \ - } \ - case TC_BIG_FIXNUM: \ - from += 1; \ - print_a_bignum(from); \ - from += 1 + Get_Integer(*from); \ - break; \ - case TC_CHARACTER_STRING: \ - from += 1; \ - print_a_string(from); \ - from += 1 + Get_Integer(*from); \ - break; \ - case TC_BIG_FLONUM: \ - print_a_flonum(*((double *) (from+1))); \ - from += 1 + float_to_pointer; \ - break; \ - case TC_CHARACTER: \ - fprintf(Portable_File, "%02x %03x\n", \ - TC_CHARACTER, (*from & MASK_EXTNDD_CHAR)); \ - from += 1; \ - break; \ - default: \ - fprintf(stderr, \ - "%s: Bad Object to print externally %lx\n", \ - Program_Name, *from); \ - exit(1); \ - } \ -} - -/* Debugging Aids and Consistency Checks */ - -#ifdef DEBUG - -When(what, message) -Boolean what; -char *message; -{ if (what) - { fprintf(stderr, "%s: Inconsistency: %s!\n", - Program_Name, (message)); - exit(1); - } - return; -} - -#define print_header(name, obj, format) \ -fprintf(Portable_File, (format), (obj)); \ -fprintf(stderr, "%s: ", (name)); \ -fprintf(stderr, (format), (obj)) - -#else - -#define When(what, message) - -#define print_header(name, obj, format) \ -fprintf(Portable_File, (format), (obj)) - -#endif - -/* The main program */ - -do_it() -{ Pointer *Heap; - long Initial_Free; - - /* Load the Data */ - - if (!Read_Header()) - { fprintf(stderr, - "%s: Input file does not appear to be in FASL format.\n", - Program_Name); - exit(1); - } - - if ((Version != FASL_FORMAT_VERSION) || - (Sub_Version > FASL_SUBVERSION) || - (Sub_Version < FASL_OLDEST_SUPPORTED) || - ((Machine_Type != FASL_INTERNAL_FORMAT) && (!Shuffle_Bytes))) - { fprintf(stderr, "%s:\n", Program_Name); - fprintf(stderr, - "FASL File Version %ld Subversion %ld Machine Type %ld\n", - Version, Sub_Version , Machine_Type); - fprintf(stderr, - "Expected: Version %d Subversion %d Machine Type %d\n", - FASL_FORMAT_VERSION, FASL_SUBVERSION, FASL_INTERNAL_FORMAT); - exit(1); - } - - if (Machine_Type == FASL_INTERNAL_FORMAT) - Shuffle_Bytes = false; - upgrade_traps = (Sub_Version < FASL_REFERENCE_TRAP); - - /* Constant Space not currently supported */ - - if (Const_Count != 0) - { fprintf(stderr, - "%s: Input file has a constant space area.\n", - Program_Name); - exit(1); - } - - { long Size = ((3 * (Heap_Count + Const_Count)) + NROOTS + 1); - Allocate_Heap_Space(Size + HEAP_BUFFER_SPACE); - if (Heap == NULL) - { fprintf(stderr, - "%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n", - Program_Name, Size); - exit(1); - } - } - Heap += HEAP_BUFFER_SPACE; - Initial_Align_Float(Heap); - Load_Data(Heap_Count, &Heap[0]); - Load_Data(Const_Count, &Heap[Heap_Count]); - Heap_Relocation = &Heap[0] - Get_Pointer(Heap_Base); - Constant_Relocation = &Heap[Heap_Count] - Get_Pointer(Const_Base); - -#ifdef DEBUG - fprintf(stderr, "Dumped Heap Base = 0x%08x\n", Heap_Base); - fprintf(stderr, "Dumped Constant Base = 0x%08x\n", Const_Base); - fprintf(stderr, "Dumped Constant Top = 0x%08x\n", Dumped_Constant_Top); - fprintf(stderr, "Heap Count = %6d\n", Heap_Count); - fprintf(stderr, "Constant Count = %6d\n", Const_Count); -#endif - - /* Reformat the data */ - - NFlonums = NIntegers = NStrings = NBits = NChars = 0; - Mem_Base = &Heap[Heap_Count + Const_Count]; - if (Ext_Prim_Vector == NIL) - { Mem_Base[0] = Make_Non_Pointer(TC_CELL, 2); - Mem_Base[1] = Make_New_Pointer(TC_CELL, Dumped_Object); - Mem_Base[2] = NIL; - Initial_Free = NROOTS + 1; - Scan = 1; - } - else - { Mem_Base[0] = Ext_Prim_Vector; /* Has CELL TYPE */ - Mem_Base[1] = Make_New_Pointer(TC_CELL, Dumped_Object); - Initial_Free = NROOTS; - Scan = 0; - } - Free = Initial_Free; - Free_Objects = &Mem_Base[Heap_Count + Initial_Free]; - Objects = 0; - - Free_Constant = (2 * Heap_Count) + Initial_Free; - Scan_Constant = Free_Constant; - Free_Cobjects = &Mem_Base[Const_Count + Free_Constant]; - Constant_Objects = 0; - -#if true - Do_Area(HEAP_CODE, Scan, Free, Objects, Free_Objects); -#else - /* When Constant Space finally becomes supported, - something like this must be done. */ - while (true) - { Do_Area(HEAP_CODE, Scan, Free, Objects, Free_Objects); - Do_Area(CONSTANT_CODE, Scan_Constant, - Free_Constant, Constant_Objects, Free_Cobjects); - Do_Area(PURE_CODE, Scan_Pure, Fre_Pure, Pure_Objects, Free_Pobjects); - if (Scan == Free) break; - } -#endif - - /* Consistency checks */ - - When(((Free - Initial_Free) > Heap_Count), "Free overran Heap"); - When(((Free_Objects - &Mem_Base[Initial_Free + Heap_Count]) > - Heap_Count), - "Free_Objects overran Heap Object Space"); - When(((Free_Constant - (Initial_Free + (2 * Heap_Count))) > Const_Count), - "Free_Constant overran Constant Space"); - When(((Free_Cobjects - &Mem_Base[Initial_Free + (2 * Heap_Count) + Const_Count]) > - Const_Count), - "Free_Cobjects overran Constant Object Space"); - - /* Output the data */ - - /* Header */ - - print_header("Portable Version", PORTABLE_VERSION, "%ld\n"); - print_header("Flags", Make_Flags(), "%ld\n"); - print_header("Version", FASL_FORMAT_VERSION, "%ld\n"); - print_header("Sub Version", FASL_SUBVERSION, "%ld\n"); - print_header("Heap Count", (Free - NROOTS), "%ld\n"); - print_header("Heap Base", NROOTS, "%ld\n"); - print_header("Heap Objects", Objects, "%ld\n"); - - /* Currently Constant and Pure not supported, but the header is ready */ - - print_header("Pure Count", 0, "%ld\n"); - print_header("Pure Base", Free_Constant, "%ld\n"); - print_header("Pure Objects", 0, "%ld\n"); - print_header("Constant Count", 0, "%ld\n"); - print_header("Constant Base", Free_Constant, "%ld\n"); - print_header("Constant Objects", 0, "%ld\n"); - - print_header("Number of flonums", NFlonums, "%ld\n"); - print_header("Number of integers", NIntegers, "%ld\n"); - print_header("Number of strings", NStrings, "%ld\n"); - print_header("Number of bits in integers", NBits, "%ld\n"); - print_header("Number of characters in strings", NChars, "%ld\n"); - print_header("& Dumped Object", (Get_Integer(Mem_Base[1])), "%ld\n"); - print_header("& Ext Prim Vector", (Get_Integer(Mem_Base[0])), "%ld\n"); - - /* External Objects */ - - /* Heap External Objects */ - - Free_Objects = &Mem_Base[Initial_Free + Heap_Count]; - for (; Objects > 0; Objects -= 1) - print_external_object(Free_Objects); - -#if false - /* Pure External Objects */ - - Free_Cobjects = &Mem_Base[Pure_Objects_Start]; - for (; Pure_Objects > 0; Pure_Objects -= 1) - print_external_object(Free_Cobjects); - - /* Constant External Objects */ - - Free_Cobjects = &Mem_Base[Constant_Objects_Start]; - for (; Constant_Objects > 0; Constant_Objects -= 1) - print_external_object(Free_Cobjects); - -#endif - - /* Pointer Objects */ - - /* Heap Objects */ - - Free_Cobjects = &Mem_Base[Free]; - for (Free_Objects = &Mem_Base[NROOTS]; - Free_Objects < Free_Cobjects; - Free_Objects += 1) - print_an_object(*Free_Objects); - -#if false - /* Pure Objects */ - - Free_Cobjects = &Mem_Base[Free_Pure]; - for (Free_Objects = &Mem_Base[Pure_Start]; - Free_Objects < Free_Cobjects; - Free_Objects += 1) - print_an_object(*Free_Objects); - - /* Constant Objects */ - - Free_Cobjects = &Mem_Base[Free_Constant]; - for (Free_Objects = &Mem_Base[Constant_Start]; - Free_Objects < Free_Cobjects; - Free_Objects += 1) - print_an_object(*Free_Objects); -#endif - - return; -} - -/* Top Level */ - -static int Noptions = 3; - -static struct Option_Struct Options[] = - {{"Do_Not_Compact", false, &Compact_P}, - {"Null_Out_NMVs", true, &Null_NMV}, - {"Swap_Bytes", true, &Shuffle_Bytes}}; - -main(argc, argv) -int argc; -char *argv[]; -{ Setup_Program(argc, argv, Noptions, Options); - return; -} diff --git a/v7/src/microcode/bitstr.c b/v7/src/microcode/bitstr.c deleted file mode 100644 index d4e27fb00..000000000 --- a/v7/src/microcode/bitstr.c +++ /dev/null @@ -1,850 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bitstr.c,v 9.25 1987/04/17 03:50:09 cph Exp $ - - Bit string primitives. - -*/ - -/* - -Memory layout of bit strings: - -+-------+-------+-------+-------+ -| NMV | GC size (longwords) | 0 -+-------+-------+-------+-------+ -| Size in bits | 1 -+-------+-------+-------+-------+ -|MSB | 2 -+-------+-------+-------+-------+ -| | 3 -+-------+-------+-------+-------+ -. . . -. . . -. . . -+-------+-------+-------+-------+ -| LSB| N -+-------+-------+-------+-------+ - -The first data word (marked as word "2" above) is where any excess -bits are kept. - -The "size in bits" is a C "long" integer. - -Conversions between nonnegative integers and bit strings are -implemented here; they use the standard binary encoding, in which -each index selects the bit corresponding to that power of 2. Thus -bit 0 is the LSB. - -*/ - -#include "scheme.h" -#include "primitive.h" -#include "bignum.h" - -#define bits_to_pointers( bits) \ -(((bits) + (POINTER_LENGTH - 1)) / POINTER_LENGTH) - -#define bit_string_length( bit_string) \ -(Fast_Vector_Ref( bit_string, NM_ENTRY_COUNT)) - -#define bit_string_start_ptr( bit_string) \ -(Nth_Vector_Loc( bit_string, NM_DATA)) - -#define bit_string_end_ptr( bit_string) \ -(Nth_Vector_Loc( bit_string, (Vector_Length( bit_string) + 1))) - -#define any_mask( nbits, offset) (low_mask( nbits) << (offset)) -#define low_mask( nbits) ((1 << (nbits)) - 1) - -Pointer -allocate_bit_string( length) - long length; -{ - long total_pointers; - Pointer result; - - total_pointers = (NM_HEADER_LENGTH + bits_to_pointers( length)); - Primitive_GC_If_Needed( total_pointers); - Free[NM_VECTOR_HEADER] = - Make_Non_Pointer( TC_MANIFEST_NM_VECTOR, (total_pointers - 1)); - Free[NM_ENTRY_COUNT] = length; - result = Make_Pointer( TC_BIT_STRING, Free); - Free += total_pointers; - return result; -} - -/* (BIT-STRING-ALLOCATE length) - Returns an uninitialized bit string of the given length. */ - -Built_In_Primitive( Prim_bit_string_allocate, 1, "BIT-STRING-ALLOCATE", 0xD1) -{ - Primitive_1_Arg(); - - Arg_1_Type( TC_FIXNUM); - return allocate_bit_string( Get_Integer( Arg1)); -} - -/* (BIT-STRING? object) - Returns true iff object is a bit string. */ - -Built_In_Primitive( Prim_bit_string_p, 1, "BIT-STRING?", 0xD3) -{ - Primitive_1_Arg(); - - Touch_In_Primitive( Arg1, Arg1); - return ((Type_Code( Arg1) == TC_BIT_STRING) ? TRUTH : NIL); -} - -void -fill_bit_string( bit_string, sense) - Pointer bit_string; - Boolean sense; -{ - Pointer *scanner; - Pointer filler; - long i; - - filler = ((Pointer) (sense ? -1 : 0)); - scanner = bit_string_start_ptr( bit_string); - for (i = bits_to_pointers( bit_string_length( bit_string)); - (i > 0); i -= 1) - *scanner++ = filler; -} - -void -clear_bit_string( bit_string) - Pointer bit_string; -{ - Pointer *scanner; - long i; - - scanner = bit_string_start_ptr( bit_string); - for (i = bits_to_pointers( bit_string_length( bit_string)); - (i > 0); i -= 1) - *scanner++ = 0; -} - -/* (MAKE-BIT-STRING size initialization) - Returns a bit string of the specified size with all the bits - set to zero if the initialization is false, one otherwise. */ - -Built_In_Primitive( Prim_make_bit_string, 2, "MAKE-BIT-STRING", 0xD2) -{ - Pointer result; - Primitive_2_Args(); - - Arg_1_Type( TC_FIXNUM); - result = allocate_bit_string( Get_Integer( Arg1)); - fill_bit_string( result, (Arg2 != NIL)); - return result; -} - -/* (BIT-STRING-FILL! bit-string initialization) - Fills the bit string with zeros if the initialization is false, - otherwise fills it with ones. */ - -Built_In_Primitive( Prim_bit_string_fill_x, 2, "BIT-STRING-FILL!", 0x197) -{ - Primitive_2_Args(); - - Arg_1_Type( TC_BIT_STRING); - fill_bit_string( Arg1, (Arg2 != NIL)); - return NIL; -} - -/* (BIT-STRING-LENGTH bit-string) - Returns the number of bits in BIT-STRING. */ - -Built_In_Primitive(Prim_bit_string_length, 1, "BIT-STRING-LENGTH", 0xD4) -{ - Primitive_1_Arg(); - - Arg_1_Type( TC_BIT_STRING); - return Make_Non_Pointer( TC_FIXNUM, bit_string_length( Arg1)); -} - -/* The computation of the variable `word' is especially clever. To - understand it, note that the index of the last pointer of a vector is - also the GC length of the vector, so that all we need do is subtract - the zero-based word index from the GC length. */ - -#define index_check( To_Where, P, Low, High, Error) \ -{ \ - To_Where = Get_Integer( P); \ - if ((To_Where < (Low)) || (To_Where >= (High))) \ - Primitive_Error( Error) \ -} - -#define index_to_word( bit_string, index) \ -(Vector_Length( bit_string) - (index / POINTER_LENGTH)) - -#define ref_initialization() \ -long index, word, mask; \ -Primitive_2_Args(); \ - \ -Arg_1_Type( TC_BIT_STRING); \ -Arg_2_Type( TC_FIXNUM); \ -index_check( index, Arg2, 0, bit_string_length( Arg1), \ - ERR_ARG_2_BAD_RANGE); \ - \ -word = index_to_word( Arg1, index); \ -mask = (1 << (index % POINTER_LENGTH)); - -/* (BIT-STRING-REF bit-string index) - Returns the boolean value of the indexed bit. */ - -Built_In_Primitive( Prim_bit_string_ref, 2, "BIT-STRING-REF", 0xD5) -{ - ref_initialization(); - - if ((Fast_Vector_Ref( Arg1, word) & mask) == 0) - return NIL; - else - return TRUTH; -} - -/* (BIT-STRING-CLEAR! bit-string index) - Sets the indexed bit to zero, returning its previous value - as a boolean. */ - -Built_In_Primitive( Prim_bit_string_clear_x, 2, "BIT-STRING-CLEAR!", 0xD8) -{ - ref_initialization(); - - if ((Fast_Vector_Ref( Arg1, word) & mask) == 0) - return NIL; - else - { - Fast_Vector_Ref( Arg1, word) &= ~mask; - return TRUTH; - } -} - -/* (BIT-STRING-SET! bit-string index) - Sets the indexed bit to one, returning its previous value - as a boolean. */ - -Built_In_Primitive( Prim_bit_string_set_x, 2, "BIT-STRING-SET!", 0xD7) -{ - ref_initialization(); - - if ((Fast_Vector_Ref( Arg1, word) & mask) == 0) - { - Fast_Vector_Ref( Arg1, word) |= mask; - return NIL; - } - else - return TRUTH; -} - -#define zero_section_p( start) \ -{ \ - long i; \ - Pointer *scan; \ - \ - scan = Nth_Vector_Loc( Arg1, (start)); \ - for (i = (length / POINTER_LENGTH); (i > 0); i -= 1) \ - if (*scan++ != 0) \ - return NIL; \ - return TRUTH; \ -} - -/* (BIT-STRING-ZERO? bit-string) - Returns true the argument has no "set" bits. */ - -Built_In_Primitive( Prim_bit_string_zero_p, 1, "BIT-STRING-ZERO?", 0xD9) -{ - long length, odd_bits; - Primitive_1_Args(); - - Arg_1_Type(TC_BIT_STRING); - - length = bit_string_length( Arg1); - odd_bits = (length % POINTER_LENGTH); - if (odd_bits == 0) - zero_section_p( NM_DATA) - else if ((Fast_Vector_Ref( Arg1, NM_DATA) & low_mask( odd_bits)) != 0) - return NIL; - else - zero_section_p( NM_DATA + 1) -} - -#define equal_sections_p( start) \ -{ \ - long i; \ - Pointer *scan1, *scan2; \ - \ - scan1 = Nth_Vector_Loc( Arg1, (start)); \ - scan2 = Nth_Vector_Loc( Arg2, (start)); \ - for (i = (length / POINTER_LENGTH); (i > 0); i -= 1) \ - if (*scan1++ != *scan2++) \ - return NIL; \ - return TRUTH; \ -} - -/* (BIT-STRING=? bit-string-1 bit-string-2) - Returns true iff the two bit strings contain the same bits. */ - -Built_In_Primitive( Prim_bit_string_equal_p, 2, "BIT-STRING=?", 0x19D) -{ - long length; - Primitive_2_Args(); - - Arg_1_Type(TC_BIT_STRING); - Arg_2_Type(TC_BIT_STRING); - - length = bit_string_length( Arg1); - if (length != bit_string_length( Arg2)) - return NIL; - else - { - long odd_bits; - - odd_bits = (length % POINTER_LENGTH); - if (odd_bits == 0) - equal_sections_p( NM_DATA) - else - { - long mask; - - mask = low_mask( odd_bits); - if ((Fast_Vector_Ref( Arg1, NM_DATA) & mask) - != (Fast_Vector_Ref( Arg2, NM_DATA) & mask)) - return NIL; - else - equal_sections_p( NM_DATA + 1) - } - } -} - -#define bitwise_op( action) \ -{ \ - Primitive_2_Args(); \ - \ - if (bit_string_length( Arg1) != bit_string_length( Arg2)) \ - Primitive_Error( ERR_ARG_1_BAD_RANGE) \ - else \ - { \ - long i; \ - Pointer *scan1, *scan2; \ - \ - scan1 = bit_string_start_ptr( Arg1); \ - scan2 = bit_string_start_ptr( Arg2); \ - for (i = (Vector_Length( Arg1) - 1); (i > 0); i -= 1) \ - *scan1++ action() (*scan2++); \ - } \ - return (NIL); \ -} - -#define bit_string_move_x_action() = -#define bit_string_movec_x_action() = ~ -#define bit_string_or_x_action() |= -#define bit_string_and_x_action() &= -#define bit_string_andc_x_action() &= ~ - -Built_In_Primitive( Prim_bit_string_move_x, 2, "BIT-STRING-MOVE!", 0x198) - bitwise_op( bit_string_move_x_action) - -Built_In_Primitive( Prim_bit_string_movec_x, 2, "BIT-STRING-MOVEC!", 0x199) - bitwise_op( bit_string_movec_x_action) - -Built_In_Primitive( Prim_bit_string_or_x, 2, "BIT-STRING-OR!", 0x19A) - bitwise_op( bit_string_or_x_action) - -Built_In_Primitive( Prim_bit_string_and_x, 2, "BIT-STRING-AND!", 0x19B) - bitwise_op( bit_string_and_x_action) - -Built_In_Primitive( Prim_bit_string_andc_x, 2, "BIT-STRING-ANDC!", 0x19C) - bitwise_op( bit_string_andc_x_action) - -/* (BIT-SUBSTRING-MOVE-RIGHT! source start1 end1 destination start2) - Destructively copies the substring of SOURCE between START1 and - END1 into DESTINATION at START2. The copying is done from the - MSB to the LSB (which only matters when SOURCE and DESTINATION - are the same). */ - -Built_In_Primitive( Prim_bit_substring_move_right_x, 5, - "BIT-SUBSTRING-MOVE-RIGHT!", 0xD6) -{ - long start1, end1, start2, end2, nbits; - long end1_mod, end2_mod; - void copy_bits(); - Primitive_5_Args(); - - Arg_1_Type( TC_BIT_STRING); - Arg_2_Type( TC_FIXNUM); - Arg_3_Type( TC_FIXNUM); - Arg_4_Type( TC_BIT_STRING); - Arg_5_Type( TC_FIXNUM); - - start1 = Get_Integer( Arg2); - end1 = Get_Integer( Arg3); - start2 = Get_Integer( Arg5); - nbits = (end1 - start1); - end2 = (start2 + nbits); - - if ((start1 < 0) || (start1 > end1)) - Primitive_Error( ERR_ARG_2_BAD_RANGE); - if (end1 > bit_string_length( Arg1)) - Primitive_Error( ERR_ARG_3_BAD_RANGE); - if ((start2 < 0) || (end2 > bit_string_length( Arg4))) - Primitive_Error( ERR_ARG_5_BAD_RANGE); - - end1_mod = (end1 % POINTER_LENGTH); - end2_mod = (end2 % POINTER_LENGTH); - - /* Using `index_to_word' here with -1 offset will work in every - case except when the `end' is 0. In this case the result of - the expression `(-1 / POINTER_LENGTH)' is either 0 or -1, at - the discretion of the C compiler being used. This doesn't - matter because if `end' is zero, then no bits will be moved. */ - - copy_bits( Nth_Vector_Loc( Arg1, index_to_word( Arg1, (end1 - 1))), - ((end1_mod == 0) ? 0 : (POINTER_LENGTH - end1_mod)), - Nth_Vector_Loc( Arg4, index_to_word( Arg4, (end2 - 1))), - ((end2_mod == 0) ? 0 : (POINTER_LENGTH - end2_mod)), - nbits); - return (NIL); -} - -#define masked_transfer( source, destination, nbits, offset) \ -{ \ - long mask; \ - \ - mask = any_mask( nbits, offset); \ - *destination = ((*source & mask) | (*destination & ~mask)); \ -} - -/* This procedure copies bits from one place to another. - The offsets are measured from the MSB of the first Pointer of - each of the arguments SOURCE and DESTINATION. It copies the bits - starting with the MSB of a bit string and moving down. */ - -void -copy_bits( source, source_offset, destination, destination_offset, nbits) - Pointer *source, *destination; - long source_offset, destination_offset, nbits; -{ - - /* This common case can be done very quickly, by splitting the - bit string into three parts. Since the source and destination are - aligned relative to one another, the main body of bits can be - transferred as Pointers, and only the `head' and `tail' need be - treated specially. */ - - if (source_offset == destination_offset) - { - if (source_offset != 0) - { - long head; - - head = (POINTER_LENGTH - source_offset); - if (nbits <= head) - { - masked_transfer( source, destination, nbits, (head - nbits)); - nbits = 0; - } - else - { Pointer temp; - long mask; - - mask = low_mask( head); - temp = *destination; - *destination++ = ((*source++ & mask) | (temp & ~mask)); - nbits -= head; - } - } - if (nbits > 0) - { - long nwords, tail; - - for (nwords = (nbits / POINTER_LENGTH); (nwords > 0); nwords -= 1) - *destination++ = *source++; - - tail = (nbits % POINTER_LENGTH); - if (tail > 0) - masked_transfer( source, destination, tail, - (POINTER_LENGTH - tail)); - } - } - - else if (source_offset < destination_offset) - { - long offset1, offset2, head; - - offset1 = (destination_offset - source_offset); - offset2 = (POINTER_LENGTH - offset1); - head = (POINTER_LENGTH - destination_offset); - - if (nbits <= head) - { - long mask; - - mask = any_mask( nbits, (head - nbits)); - *destination = - (((*source >> offset1) & mask) | (*destination & ~mask)); - } - else - { - long mask1, mask2; - - { Pointer temp; - long mask; - - mask = low_mask( head); - temp = *destination; - *destination++ = - (((*source >> offset1) & mask) | (temp & ~mask)); - } - nbits -= head; - mask1 = low_mask( offset1); - mask2 = low_mask( offset2); - { - long nwords, i; - - for (nwords = (nbits / POINTER_LENGTH); (nwords > 0); nwords -= 1) - { - i = ((*source++ & mask1) << offset2); - *destination++ = (((*source >> offset1) & mask2) | i); - } - } - - { - long tail, dest_tail; - - tail = (nbits % POINTER_LENGTH); - dest_tail = (*destination & low_mask( POINTER_LENGTH - tail)); - if (tail <= offset1) - *destination = - (((*source & any_mask( tail, (offset1 - tail))) << offset2) - | dest_tail); - else - { - long i, j; - - i = ((*source++ & mask1) << offset2); - j = (tail - offset1); - *destination = - (((*source & any_mask( j, (POINTER_LENGTH - j))) >> offset1) - | i | dest_tail); - } - } - } - } - - else /* if (source_offset > destination_offset) */ - { - long offset1, offset2, head; - - offset1 = (source_offset - destination_offset); - offset2 = (POINTER_LENGTH - offset1); - head = (POINTER_LENGTH - source_offset); - - if (nbits <= head) - { - long mask; - - mask = any_mask( nbits, (offset1 + (head - nbits))); - *destination = - (((*source << offset1) & mask) | (*destination & ~mask)); - } - else - { - long dest_buffer, mask1, mask2; - - { - long mask; - - mask = any_mask( head, offset1); - dest_buffer = - ((*destination & ~mask) - | ((*source++ << offset1) & mask)); - } - nbits -= head; - mask1 = low_mask( offset1); - mask2 = any_mask( offset2, offset1); - { - long nwords; - - nwords = (nbits / POINTER_LENGTH); - if (nwords > 0) - dest_buffer &= mask2; - for (; (nwords > 0); nwords -= 1) - { - *destination++ = - (dest_buffer | ((*source >> offset2) & mask1)); - dest_buffer = (*source++ << offset1); - } - } - - { - long tail; - - tail = (nbits % POINTER_LENGTH); - if (tail <= offset1) - *destination = - (dest_buffer - | (*destination & low_mask( offset1 - tail)) - | ((*source >> offset2) & any_mask( tail, (offset1 - tail)))); - else - { - long mask; - - *destination++ = - (dest_buffer | ((*source >> offset2) & mask1)); - mask = low_mask( POINTER_LENGTH - tail); - *destination = - ((*destination & ~mask) | ((*source << offset1) & mask)); - } - } - } - } -} - -/* Integer <-> Bit-string Conversions */ - -long -count_significant_bits( number, start) - long number, start; -{ - long significant_bits, i; - - significant_bits = start; - for (i = (1 << (start - 1)); (i >= 0); i >>= 1) - { - if (number >= i) - break; - significant_bits -= 1; - } - return significant_bits; -} - -long -long_significant_bits( number) - long number; -{ - if (number < 0) - return ULONG_SIZE; - else - return count_significant_bits( number, (ULONG_SIZE - 1)); -} - -Pointer -zero_to_bit_string( length) - long length; -{ - Pointer result; - - result = allocate_bit_string( length); - clear_bit_string( result); - return result; -} - -Pointer -long_to_bit_string( length, number) - long length, number; -{ - if (number < 0) - Primitive_Error( ERR_ARG_2_BAD_RANGE) - else if (number == 0) - zero_to_bit_string( length); - else - { - if (length < long_significant_bits( number)) - Primitive_Error( ERR_ARG_2_BAD_RANGE) - else - { - Pointer result; - - result = allocate_bit_string( length); - clear_bit_string( result); - Fast_Vector_Set( result, Vector_Length( result), number); - return result; - } - } -} - -Pointer -bignum_to_bit_string( length, bignum) - long length; - Pointer bignum; -{ - bigdigit *bigptr; - long ndigits; - - bigptr = BIGNUM( Get_Pointer( bignum)); - if (NEG_BIGNUM( bigptr)) - Primitive_Error( ERR_ARG_2_BAD_RANGE); - ndigits = LEN( bigptr); - if (ndigits == 0) - zero_to_bit_string( length); - else - { - if (length < - (count_significant_bits( *(Bignum_Top( bigptr)), SHIFT) - + (SHIFT * (ndigits - 1)))) - Primitive_Error( ERR_ARG_2_BAD_RANGE) - else - { - Pointer result; - bigdigit *scan1, *scan2; - - result = allocate_bit_string( length); - scan1 = Bignum_Bottom( bigptr); - scan2 = ((bigdigit *) bit_string_end_ptr( result)); - for (; (ndigits > 0); ndigits -= 1) - *--scan2 = *scan1++; - return result; - } - } -} - -/* (UNSIGNED-INTEGER->BIT-STRING length integer) - INTEGER, which must be a non-negative integer, is converted to - a bit-string of length LENGTH. If INTEGER is too large, an - error is signalled. */ - -Built_In_Primitive( Prim_unsigned_to_bit_string, 2, - "UNSIGNED-INTEGER->BIT-STRING", 0xDC) -{ - long length; - Primitive_2_Args(); - - Arg_1_Type( TC_FIXNUM); - length = Get_Integer( Arg1); - if (length < 0) - Primitive_Error( ERR_ARG_1_BAD_RANGE) - else if (Type_Code( Arg2) == TC_FIXNUM) - return long_to_bit_string( length, Get_Integer( Arg2)); - else if (Type_Code( Arg2) == TC_BIG_FIXNUM) - return bignum_to_bit_string( length, Arg2); - else - Primitive_Error( ERR_ARG_2_WRONG_TYPE) -} - -/* (BIT-STRING->UNSIGNED-INTEGER bit-string) - BIT-STRING is converted to the appropriate non-negative integer. - This operation is the inverse of `integer->bit-string'. */ - -Built_In_Primitive( Prim_bit_string_to_unsigned, 1, - "BIT-STRING->UNSIGNED-INTEGER", 0xDD) -{ - Pointer *scan; - long nwords, nbits, ndigits, align_ndigits, word; - bigdigit *bignum, *scan1, *scan2; - - Primitive_1_Arg(); - - Arg_1_Type( TC_BIT_STRING); - - /* Count the number of significant bits.*/ - scan = bit_string_start_ptr( Arg1); - nbits = (bit_string_length( Arg1) % POINTER_LENGTH); - word = ((nbits > 0) ? (*scan++ & low_mask( nbits)) : *scan++); - for (nwords = (Vector_Length( Arg1) - 1); (nwords > 0); nwords -= 1) - { - if (word != 0) - break; - else - word = *scan++; - } - if (nwords == 0) - return Make_Unsigned_Fixnum(0); - nbits = (((nwords - 1) * POINTER_LENGTH) + long_significant_bits( word)); - - /* Handle fixnum case. */ - if (nbits < FIXNUM_LENGTH) - return (Make_Unsigned_Fixnum( word)); - - /* Now the interesting one, we must make a bignum. */ - ndigits = ((nbits + (SHIFT - 1)) / SHIFT); - align_ndigits = Align( ndigits); - Primitive_GC_If_Needed( align_ndigits); - bignum = BIGNUM( Free); - Free += align_ndigits; - Prepare_Header( bignum, ndigits, POSITIVE); - - scan1 = ((bigdigit *) bit_string_end_ptr( Arg1)); - scan2 = Bignum_Bottom( bignum); - for (; (ndigits > 0); ndigits -= 1) - *scan2++ = *--scan1; - nbits = (nbits % SHIFT); - if (nbits != 0) - *scan2 = (*--scan2 & low_mask( nbits)); - - return Make_Pointer( TC_BIG_FIXNUM, ((Pointer *) bignum)); -} - -/* These primitives should test the type of their first argument to - verify that it is a pointer. */ - -/* (READ-BITS! pointer offset bit-string) - Read the contents of memory at the address (POINTER,OFFSET) - into BIT-STRING. */ - -Built_In_Primitive( Prim_read_bits_x, 3, "READ-BITS!", 0xDF) -{ - long end, end_mod; - Primitive_3_Args(); - - Arg_2_Type( TC_FIXNUM); - Arg_3_Type( TC_BIT_STRING); - end = bit_string_length( Arg3); - end_mod = (end % POINTER_LENGTH); - copy_bits( Nth_Vector_Loc( Arg1, 0), Get_Integer( Arg2), - Nth_Vector_Loc( Arg3, index_to_word( Arg3, (end - 1))), - ((end_mod == 0) ? 0 : (POINTER_LENGTH - end_mod)), - end); - return (NIL); -} - -/* (WRITE-BITS! pointer offset bit-string) - Write the contents of BIT-STRING in memory at the address - (POINTER,OFFSET). */ - -Built_In_Primitive( Prim_write_bits_x, 3, "WRITE-BITS!", 0xE0) -{ - long end, end_mod; - Primitive_3_Args(); - - Arg_2_Type( TC_FIXNUM); - Arg_3_Type( TC_BIT_STRING); - end = bit_string_length( Arg3); - end_mod = (end % POINTER_LENGTH); - copy_bits( Nth_Vector_Loc( Arg3, index_to_word( Arg3, (end - 1))), - ((end_mod == 0) ? 0 : (POINTER_LENGTH - end_mod)), - Nth_Vector_Loc( Arg1, 0), Get_Integer( Arg2), - end); - return (NIL); -} diff --git a/v7/src/microcode/bkpt.c b/v7/src/microcode/bkpt.c deleted file mode 100644 index 30b1a6a7c..000000000 --- a/v7/src/microcode/bkpt.c +++ /dev/null @@ -1,103 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bkpt.c,v 9.21 1987/01/22 14:16:33 jinx Rel $ - * - * This file contains breakpoint utilities. - * Disabled when not debugging the interpreter. - * - */ - -#include "scheme.h" - -#ifndef ENABLE_DEBUGGING_TOOLS -#include "Error: Not debugging but bkpt.c included" -#endif - -sp_record_list SP_List = sp_nil; - -extern Boolean Add_a_Pop_Return_Breakpoint(); - -static struct sp_record One_Before = -{ ((Pointer *) 0), - sp_nil -}; - -Boolean Add_a_Pop_Return_Breakpoint(SP) -Pointer *SP; -{ sp_record_list old = SP_List; - SP_List = ((sp_record_list) malloc(sizeof(struct sp_record))); - if (SP_List == sp_nil) - { fprintf(stderr, "Could not allocate a breakpoint structure\n"); - SP_List = old; - return false; - } - SP_List->sp = SP; - SP_List->next = old; - One_Before.next = SP_List; - return true; -} - -/* This uses register rather than fast because it is invoked - * very often and would make things too slow. - */ - -void Pop_Return_Break_Point() -{ register Pointer *SP = Stack_Pointer; - register sp_record_list previous = &One_Before; - register sp_record_list this = previous->next; /* = SP_List */ - for ( ; - this != sp_nil; - previous = this, this = this->next) - if (this->sp == SP) - { Handle_Pop_Return_Break(); - previous->next = this->next; - break; - } - SP_List = One_Before.next; - return; -} - -/* A breakpoint can be placed here from a C debugger to examine - the state of the world. */ - -extern Boolean Print_One_Continuation_Frame(); - -Handle_Pop_Return_Break() -{ Boolean ignore; - Pointer *Old_Stack = Stack_Pointer; - - printf("Pop Return Break: SP = 0x%x\n", Stack_Pointer); - ignore = Print_One_Continuation_Frame(); - Stack_Pointer = Old_Stack; - return; -} diff --git a/v7/src/microcode/bkpt.h b/v7/src/microcode/bkpt.h deleted file mode 100644 index d737da110..000000000 --- a/v7/src/microcode/bkpt.h +++ /dev/null @@ -1,101 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bkpt.h,v 9.23 1987/04/16 02:08:44 jinx Rel $ - * - * This file contains breakpoint utilities. - * Disabled when not debugging the interpreter. - * It "shadows" definitions in default.h - * - */ - -#ifdef ENABLE_DEBUGGING_TOOLS - -struct sp_record -{ Pointer *sp; - struct sp_record *next; -}; -typedef struct sp_record *sp_record_list; - -#define sp_nil ((sp_record_list) NULL) -#define debug_maxslots 100 - -#define Eval_Ucode_Hook() \ -{ \ - local_circle[local_slotno++] = Fetch_Expression(); \ - if (local_slotno >= debug_maxslots) local_slotno = 0; \ - if (local_nslots < debug_maxslots) local_nslots++; \ -} - -#define Pop_Return_Ucode_Hook() \ -{ \ - if (SP_List != sp_nil) \ - { Export_Registers(); \ - Pop_Return_Break_Point(); \ - Import_Registers(); \ - } \ -} - -/* Not implemented yet */ - -#define Apply_Ucode_Hook() - -/* For performance metering we note the time spent handling each - * primitive. This MIGHT help us figure out where all the time - * goes. It should make the time zone kludge obselete someday. - */ - -#if false -/* This code disabled by SAS 6/24/86 */ -struct -{ int nprims; - int primtime[1]; -} perfinfo_data; - -void Clear_Perfinfo_Data() -{ int i; - perfinfo_data.nprims = MAX_PRIMITIVE + 1; - for (i = 0; i <= MAX_PRIMITIVE; i++) - perfinfo_data.primtime[i] = 0; -} - -#define Metering_Apply_Primitive(Loc, N) \ -{ \ - long Start_Time = Sys_Clock(); \ - \ - Loc = Apply_Primitive(N) \ - perfinfo_data.primtime[N] += Sys_Clock() - Start_Time; \ - Set_Time_Zone(Zone_Working); \ -} -#endif -#endif /* ifdef ENABLE_DEBUGGING_TOOLS */ - diff --git a/v7/src/microcode/boot.c b/v7/src/microcode/boot.c deleted file mode 100644 index 0b31f4761..000000000 --- a/v7/src/microcode/boot.c +++ /dev/null @@ -1,586 +0,0 @@ -/* -*-C-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.30 1987/04/16 02:08:53 jinx Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* This file contains the code to support startup of - the SCHEME interpreter. - - The command line (when not running a dumped executable version) may - take the following forms: - - scheme - - or - - scheme {band-name} - - or - - scheme {filespec} - {-heap heap-size} - {-stack stack-size} - {-constant constant-size} - {-utabmd utab-filename} or {-utab utab-filename} - {other arguments ignored by the core microcode} - - with filespec either {-band band-name} or {{-}fasl file-name} - arguments are optional, numbers are in 1K units. Default values - are given above. The arguments in the long for may appear in any - order on the command line. The allocation arguments (heap, stack, - and constant) are ignored when scheme is an executable image. A - warning message is printed if the command line contains them. - - heap-size......number of cells to allocate for user heap; this will - be doubled to allow for 2 space GC. - stack-size.....number of cells for control stack. This primarily - controls maximum depth of recursion. If the flag - USE_STACKLETS is defined, then this controls the - size of the stacklets (not the total stack) and - thus affects how often new stack segments must - be allocated. - constant-size..number of cells for constant and pure space in the - system. - utab-filename..name of an alternate utabmd file to use. - -Additional arguments may exist for particular machines; see CONFIG.H -for details. They are created by defining a macro Command_Line_Args. - -*/ - -#include "scheme.h" -#include "primitive.h" -#include "version.h" -#include "character.h" -#ifndef islower -#include -#endif - -#define STRING_SIZE 512 -#define BLOCKSIZE 1024 -#define blocks(n) ((n)*BLOCKSIZE) - -/* Utilities for command line parsing */ - -#define upcase(c) ((islower(c)) ? (toupper(c)) : c) - -void -uppercase(to_where, from_where) -fast char *to_where, *from_where; -{ fast char c; - while((c = *from_where++) != '\0') *to_where++ = upcase(c); - *to_where = '\0'; - return; -} - -int -Parse_Option(opt_key, nargs, args, casep) -char *opt_key, **args; -Boolean casep; -int nargs; -{ int i; - char key[STRING_SIZE], current[STRING_SIZE]; - if (casep) uppercase(key, opt_key); else strcpy(key, opt_key); - for(i = 0; i < nargs; i++) - { if (casep) uppercase(current, args[i]); else strcpy(current, args[i]); - if (strcmp(key, current) == 0) return i; - } - return NOT_THERE; -} - -long -Def_Number(key, nargs, args, def) -char *key, **args; -long def; -int nargs; -{ int position = Parse_Option(key, nargs, args, true); - if ((position == NOT_THERE) || (position == (nargs-1))) return def; - else return atoi(args[position+1]); -} - -/* Obviously, the main program */ - -/* Used to test whether it is a dumped executable version */ - -extern Boolean Was_Scheme_Dumped; -Boolean Was_Scheme_Dumped = false; - -/* Exit is done in a different way on some operating systems (eg. VMS) */ -Exit_Scheme_Declarations; - -/* Main program */ - -forward void Start_Scheme(); -extern void Clear_Memory(), Setup_Memory(), Reset_Memory(); - -void -main(argc, argv) - int argc; - char **argv; -{ Boolean FASL_It = false; - char *File_Name = NULL; - int Saved_Heap_Size, Saved_Stack_Size, Saved_Constant_Size; - extern void compiler_initialize(); - - Saved_argc = argc; - Saved_argv = argv; - - Init_Exit_Scheme(); - - if (argc > 2) - { int position; - if (((position = Parse_Option("-band", argc, argv, true)) - != NOT_THERE) && - (position != (argc-1))) - File_Name = argv[position+1]; - else if ((((position = Parse_Option("-fasl", argc, argv, true)) - != NOT_THERE) || - ((position = Parse_Option("fasl", argc, argv, true)) - != NOT_THERE)) && - (position != (argc-1))) - { File_Name = argv[position + 1]; - FASL_It = true; - } - } - else if ((argc == 2) && (argv[1][0] != '-')) File_Name = argv[1]; - - if (!Was_Scheme_Dumped) - { Heap_Size = HEAP_SIZE; - Stack_Size = STACK_SIZE; - Constant_Size = CONSTANT_SIZE; - } - else - { Saved_Heap_Size = Heap_Size; - Saved_Stack_Size = Stack_Size; - Saved_Constant_Size = Constant_Size; - } - - Heap_Size = Def_Number("-heap", argc, argv, Heap_Size); - Stack_Size = Def_Number("-stack", argc, argv, Stack_Size); - Constant_Size = Def_Number("-constant", argc, argv, Constant_Size); - - if (Was_Scheme_Dumped) - { Boolean warned = false; - printf("Executable Scheme"); - if ((Heap_Size != Saved_Heap_Size) || - (Stack_Size != Saved_Stack_Size) || - (Constant_Size != Saved_Constant_Size)) - { printf(".\n"); - fprintf(stderr, -"Warning: Allocation parameters (heap, stack, and constant) ignored.\n"); - Heap_Size = Saved_Heap_Size; - Stack_Size = Saved_Stack_Size; - Constant_Size = Saved_Constant_Size; - warned = true; - } - if (File_Name == NULL) - { if (!warned) printf("; "); - printf("Microcode Version %d.%d\n", VERSION, SUBVERSION); - OS_Init(true); - Enter_Interpreter(); - } - else - { if (!warned) printf(".\n"); - Clear_Memory(blocks(Heap_Size), blocks(Stack_Size), - blocks(Constant_Size)); - /* We are reloading from scratch anyway. */ - Was_Scheme_Dumped = false; - Start_Scheme((FASL_It ? BOOT_FASLOAD : BOOT_LOAD_BAND), File_Name); - } - } - if (File_Name == NULL) File_Name = DEFAULT_BAND_NAME; - Command_Line_Hook(); - -/* main continues on the next page */ - -/* main, continued */ - - Setup_Memory(blocks(Heap_Size), blocks(Stack_Size), - blocks(Constant_Size)); - compiler_initialize((long) FASL_It); - Start_Scheme((FASL_It ? BOOT_FASLOAD : BOOT_LOAD_BAND), File_Name); -} - -#define Default_Init_Fixed_Objects(Fixed_Objects) \ -{ Pointer Int_Vec, OB_Array, Error, Bad_Object, \ - The_Queue, *Dummy_Hist, The_Utilities; \ - fast long i; \ - /* Interrupt vector */ \ - Int_Vec = Make_Pointer(TC_VECTOR, Free); \ - *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, \ - MAX_INTERRUPT_NUMBER + 1); \ - for (i=0; i <= MAX_INTERRUPT_NUMBER; i++) *Free++ = NIL; \ - /* Error vector is not needed at boot time */ \ - Error = NIL; \ - /* Dummy History Structure */ \ - History = Make_Dummy_History(); \ - Dummy_Hist = Make_Dummy_History(); \ - /* OBArray */ \ - OB_Array = Make_Pointer(TC_VECTOR, Free); \ - *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, OBARRAY_SIZE); \ - for (i=0; i < OBARRAY_SIZE; i++) *Free++ = NIL; \ - /* Non Object */ \ - Bad_Object = Make_Pointer(TC_LIST, Free); \ - *Free++ = NIL; \ - *Free++ = NIL; \ - /* Initial empty work queue */ \ - The_Queue = Make_Pointer(TC_LIST, Free); \ - *Free++ = NIL; \ - *Free++ = NIL; \ - /* Empty utilities vector */ \ - The_Utilities = Make_Pointer(TC_VECTOR, Free); \ - *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, 0); \ - \ - /* Now make the fixed objects vector */ \ - Fixed_Objects = Make_Pointer(TC_VECTOR, Free); \ - *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, NFixed_Objects); \ - for (i=1; i <= NFixed_Objects; i++) *Free++ = NIL; \ - User_Vector_Set(Fixed_Objects, Non_Object, Bad_Object); \ - User_Vector_Set(Fixed_Objects, System_Interrupt_Vector, Int_Vec); \ - User_Vector_Set(Fixed_Objects, System_Error_Vector, Error); \ - User_Vector_Set(Fixed_Objects, OBArray, OB_Array); \ - User_Vector_Set(Fixed_Objects, Dummy_History, \ - Make_Pointer(TC_HUNK3, Dummy_Hist)); \ - User_Vector_Set(Fixed_Objects, State_Space_Tag, TRUTH); \ - User_Vector_Set(Fixed_Objects, Bignum_One, \ - Fix_To_Big(Make_Unsigned_Fixnum(1))); \ - User_Vector_Set(Fixed_Objects, Me_Myself, Fixed_Objects); \ - User_Vector_Set(Fixed_Objects, The_Work_Queue, The_Queue); \ - User_Vector_Set(Fixed_Objects, Utilities_Vector, The_Utilities); \ -} - -/* Boot Scheme */ - -void -Start_Scheme(Start_Prim, File_Name) - int Start_Prim; - char *File_Name; -{ - extern Pointer make_primitive(); - Pointer FName, Init_Prog, *Fasload_Call, prim; - fast long i; - Boolean I_Am_Master; /* Butterfly test */ - - I_Am_Master = (Start_Prim != BOOT_GET_WORK); - if (I_Am_Master) - printf("Scheme Microcode Version %d.%d\n", VERSION, SUBVERSION); - OS_Init(I_Am_Master); - if (I_Am_Master) - { - for (i = 0; i < FILE_CHANNELS; i++) - { - Channels[i] = NULL; - } - Init_Fixed_Objects(); - } - -/* The initial program to execute is one of - (SCODE-EVAL (BINARY-FASLOAD ) SYSTEM-GLOBAL-ENVIRONMENT), - (LOAD-BAND ), or - ((GET-WORK)) - depending on the value of Start_Prim. -*/ - - FName = C_String_To_Scheme_String(File_Name); - Fasload_Call = Free; - switch (Start_Prim) - { - case BOOT_FASLOAD: /* (SCODE-EVAL (BINARY-FASLOAD ) GLOBAL-ENV) */ - *Free++ = make_primitive("BINARY-FASLOAD"); - *Free++ = FName; - Init_Prog = Make_Pointer(TC_PCOMB2, Free); - *Free++ = make_primitive("SCODE-EVAL"); - *Free++ = Make_Pointer(TC_PCOMB1, Fasload_Call); - *Free++ = Make_Non_Pointer(GLOBAL_ENV, GO_TO_GLOBAL); - break; - - case BOOT_LOAD_BAND: /* (LOAD-BAND ) */ - *Free++ = make_primitive("LOAD-BAND"); - *Free++ = FName; - Init_Prog = Make_Pointer(TC_PCOMB1, Fasload_Call); - break; - - case BOOT_GET_WORK: /* ((GET-WORK)) */ - *Free++ = make_primitive("GET-WORK"); - *Free++ = NIL; - Init_Prog = Make_Pointer(TC_COMBINATION, Free); - *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, 1); - *Free++ = Make_Non_Pointer(TC_PCOMB1, Fasload_Call); - break; - - default: - fprintf(stderr, "Unknown boot time option: %d\n", Start_Prim); - Microcode_Termination(TERM_BAD_PRIMITIVE); - /*NOTREACHED*/ - } - -/* Start_Scheme continues on the next page */ - -/* Start_Scheme, continued */ - - /* Setup registers */ - - IntEnb = INT_Mask; - IntCode = 0; - Env = Make_Non_Pointer(GLOBAL_ENV, 0); - Trapping = false; - Return_Hook_Address = NULL; - - /* Give the interpreter something to chew on, and ... */ - - Will_Push(CONTINUATION_SIZE); - Store_Return(RC_END_OF_COMPUTATION); - Store_Expression(NIL); - Save_Cont(); - Pushed(); - - Store_Expression(Init_Prog); - - /* Go to it! */ - - if ((Stack_Pointer <= Stack_Guard) || (Free > MemTop)) - { - fprintf(stderr, "Configuration won't hold initial data.\n"); - Microcode_Termination(TERM_EXIT); - } - Entry_Hook(); - Enter_Interpreter(); - /*NOTREACHED*/ -} - -Enter_Interpreter() -{ - jmp_buf Orig_Eval_Point; - Back_To_Eval = (jmp_buf *) Orig_Eval_Point; - - Interpret(Was_Scheme_Dumped); - fprintf(stderr, "\nThe interpreter returned to top level!\n"); - Microcode_Termination(TERM_EXIT); - /*NOTREACHED*/ -} - -#define IDENTITY_LENGTH 20 /* Plenty of room */ -#define ID_RELEASE 0 /* Scheme system release */ -#define ID_MICRO_VERSION 1 /* Microcode version */ -#define ID_MICRO_MOD 2 /* Microcode modification */ -#define ID_PRINTER_WIDTH 3 /* Width of console (chars) */ -#define ID_PRINTER_LENGTH 4 /* Height of console (chars) */ -#define ID_NEW_LINE_CHARACTER 5 /* #\Newline */ -#define ID_FLONUM_PRECISION 6 /* Flonum mantissa (bits) */ -#define ID_FLONUM_EXPONENT 7 /* Flonum exponent (bits) */ -#define ID_OS_NAME 8 /* OS name (string) */ -#define ID_OS_VARIANT 9 /* OS variant (string) */ - -Built_In_Primitive (Prim_Microcode_Identify, 0, "MICROCODE-IDENTIFY", 0xE5) -{ - Pointer *Result; - long i; - Primitive_0_Args (); - - Primitive_GC_If_Needed (IDENTITY_LENGTH + VECTOR_DATA); - Result = Free; - *Free++ = (Make_Non_Pointer (TC_MANIFEST_VECTOR, IDENTITY_LENGTH)); - for (i = 0; (i < IDENTITY_LENGTH); i += 1) - *Free++ = NIL; - Result[(ID_RELEASE + VECTOR_DATA)] - = (C_String_To_Scheme_String (RELEASE)); - Result[(ID_MICRO_VERSION + VECTOR_DATA)] - = (Make_Unsigned_Fixnum (VERSION)); - Result[(ID_MICRO_MOD + VECTOR_DATA)] - = (Make_Unsigned_Fixnum (SUBVERSION)); - Result[(ID_PRINTER_WIDTH + VECTOR_DATA)] - = (Make_Unsigned_Fixnum (NColumns ())); - Result[(ID_PRINTER_LENGTH + VECTOR_DATA)] - = (Make_Unsigned_Fixnum (NLines ())); - Result[(ID_NEW_LINE_CHARACTER + VECTOR_DATA)] - = (c_char_to_scheme_char ('\n')); - Result[(ID_FLONUM_PRECISION + VECTOR_DATA)] - = (Make_Unsigned_Fixnum (FLONUM_MANTISSA_BITS)); - Result[(ID_FLONUM_EXPONENT + VECTOR_DATA)] - = (Make_Unsigned_Fixnum (FLONUM_EXPT_SIZE)); - Result[(ID_OS_NAME + VECTOR_DATA)] - = (C_String_To_Scheme_String (OS_Name)); - Result[(ID_OS_VARIANT + VECTOR_DATA)] - = (C_String_To_Scheme_String (OS_Variant)); - return (Make_Pointer (TC_VECTOR, Result)); -} - -Built_In_Primitive(Prim_Microcode_Tables_Filename, - 0, "MICROCODE-TABLES-FILENAME", 0x180) -{ fast char *From, *To; - char *Prefix, *Suffix; - fast long Count; - long position; - Pointer Result; - Primitive_0_Args(); - - if ((((position = Parse_Option("-utabmd", Saved_argc, Saved_argv, true)) - != NOT_THERE) && - (position != (Saved_argc - 1))) || - (((position = Parse_Option("-utab", Saved_argc, Saved_argv, true)) - != NOT_THERE) && - (position != (Saved_argc - 1)))) - { Prefix = ""; - Suffix = Saved_argv[position + 1]; - } - else - { Prefix = SCHEME_SOURCES_PATH; - Suffix = UCODE_TABLES_FILENAME; - } - /* Find the length of the combined string, and allocate. */ - Count = 0; - for (From = Prefix; *From++ != '\0'; ) - { Count += 1; - } - for (From = Suffix; *From++ != '\0'; ) - { Count += 1; - } - Primitive_GC_If_Needed(STRING_CHARS + - ((Count + sizeof(Pointer)) / - sizeof(Pointer))); - - /* Append both substrings. */ - Result = Make_Pointer(TC_CHARACTER_STRING, Free); - To = (char *) &(Free[STRING_CHARS]); - for (From = &(Prefix[0]); *From != '\0'; ) - { *To++ = *From++; - } - for (From = &(Suffix[0]); *From != '\0'; ) - { *To++ = *From++; - } - *To = '\0'; - Free += STRING_CHARS + ((Count + sizeof(Pointer)) / sizeof(Pointer)); - Vector_Set(Result, STRING_LENGTH, Make_Unsigned_Fixnum(Count)); - Vector_Set(Result, STRING_HEADER, - Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, - ((Free - Get_Pointer(Result)) - 1))); - return Result; -} - -/*VARARGS1*/ -term_type -Microcode_Termination(Err, Micro_Error) -long Err, Micro_Error; -{ long value = 1; - Pointer Term_Vector; - if ((Err != TERM_HALT) && - (Valid_Fixed_Obj_Vector()) && - (Type_Code(Term_Vector = - Get_Fixed_Obj_Slot(Termination_Proc_Vector)) == - TC_VECTOR) && - (Vector_Length(Term_Vector) > Err)) - { Pointer Handler = User_Vector_Ref(Term_Vector, Err); - if (Handler != NIL) - { - Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + - ((Err == TERM_NO_ERROR_HANDLER) ? 5 : 4)); - Store_Return(RC_HALT); - Store_Expression(Make_Unsigned_Fixnum(Err)); - Save_Cont(); - if (Err == TERM_NO_ERROR_HANDLER) - Push(Make_Unsigned_Fixnum(Micro_Error)); - Push(Val); /* Arg 3 */ - Push(Fetch_Env()); /* Arg 2 */ - Push(Fetch_Expression()); /* Arg 1 */ - Push(Handler); /* The handler function */ - Push(STACK_FRAME_HEADER + ((Err==TERM_NO_ERROR_HANDLER) ? 4 : 3)); - Pushed(); - longjmp(*Back_To_Eval, PRIM_NO_TRAP_APPLY); - } - } - -/* Microcode_Termination continues on the next page */ - -/* Microcode_Termination, continued */ - - switch(Err) - { case TERM_BAD_PRIMITIVE: - printf("\nBad primitive invoked.\n"); break; - case TERM_BAD_PRIMITIVE_DURING_ERROR: - printf("Error during unknown primitive.\n"); break; - case TERM_BAD_ROOT: - printf("Band file isn't a control point.\n"); break; - case TERM_BAD_STACK: - printf("Control stack messed up.\n"); break; - case TERM_BROKEN_HEART: - printf("Broken heart encountered.\n"); break; - case TERM_COMPILER_DEATH: - printf("Compiled code entered without compiler support.\n"); break; - case TERM_DISK_RESTORE: - printf("DISK restore.\n"); break; - case TERM_EOF: - printf("\nEnd of input stream reached.\n"); break; - case TERM_END_OF_COMPUTATION: - Print_Expression(Val, "End of computation; final result"); break; - case TERM_EXIT: - printf("Inconsistency detected.\n"); break; - case TERM_GC_OUT_OF_SPACE: - printf("Out of space after GC. Needed %d, have %d\n", - Get_Integer(Fetch_Expression()), Space_Before_GC()); - break; - case TERM_HALT: - printf("User halt code.\n"); value = 0; break; - case TERM_INVALID_TYPE_CODE: - printf("Bad Type: check GC_Type map.\n"); break; - case TERM_NO_ERROR_HANDLER: - printf("\nNo handler for error code: %d\n", Micro_Error); break; - case TERM_NO_INTERRUPT_HANDLER: - printf("No interrupt handler.\n"); break; - case TERM_NON_EXISTENT_CONTINUATION: - printf("No such return code 0x%08x.\n", Fetch_Return()); break; - case TERM_NON_POINTER_RELOCATION: - printf("Non pointer relocation!?\n"); break; - case TERM_STACK_ALLOCATION_FAILED: - printf("No space for stack!?\n"); break; - case TERM_STACK_OVERFLOW: - printf("Recursion depth exceeded.\n"); break; - case TERM_TERM_HANDLER: - printf("Termination handler returned.\n"); break; - case TERM_UNIMPLEMENTED_CONTINUATION: - printf("Return code not implemented.\n"); break; - case TERM_NO_SPACE: - printf("Not enough memory.\n"); break; - case TERM_SIGNAL: - printf("Unhandled signal received.\n"); break; - default: printf("Termination code 0x%x.\n", Err); - } - if ((Trace_On_Error) && (Err != TERM_HALT)) - { printf( "\n\nStack trace:\n\n"); - Back_Trace(); - } - OS_Flush_Output_Buffer(); - OS_Quit(); - Reset_Memory(); - Exit_Hook(); - Exit_Scheme(value); -} - diff --git a/v7/src/microcode/breakup.c b/v7/src/microcode/breakup.c deleted file mode 100644 index 2a6019c65..000000000 --- a/v7/src/microcode/breakup.c +++ /dev/null @@ -1,169 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/breakup.c,v 9.21 1987/01/22 14:11:34 jinx Rel $ */ - -#include - -#ifndef isdigit -#include -#endif - -#define boolean char -#define false 0 -#define true 1 - -#define isoctal(c) (isdigit(c) && (c != '8') && (c != '9')) - -int get_a_char() -{ register int c; - register int count = 2; - for (c = getchar(); - isoctal(c) && count >= 0; - c = getchar(), count -=1) - putchar(c); - if (count != 2) return c; - putchar(c); - return getchar(); -} - -main() -{ register int c; - register boolean after_new_line = true; - while ((c = getchar()) != EOF) -re_dispatch: - switch(c) - { case '\f': - break; - case ',': - putchar(c); - while (((c = getchar()) == ' ') || (c == '\t')) - if (c == EOF) - { fprintf(stderr, "Confused expression: ,\n"); - exit(1); - } - if (c == '\n') - { putchar(c); - after_new_line = true; - break; - } - putchar(' '); - goto re_dispatch; - case ';': - case ':': - case '?': - case '}': - putchar(c); - putchar('\n'); - after_new_line = true; - break; - case '\n': - if (!after_new_line) - { after_new_line = true; - putchar('\n'); - } - break; - case '\'': - putchar(c); - c = getchar(); - if (c == EOF) - { fprintf(stderr, "Confused character: EOF\n"); - exit(1); - } - putchar(c); - if (c == '\n') - { fprintf(stderr, "Confused character: \\n\n"); - after_new_line = true; - break; - } - if (c == '\'') - { fprintf(stderr, "Confused character: \\\'\n"); - break; - } - if (c == '\\') - c = get_a_char(); - else c = getchar(); - if (c == EOF) - { fprintf(stderr, "Confused character: EOF\n"); - exit(1); - } - putchar(c); - if (c != '\'') - fprintf(stderr, "Confused character: %c = 0x%x\n", - c); - break; - case '"': - after_new_line == false; - putchar(c); - c = getchar(); - while (true) - { while ((c != EOF) && - (c != '"') && - (c != '\n') && - (c != '\\')) - { putchar(c); - c = getchar(); - } - if (c == EOF) - { fprintf(stderr, "Confused string: EOF\n"); - exit(1); - } - putchar(c); - if (c == '\n') - { fprintf(stderr, "Confused string: \\n\n"); - after_new_line = true; - break; - } - if (c == '"') break; - if (c == '\\') - c = get_a_char(); - } - break; - case '#': - if (after_new_line) - { while (((c = getchar()) != EOF) && (c != '\n')) ; - if (c == EOF) exit(0); - break; - } - putchar(c); - break; - case '{': - if (!after_new_line) - putchar('\n'); - /* Fall Through */ - default: - after_new_line = false; - putchar(c); - } - fflush(stdout); - exit(0); -} diff --git a/v7/src/microcode/char.c b/v7/src/microcode/char.c deleted file mode 100644 index eb0eab590..000000000 --- a/v7/src/microcode/char.c +++ /dev/null @@ -1,329 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/char.c,v 9.21 1987/04/16 02:18:50 jinx Exp $ */ - -/* Character primitives. */ - -#include "scheme.h" -#include "primitive.h" -#include "character.h" -#include - -#define define_ascii_char_guarantee(procedure_name, wta, bra) \ -long \ -procedure_name (argument) \ - Pointer argument; \ -{ \ - fast long ascii; \ - \ - if (! (character_p (argument))) \ - wta (); \ - ascii = (scheme_char_to_c_char (argument)); \ - if (ascii == NOT_ASCII) \ - bra (); \ - return (ascii); \ -} - -define_ascii_char_guarantee (guarantee_ascii_char_arg_1, - error_wrong_type_arg_1, - error_bad_range_arg_1) - -define_ascii_char_guarantee (guarantee_ascii_char_arg_2, - error_wrong_type_arg_2, - error_bad_range_arg_2) - -define_ascii_char_guarantee (guarantee_ascii_char_arg_3, - error_wrong_type_arg_3, - error_bad_range_arg_3) - -define_ascii_char_guarantee (guarantee_ascii_char_arg_4, - error_wrong_type_arg_4, - error_bad_range_arg_4) - -define_ascii_char_guarantee (guarantee_ascii_char_arg_5, - error_wrong_type_arg_5, - error_bad_range_arg_5) - -define_ascii_char_guarantee (guarantee_ascii_char_arg_6, - error_wrong_type_arg_6, - error_bad_range_arg_6) - -define_ascii_char_guarantee (guarantee_ascii_char_arg_7, - error_wrong_type_arg_7, - error_bad_range_arg_7) - -define_ascii_char_guarantee (guarantee_ascii_char_arg_8, - error_wrong_type_arg_8, - error_bad_range_arg_8) - -define_ascii_char_guarantee (guarantee_ascii_char_arg_9, - error_wrong_type_arg_9, - error_bad_range_arg_9) - -define_ascii_char_guarantee (guarantee_ascii_char_arg_10, - error_wrong_type_arg_10, - error_bad_range_arg_10) - -#define define_ascii_integer_guarantee(procedure_name, wta, bra) \ -long \ -procedure_name (argument) \ - Pointer argument; \ -{ \ - fast long ascii; \ - \ - if (! (fixnum_p (argument))) wta (); \ - if (fixnum_negative_p (argument)) bra (); \ - ascii = (pointer_datum (argument)); \ - if (ascii >= MAX_ASCII) bra (); \ - return (ascii); \ -} - -define_ascii_integer_guarantee (guarantee_ascii_integer_arg_1, - error_wrong_type_arg_1, - error_bad_range_arg_1) - -define_ascii_integer_guarantee (guarantee_ascii_integer_arg_2, - error_wrong_type_arg_2, - error_bad_range_arg_2) - -define_ascii_integer_guarantee (guarantee_ascii_integer_arg_3, - error_wrong_type_arg_3, - error_bad_range_arg_3) - -define_ascii_integer_guarantee (guarantee_ascii_integer_arg_4, - error_wrong_type_arg_4, - error_bad_range_arg_4) - -define_ascii_integer_guarantee (guarantee_ascii_integer_arg_5, - error_wrong_type_arg_5, - error_bad_range_arg_5) - -define_ascii_integer_guarantee (guarantee_ascii_integer_arg_6, - error_wrong_type_arg_6, - error_bad_range_arg_6) - -define_ascii_integer_guarantee (guarantee_ascii_integer_arg_7, - error_wrong_type_arg_7, - error_bad_range_arg_7) - -define_ascii_integer_guarantee (guarantee_ascii_integer_arg_8, - error_wrong_type_arg_8, - error_bad_range_arg_8) - -define_ascii_integer_guarantee (guarantee_ascii_integer_arg_9, - error_wrong_type_arg_9, - error_bad_range_arg_9) - -define_ascii_integer_guarantee (guarantee_ascii_integer_arg_10, - error_wrong_type_arg_10, - error_bad_range_arg_10) - -Built_In_Primitive (Prim_Make_Char, 2, "MAKE-CHAR", 0x14) -{ - long bucky_bits, code; - Primitive_2_Args (); - - code = (guarantee_index_arg_1 (Arg1, MAX_CODE)); - bucky_bits = (guarantee_index_arg_2 (Arg2, MAX_BITS)); - return (make_char (bucky_bits, code)); -} - -Built_In_Primitive (Prim_Char_Bits, 1, "CHAR-BITS", 0x15) -{ - Primitive_1_Arg (); - - guarantee_char_arg_1 (); - return (Make_Unsigned_Fixnum (char_bits (Arg1))); -} - -Built_In_Primitive (Prim_Char_Code, 1, "CHAR-CODE", 0x17) -{ - Primitive_1_Arg (); - - guarantee_char_arg_1 (); - return (Make_Unsigned_Fixnum (char_code (Arg1))); -} - -Built_In_Primitive (Prim_Char_To_Integer, 1, "CHAR->INTEGER", 0x1B) -{ - Primitive_1_Arg (); - - guarantee_char_arg_1 (); - return (Make_Unsigned_Fixnum (Arg1 & MASK_EXTNDD_CHAR)); -} - -Built_In_Primitive (Prim_Integer_To_Char, 1, "INTEGER->CHAR", 0x34) -{ - Primitive_1_Arg (); - - return - (Make_Non_Pointer (TC_CHARACTER, - (guarantee_index_arg_1 (Arg1, MAX_EXTNDD_CHAR)))); -} - -long -char_downcase (c) - long c; -{ - c = (char_to_long (c)); - return ((isupper (c)) ? ((c - 'A') + 'a') : c); -} - -long -char_upcase (c) - long c; -{ - c = (char_to_long (c)); - return ((islower (c)) ? ((c - 'a') + 'A') : c); -} - -Built_In_Primitive (Prim_Char_Downcase, 1, "CHAR-DOWNCASE", 0x35) -{ - Primitive_1_Arg (); - - guarantee_char_arg_1 (); - return (make_char ((char_bits (Arg1)), (char_downcase (char_code (Arg1))))); -} - -Built_In_Primitive (Prim_Char_Upcase, 1, "CHAR-UPCASE", 0x36) -{ - Primitive_1_Arg (); - - guarantee_char_arg_1 (); - return (make_char ((char_bits (Arg1)), (char_upcase (char_code (Arg1))))); -} - -Built_In_Primitive (Prim_Ascii_To_Char, 1, "ASCII->CHAR", 0x37) -{ - Primitive_1_Arg (); - - return (c_char_to_scheme_char (guarantee_ascii_integer_arg_1 (Arg1))); -} - -Built_In_Primitive (Prim_Char_To_Ascii, 1, "CHAR->ASCII", 0x39) -{ - Primitive_1_Arg (); - - return (Make_Unsigned_Fixnum (guarantee_ascii_char_arg_1 (Arg1))); -} - -Built_In_Primitive (Prim_Char_Ascii_P, 1, "CHAR-ASCII?", 0x38) -{ - long ascii; - Primitive_1_Arg (); - - guarantee_char_arg_1 (); - ascii = (scheme_char_to_c_char (Arg1)); - return ((ascii == NOT_ASCII) ? NIL : (Make_Unsigned_Fixnum (ascii))); -} - -forward Boolean ascii_control_p(); - -long -ascii_to_mit_ascii (ascii) - long ascii; -{ - long bucky_bits, code; - - bucky_bits = (((ascii & 0200) != 0) ? CHAR_BITS_META : 0); - code = (ascii & 0177); - if (ascii_control_p (code)) - { - code |= 0100; /* Convert to non-control code. */ - bucky_bits |= CHAR_BITS_CONTROL; - } - return ((bucky_bits << CODE_LENGTH) | code); -} - -long -mit_ascii_to_ascii (mit_ascii) - long mit_ascii; -{ - long bucky_bits, code; - - bucky_bits = ((mit_ascii >> CODE_LENGTH) & CHAR_MASK_BITS); - code = (mit_ascii & CHAR_MASK_CODE); - if ((bucky_bits & (~ CHAR_BITS_CONTROL_META)) != 0) - return (NOT_ASCII); - else - { - if ((bucky_bits & CHAR_BITS_CONTROL) != 0) - { - code = (char_upcase (code) & (~ 0100)); - if (!ascii_control_p (code)) - return (NOT_ASCII); - } - else - { - if (ascii_control_p (code)) - return (NOT_ASCII); - } - return (((bucky_bits & CHAR_BITS_META) != 0) ? (code | 0200) : code); - } -} - -Boolean -ascii_control_p (code) - int code; -{ - switch (code) - { - case 000: - case 001: - case 002: - case 003: - case 004: - case 005: - case 006: - case 007: - case 016: - case 017: - case 020: - case 021: - case 022: - case 023: - case 024: - case 025: - case 026: - case 027: - case 030: - case 031: - case 034: - case 035: - case 036: - return (true); - - default: - return (false); - } -} diff --git a/v7/src/microcode/config.h b/v7/src/microcode/config.h deleted file mode 100644 index 6ba390306..000000000 --- a/v7/src/microcode/config.h +++ /dev/null @@ -1,449 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/config.h,v 9.24 1987/04/16 02:20:07 jinx Exp $ - * - * This file contains the configuration information and the information - * given on the command line on Unix. - * - */ - -/* Default pathnames. */ - -#ifndef DEFAULT_BAND_NAME -#define DEFAULT_BAND_NAME "scm:scheme.bin" -#endif -#ifndef SCHEME_SOURCES_PATH -#define SCHEME_SOURCES_PATH "scm:" -#endif - -#ifndef butterfly -#ifndef unix -/* On unix, these are part of the make file. */ - -/* Runtime debugging flags, with appropriate defaults: */ - -/* To debug the interpreter code itself, define ENABLE_DEBUGGING_TOOLS */ -/* #define ENABLE_DEBUGGING_TOOLS */ - -/* If runtime HISTORY recording (a Scheme code debugging tool) is desired. */ -#define COMPILE_HISTORY - -/* To enable the STEPPER. Incompatible with futures. */ -/* #define COMPILE_STEPPER */ - -/* To enable FUTURES (a multiprocessor / multiprocessing extension). - This option is incompatible with the stepper. - Future.c must also be compiled. */ -/* #define COMPILE_FUTURES */ - -/* To enable stacklets (mostly useful with FUTURES). These allow the - stack to be allocated in small chunks from the heap, rather than - in a single contiguous area at start up time. The use of the this - option is incompatible with the stepper and compiler. -*/ -/* #define USE_STACKLETS */ -#endif -#endif - -/* Some configuration consistency testing */ - -#ifdef COMPILE_STEPPER -#ifdef COMPILE_FUTURES -#include "Error: Futures and stepping are not currently compatible." -#endif -#endif - -#ifdef USE_STACKLETS -#ifdef COMPILE_STEPPER -#include "Error: The stepper doesn't work with stacklets." -#endif -#endif - -/* These C type definitions are needed by everybody. - They should not be here, but it is unavoidable. */ - -typedef char Boolean; -#define true 1 -#define false 0 - -/* This defines it so that C will be happy. - The various fields are defined in object.h */ - -typedef unsigned long Pointer; - -/* Operating System / Machine dependencies: - - For each implementation, be sure to specify FASL_INTERNAL_FORMAT, - the various sizes, and the floating point information. - Make sure that there is an appropriate FASL_. - If you do not know these parameters, try compiling and running the - wsize program ("make wsize" if on a unix variant). It may not run, - but if it does, it will probably compute the correct information. - - Note that the C type void is used in the sources. If your version - of C does not have this type, you should bypass it. - This can be done by inserting the preprocessor command - '#define void' in this file. - - CHAR_SIZE is the size of a character in bits. - - USHORT_SIZE is the size of an unsigned short in bits. It should - be equivalent to (sizeof(unsigned short) * CHAR_SIZE), but is - available to the preprocessor. - - ULONG_SIZE is the size of an unsigned long in bits. - - FLONUM_EXPT_SIZE is the number of bits in the largest positive - exponent of a (double) floating point number. - Note that if excess exponents are used in the representation, - this number is one less than the size in bits of the exponent field. - - FLONUM_MANTISSA_BITS is the number of bits in the (positive) mantissa - of a (double) floating point number. It includes the hidden bit if - the representation uses them. - - Thus 2+FLONUM_EXPT_SIZE+FLONUM_MANTISSA_BITS(-1 if hidden bit is used) - should be the size in bits of a (double) floating point number. - - FLONUM_EXPONENT_SIZE - MAX_FLONUM_EXPONENT = 2 - 1 - - Other flags (the safe option is NOT to define them, which will - sacrifice speed for safety): - - b32 should be defined for machines whose word size - (CHAR_SIZE*sizeof(long)) is 32 bits. The information is redundant, - but some C compilers do not do constant folding when shifts are - involved, so it sometimes makes a big difference to define the - constants directly rather than in terms of other constants. - Similar things can be done for other word sizes. -*/ - -/* Heap_In_Low_Memory should be defined if malloc returns the lowest - available memory and thus all addresses will fit in the datum portion - of a Scheme Pointer. The datum portion of a Scheme Pointer is 8 bits - less than the length of a C long. - - UNSIGNED_SHIFT is defined if right shifting an unsigned long - (i.e. Pointer) results in a logical (vs. arithmetic) shift. - Setting the flag allows faster type code extraction. - - BELL is the character which rings the terminal bell. - - The following switches are used to use the system provided library - routines rather than the emulated versions in the Scheme sources. - The system provided ones are more accurate and potentially more - efficient. - - HAS_FLOOR should be defined if the system has the double precision - procedures floor and ceil. On Unix, look for floor(3M). - - HAS_FREXP should be defined if the system has the double precision - procedures ldexp and frexp. On Unix, look for frexp(3C). - - FLOATING_ALIGNMENT should be defined if the system requires - floating point numbers (double) to be aligned more strictly than - Pointers (long). The value must be a mask of the low order - bits which are required to be zero for the storage address. - For example, a value of 0x7 requires octabyte alignment on a - machine where addresses are specified in bytes. The alignment - must be an integral multiple of the length of a long, since - it must pad with an explicit Pointer value. - This option is not completely working right now. - -*/ - -#define FASL_UNKNOWN 0 -#define FASL_PDP10 1 -#define FASL_VAX 2 -#define FASL_HP_9000_200 3 -#define FASL_NU 4 -#define FASL_HP_9000_500 5 -#define FASL_SUN 6 -#define FASL_BFLY 7 -#define FASL_CYBER 8 -#define FASL_CELERITY 9 -#define FASL_HP_SPECTRUM 10 -#define FASL_UMAX 11 - -/* These (pdp10 and nu) haven't worked in a while. - * Should be upgraded or flushed some day. - */ - -#ifdef pdp10 -#define Heap_In_Low_Memory -#define CHAR_SIZE 36 / * Ugh! Supposedly fixed in newer Cs * / -#define BELL '\007' -#define FASL_INTERNAL_FORMAT FASL_PDP10 -#endif - -#ifdef nu -#define Heap_In_Low_Memory -#define CHAR_SIZE 8 -#define USHORT_SIZE 16 -#define ULONG_SIZE 32 -#define BELL '\007' -#define FASL_INTERNAL_FORMAT FASL_NU -#define FLONUM_EXPT_SIZE 7 -#define FLONUM_MANTISSA_BITS 56 -#define MAX_FLONUM_EXPONENT 127 -#define HAS_FREXP -#ifdef quick -/* Bignum code fails for certain variables in registers because of a - compiler bug! -*/ -#undef quick -#define quick -#endif -#endif - -#ifdef vax -/* Amazingly unix and vms agree on all these */ -#define Heap_In_Low_Memory -#define UNSIGNED_SHIFT -#define CHAR_SIZE 8 -#define USHORT_SIZE 16 -#define ULONG_SIZE 32 -#define BELL '\007' -#define FASL_INTERNAL_FORMAT FASL_VAX -#define FLONUM_EXPT_SIZE 7 -#define FLONUM_MANTISSA_BITS 56 /* D format */ -#define MAX_FLONUM_EXPONENT 127 -#define HAS_FLOOR -#define HAS_FREXP - -/* Not on these, however */ - -#ifdef vms - -/* Pre version 4 VMS C has not void type, thus make it go away */ -/* #define void */ -/* Name conflict in VMS with system variable */ -#define Free Free_Register - -/* exit(0) produces horrible message on VMS */ - -#define NORMAL_EXIT 1 - -#define Exit_Scheme_Declarations static jmp_buf Exit_Point - -#define Init_Exit_Scheme() \ -{ \ - int Which_Way = setjmp(Exit_Point); \ - if (Which_Way == NORMAL_EXIT) \ - return; \ -} - -#define Exit_Scheme(value) \ -if (value != 0) \ - exit(value); \ -longjmp(Exit_Point, NORMAL_EXIT) - -#else /* not a vms */ - -/* Vax Unix C compiler bug */ - -#define double_into_fixnum(what, target) \ -{ \ - long For_Vaxes_Sake = ((long) what); \ - \ - target = Make_Non_Pointer(TC_FIXNUM, For_Vaxes_Sake); \ -} - -#endif /* not vms */ -#endif /* vax */ - -#ifdef hp9000s200 /* and s300, pretty indistinguishable */ -#define Heap_In_Low_Memory -#define UNSIGNED_SHIFT -#define CHAR_SIZE 8 -#define USHORT_SIZE 16 -#define ULONG_SIZE 32 -#define BELL '\007' -#define FASL_INTERNAL_FORMAT FASL_HP_9000_200 -#define FLONUM_EXPT_SIZE 10 -#define FLONUM_MANTISSA_BITS 53 -#define MAX_FLONUM_EXPONENT 1023 -#define HAS_FLOOR -#define HAS_FREXP -/* C compiler bug in GC_Type */ -#define term_type int -#endif - -#ifdef hp9000s500 -/* An unfortunate fact of life on this machine: - the C heap is in high memory thus Heap_In_Low_Memory is not - defined and the whole thing runs slowly. *Sigh* -*/ -#define UNSIGNED_SHIFT -#define CHAR_SIZE 8 -#define USHORT_SIZE 16 -#define ULONG_SIZE 32 -#define BELL '\007' -#define FASL_INTERNAL_FORMAT FASL_HP_9000_500 -#define FLONUM_EXPT_SIZE 10 -#define FLONUM_MANTISSA_BITS 53 -#define MAX_FLONUM_EXPONENT 1023 -#define HAS_FLOOR -#define HAS_FREXP - -/* C Compiler bug when constant folding and anchor pointing */ -#define And2(x, y) ((x) ? (y) : false) -#define And3(x, y, z) ((x) ? ((y) ? (z) : false) : false) -#define Or2(x, y) ((x) ? true : (y)) -#define Or3(x, y, z) ((x) ? true : ((y) ? true : (z))) -#endif - -#ifdef sun -#define Heap_In_Low_Memory -#define UNSIGNED_SHIFT -#define CHAR_SIZE 8 -#define USHORT_SIZE 16 -#define ULONG_SIZE 32 -#define BELL '\007' -#define FASL_INTERNAL_FORMAT FASL_SUN -#define FLONUM_EXPT_SIZE 7 -#define FLONUM_MANTISSA_BITS 56 -#define MAX_FLONUM_EXPONENT 127 -#define HAS_FLOOR -#define HAS_FREXP -#endif - -#ifdef butterfly -#define Heap_In_Low_Memory -#define CHAR_SIZE 8 -#define USHORT_SIZE 16 -#define ULONG_SIZE 32 -#define BELL '\007' -#define FASL_INTERNAL_FORMAT FASL_BFLY -#define FLONUM_EXPT_SIZE 7 -#define FLONUM_MANTISSA_BITS 56 -#define MAX_FLONUM_EXPONENT 127 -#include -#define HAS_FREXP -#define STACK_SIZE 4 /* 4K objects */ -#endif - -#ifdef cyber180 -/* Word size is 64 bits. */ -#define Heap_In_Low_Memory -#define CHAR_SIZE 8 -#define USHORT_SIZE ??? -#define ULONG_SIZE ??? -#define BELL '\007' -#define FASL_INTERNAL_FORMAT FASL_CYBER -#define FLONUM_EXPT_SIZE 14 -#define FLONUM_MANTISSA_BITS 48 -/* Not the full range, or so the manual says. */ -#define MAX_FLONUM_EXPONENT 4095 -/* The Cyber180 C compiler manifests a bug in hairy conditional - expressions */ -#define Conditional_Bug -#endif - -#ifdef celerity -#define Heap_In_Low_Memory -#define UNSIGNED_SHIFT -#define CHAR_SIZE 8 -#define USHORT_SIZE 16 -#define ULONG_SIZE 32 -#define BELL '\007' -#define FASL_INTERNAL_FORMAT FASL_CELERITY -#define FLONUM_EXPT_SIZE 11 -#define FLONUM_MANTISSA_BITS 53 -#define MAX_FLONUM_EXPONENT 2047 -#endif - -#ifdef spectrum -/* Heap resides in "Quad 1", and hence memory addresses have a 1 - in the second MSBit. This is taken care of in object.h, and is - still considered Heap_In_Low_Memory. -*/ -#define Heap_In_Low_Memory -#define UNSIGNED_SHIFT -#define CHAR_SIZE 8 -#define USHORT_SIZE 16 -#define ULONG_SIZE 32 -#define BELL '\007' -#define FASL_INTERNAL_FORMAT FASL_HP_SPECTRUM -#define FLONUM_EXPT_SIZE 10 -#define FLONUM_MANTISSA_BITS 53 -#define MAX_FLONUM_EXPONENT 1023 -#define FLOATING_ALIGNMENT 0x7 /* Low 3 MBZ for float storage */ -#define HAS_FLOOR -#define HAS_FREXP -#endif - -#ifdef umax -#define Heap_In_Low_Memory -#define UNSIGNED_SHIFT -#define CHAR_SIZE 8 -#define USHORT_SIZE 16 -#define ULONG_SIZE 32 -#define BELL '\007' -#define FASL_INTERNAL_FORMAT FASL_UMAX -#define FLONUM_EXPT_SIZE 10 -#define FLONUM_MANTISSA_BITS 53 -#define MAX_FLONUM_EXPONENT 1023 -#define HAS_FLOOR -#define HAS_FREXP -#endif - -/* Make sure that some definition applies. - If this error occurs, and the parameters of the - configuration are unknown, try the Wsize program. -*/ - -#ifndef CHAR_SIZE -#include "Error: config.h: Unknown configuration." -#endif - -#if (ULONG_SIZE == 32) -#define b32 -#endif - -/* Default "segment" sizes */ - -#ifndef STACK_SIZE -#ifndef USE_STACKLETS -#define STACK_SIZE 30 /* Default Kcells for stack */ -#else -#define STACK_SIZE 256 /* Default stacklet size */ -#endif -#endif -#ifndef CONSTANT_SIZE -#define CONSTANT_SIZE 180 /* Default Kcells for constant */ -#endif -#ifndef HEAP_SIZE -#define HEAP_SIZE 250 /* Default Kcells for each heap */ -#endif diff --git a/v7/src/microcode/const.h b/v7/src/microcode/const.h deleted file mode 100644 index 859795a83..000000000 --- a/v7/src/microcode/const.h +++ /dev/null @@ -1,170 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/const.h,v 9.24 1987/04/16 02:20:20 jinx Rel $ - * - * Named constants used throughout the interpreter - * - */ - -#if (CHAR_SIZE != 8) -#define MAX_CHAR ((1<= 0;) - *bucket++ = NIL; - - /* Now rehash all the entries from the unhash table and maybe splice - the buckets. */ - - for (counter = table_size, bucket = Nth_Vector_Loc(Arg1, 1); - --counter >= 0; - bucket += 1) - { if (Fast_Vector_Ref(*bucket, CONS_CAR) == TRUTH) - splice_and_rehash_bucket(Nth_Vector_Loc(*bucket, CONS_CDR), Arg2, table_size); - else - rehash_bucket(Nth_Vector_Loc(*bucket, CONS_CDR), Arg2, table_size); - } - - return TRUTH; -} diff --git a/v7/src/microcode/debug.c b/v7/src/microcode/debug.c deleted file mode 100644 index 27f455627..000000000 --- a/v7/src/microcode/debug.c +++ /dev/null @@ -1,733 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/debug.c,v 9.24 1987/04/16 02:20:42 jinx Rel $ - * - * Utilities to help with debugging - */ - -#include "scheme.h" -#include "primitive.h" -#include "trap.h" -#include "lookup.h" - -void Show_Pure() -{ Pointer *Obj_Address; - long Pure_Size, Total_Size; - - Obj_Address = Constant_Space; - while (true) - { if (Obj_Address > Free_Constant) - { printf("Past end of area.\n"); - return; - } - if (Obj_Address == Free_Constant) - { printf("Done.\n"); - return; - } - Pure_Size = Get_Integer(*Obj_Address); - Total_Size = Get_Integer(Obj_Address[1]); - printf("0x%x: pure=0x%x, total=0x%x\n", - Obj_Address, Pure_Size, Total_Size); - if (Type_Code(*Obj_Address) != TC_MANIFEST_SPECIAL_NM_VECTOR) - { printf("Missing initial SNMV.\n"); - return; - } - if (Type_Code(Obj_Address[1]) != PURE_PART) - printf("Missing subsequent pure header.\n"); - if (Type_Code(Obj_Address[Pure_Size-1]) != - TC_MANIFEST_SPECIAL_NM_VECTOR) - { printf("Missing internal SNMV.\n"); - return; - } - if (Type_Code(Obj_Address[Pure_Size]) != CONSTANT_PART) - { printf("Missing constant header.\n"); - return; - } - if (Get_Integer(Obj_Address[Pure_Size]) != Pure_Size) - printf("Pure size mismatch 0x%x.\n", - Get_Integer(Obj_Address[Pure_Size])); - if (Type_Code(Obj_Address[Total_Size-1]) != - TC_MANIFEST_SPECIAL_NM_VECTOR) - { printf("Missing ending SNMV.\n"); - return; - } - if (Type_Code(Obj_Address[Total_Size]) != END_OF_BLOCK) - { printf("Missing ending header.\n"); - return; - } - if (Get_Integer(Obj_Address[Total_Size]) != Total_Size) - printf("Total size mismatch 0x%x.\n", - Get_Integer(Obj_Address[Total_Size])); - Obj_Address += Total_Size+1; -#ifdef FLOATING_ALIGNMENT - while (*Obj_Address == Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0)) - Obj_Address += 1; -#endif - } -} - -void -Show_Env(The_Env) - Pointer The_Env; -{ - Pointer *name_ptr, procedure, *value_ptr, extension; - long count, i; - - procedure = Vector_Ref(The_Env, ENVIRONMENT_FUNCTION); - value_ptr = Nth_Vector_Loc(The_Env, ENVIRONMENT_FIRST_ARG); - - if (Type_Code(procedure) == AUX_LIST_TYPE) - { - extension = procedure; - procedure = Fast_Vector_Ref(extension, ENV_EXTENSION_PROCEDURE); - } - else - extension = NIL; - - if ((Type_Code(procedure) != TC_PROCEDURE) && - (Type_Code(procedure) != TC_EXTENDED_PROCEDURE)) - { - printf("Not created by a procedure"); - return; - } - name_ptr = Nth_Vector_Loc(procedure, PROCEDURE_LAMBDA_EXPR); - name_ptr = Nth_Vector_Loc(*name_ptr, LAMBDA_FORMALS); - count = Vector_Length(*name_ptr) - 1; - - name_ptr = Nth_Vector_Loc(*name_ptr, 2); - for (i = 0; i < count; i++) - { - Print_Expression(*name_ptr++, "Name "); - Print_Expression(*value_ptr++, " Value "); - printf("\n"); - } - if (extension != NIL) - { - printf("Auxilliary Variables\n"); - count = Get_Integer(Vector_Ref(extension, AUX_LIST_COUNT)); - for (i = 0, name_ptr = Nth_Vector_Loc(extension, AUX_LIST_FIRST); - i < count; - i++, name_ptr++) - { - Print_Expression(Vector_Ref(*name_ptr, CONS_CAR), - "Name "); - Print_Expression(Vector_Ref(*name_ptr, CONS_CAR), - " Value "); - printf("\n"); - } - } -} - -List_Print(Expr) -Pointer Expr; -{ int Count; - Count = 0; - printf("("); - while (((Type_Code(Expr) == TC_LIST) || - (Type_Code(Expr) == TC_WEAK_CONS)) - && Count < MAX_LIST_PRINT) - { Print_Expression(Vector_Ref(Expr, CONS_CAR), - (Type_Code(Expr)==TC_LIST) ? "" : "{weak}"); - Expr = Vector_Ref(Expr, CONS_CDR); - if (Type_Code(Expr) != TC_NULL) printf(" "); - Count += 1; - } - if (Type_Code(Expr) != TC_NULL) - { if (Count==MAX_LIST_PRINT) printf("..."); - else - { printf(". "); - Print_Expression(Expr, ""); - } - } - printf(")"); -} - -long Print_Return_Name(Ptr) -Pointer Ptr; -{ long index = Get_Integer(Ptr); - char *name; - if ((index <= MAX_RETURN) && - ((name = Return_Names[index]) != ((char *) NULL))) - printf("%s", name); - else - printf("[0x%x]", index); -} - -void Print_Return(String) -char *String; -{ printf("%s: ", String); - Print_Return_Name(Fetch_Return()); - CRLF(); -} - -extern Boolean Prt_PName(); - -void Print_Expression(Expr, String) -char *String; -Pointer Expr; -{ if (String[0] != 0) printf("%s: ", String); - Do_Printing(Expr, true); -} - -Do_Printing(Expr, Detailed) -Pointer Expr; -Boolean Detailed; -{ long Temp_Address; - Boolean Return_After_Print; - Temp_Address = Get_Integer(Expr); - Return_After_Print = false; - switch(Type_Code(Expr)) - { case TC_ACCESS: - printf("[ACCESS ("); - Expr = Vector_Ref(Expr, ACCESS_NAME); - goto SPrint; - - case TC_ASSIGNMENT: - printf("[SET! ("); - Expr = Vector_Ref(Vector_Ref(Expr, ASSIGN_NAME), - VARIABLE_SYMBOL); - goto SPrint; - - case TC_CHARACTER_STRING: - { long Length, i; - char *Next, This; - printf("\""); - Length = Get_Integer(Vector_Ref(Expr, STRING_LENGTH)); - Next = (char *) Nth_Vector_Loc(Expr, STRING_CHARS); - for (i=0; i < Length; i++) - { This = *Next++; - printf((This < ' ') || (This > '|') ? "\\%03o" : "%c", - This); - } - printf("\""); - return; - } - -/* Do_Printing continues on the next page */ - -/* Do_Printing, continued */ - - case TC_DEFINITION: - printf("[DEFINE ("); - Expr = Vector_Ref(Expr, DEFINE_NAME); - goto SPrint; - - case TC_FIXNUM: - { long A; - Sign_Extend(Expr, A); - printf("%d", A); - return; - } - - case TC_BIG_FLONUM: printf("%f", Get_Float(Expr)); return; - - case TC_WEAK_CONS: - case TC_LIST: List_Print(Expr); return; - - case TC_NULL: - if (Temp_Address==0) - { printf("()"); - return; - } - printf("[NULL"); - break; - -/* Do_Printing continues on the next page */ - -/* Do_Printing, continued */ - - case TC_UNINTERNED_SYMBOL: - printf("[UNINTERNED_SYMBOL ("); goto SPrint; - - case TC_INTERNED_SYMBOL: - { Pointer Name; - char *Next_Char; - long Length, i; - Return_After_Print = true; -SPrint: - Name = Vector_Ref(Expr, SYMBOL_NAME); - Length = Get_Integer(Vector_Ref(Name, STRING_LENGTH)); - Next_Char = (char *) Nth_Vector_Loc(Name, STRING_CHARS); - for (i=0; i < Length; i++) - printf("%c", *Next_Char++); - if (Return_After_Print) return; - printf(")"); - break; - } - -/* Do_Printing continues on the next page */ - -/* Do_Printing, continued */ - - case TC_VARIABLE: - if (Detailed) printf("[VARIABLE ("); - Expr = Vector_Ref(Expr, VARIABLE_SYMBOL); - if (!Detailed) Return_After_Print = true; - goto SPrint; - - case TC_BIG_FIXNUM: printf("[BIG_FIXNUM"); break; - case TC_BROKEN_HEART: printf("[BROKEN_HEART"); break; - case TC_CHARACTER: printf("[CHARACTER"); break; - case TC_COMBINATION: - printf("[COMBINATION (%d args) 0x%x]", - Vector_Length(Expr)-1, Temp_Address); - if (Detailed) - { printf(" ("); - Do_Printing(Vector_Ref(Expr, COMB_FN_SLOT), false); - printf(" ...)"); - } - return; - case TC_COMBINATION_1: - printf("[COMBINATION_1 0x%x]", Temp_Address); - if (Detailed) - { printf(" ("); - Do_Printing(Vector_Ref(Expr, COMB_1_FN), false); - printf(", "); - Do_Printing(Vector_Ref(Expr, COMB_1_ARG_1), false); - printf(")"); - } - return; - -/* Do_Printing continues on the next page */ - -/* Do_Printing, continued */ - - case TC_COMBINATION_2: - printf("[COMBINATION_2 0x%x]", Temp_Address); - if (Detailed) - { printf(" ("); - Do_Printing(Vector_Ref(Expr, COMB_2_FN), false); - printf(", "); - Do_Printing(Vector_Ref(Expr, COMB_2_ARG_1), false); - printf(", "); - Do_Printing(Vector_Ref(Expr, COMB_2_ARG_2), false); - printf(")"); - } - return; - case TC_CELL: printf("[CELL"); break; - case TC_COMMENT: printf("[COMMENT"); break; - case TC_COMPILED_EXPRESSION: printf("[COMPILED_EXPRESSION"); break; - case TC_COMPILED_PROCEDURE: - printf("[COMPILED_PROCEDURE"); break; - case TC_CONDITIONAL: printf("[CONDITIONAL"); break; - case TC_CONTROL_POINT: printf("[CONTROL_POINT"); break; - case TC_DELAY: printf("[DELAY"); break; - case TC_DELAYED: printf("[DELAYED"); break; - case TC_DISJUNCTION: printf("[DISJUNCTION"); break; - case TC_ENVIRONMENT: - { - Pointer procedure; - - printf("[ENVIRONMENT 0x%x]", Temp_Address); - printf(" (from "); - procedure = Vector_Ref(Expr, ENVIRONMENT_FUNCTION); - if (Type_Code(procedure) == TC_QUAD) - procedure = Vector_Ref(procedure, ENV_EXTENSION_PROCEDURE); - Do_Printing(procedure, false); - printf(")"); - return; - } - case TC_EXTENDED_LAMBDA: - if (Detailed) printf("[EXTENDED_LAMBDA ("); - Do_Printing( - Vector_Ref( - Vector_Ref(Expr, ELAMBDA_NAMES), - 1), false); - if (Detailed) printf(") 0x%x", Temp_Address); - return; - case TC_EXTENDED_PROCEDURE: - if (Detailed) printf("[EXTENDED_PROCEDURE ("); - Do_Printing(Vector_Ref(Expr, PROCEDURE_LAMBDA_EXPR), false); - if (Detailed) printf(") 0x%x]", Temp_Address); - break; - -/* Do_Printing continues on the next page */ - -/* Do_Printing, continued */ - - case TC_FUTURE: printf("[FUTURE"); break; - case TC_HUNK3: printf("[TRIPLE"); break; - case TC_IN_PACKAGE: printf("[IN_PACKAGE"); break; - case TC_LAMBDA: - if (Detailed) printf("[LAMBDA ("); - Do_Printing( - Vector_Ref( - Vector_Ref(Expr, LAMBDA_FORMALS), - 1), false); - if (Detailed) printf(") 0x%x]", Temp_Address); - return; - case TC_LEXPR: printf("[LEXPR"); break; - case TC_MANIFEST_NM_VECTOR: printf("[MANIFEST_NM_VECTOR"); break; - case TC_MANIFEST_SPECIAL_NM_VECTOR: - printf("[MANIFEST_SPECIAL_NM_VECTOR"); break; - case TC_NON_MARKED_VECTOR: printf("[NON_MARKED_VECTOR"); break; - case TC_PCOMB0: printf("[PCOMB0"); break; - case TC_PCOMB1: printf("[PCOMB1"); break; - case TC_PCOMB2: printf("[PCOMB2"); break; - case TC_PCOMB3: printf("[PCOMB3"); break; - case TC_PRIMITIVE: - printf("[PRIMITIVE "); Prt_PName(Temp_Address); - printf("]"); return; - case TC_PRIMITIVE_EXTERNAL: printf("[PRIMITIVE_EXTERNAL"); break; - case TC_PROCEDURE: - if (Detailed) printf("[PROCEDURE ("); - Do_Printing(Vector_Ref(Expr, PROCEDURE_LAMBDA_EXPR), false); - if (Detailed) printf(") 0x%x]", Temp_Address); - return; - -/* Do_Printing continues on the next page */ - -/* Do_Printing, continued */ - - case TC_QUAD: printf("[QUAD"); break; - case TC_REFERENCE_TRAP: - { - printf("[REFERENCE-TRAP"); - if (Datum(Expr) <= TRAP_MAX_IMMEDIATE) - break; - Print_Expression(Vector_Ref(Expr, TRAP_TAG), " tag"); - Print_Expression(Vector_Ref(Expr, TRAP_EXTRA), " extra"); - printf("]"); - return; - } - case TC_RETURN_CODE: - printf("[RETURN_CODE "); - Print_Return_Name(Expr); - printf("]"); - return; - case TC_SCODE_QUOTE: printf("[SCODE_QUOTE"); break; - case TC_SEQUENCE_2: printf("[SEQUENCE_2"); break; - case TC_SEQUENCE_3: printf("[SEQUENCE_3"); break; - case TC_THE_ENVIRONMENT: printf("[THE_ENVIRONMENT"); break; - case TC_TRUE: - if (Temp_Address == 0) - { printf("#!true"); - return; - } - printf("[TRUE"); - break; - case TC_VECTOR: printf("[VECTOR"); break; - case TC_VECTOR_16B: printf("[VECTOR_16B"); break; - case TC_VECTOR_1B: printf("[VECTOR_1B"); break; - default: printf("[0x%x", Type_Code(Expr)); - } - printf(" 0x%x]", Temp_Address); -} - -Boolean -Print_One_Continuation_Frame(Temp) - Pointer Temp; -{ - Pointer Expr; - - Print_Expression(Temp, "Return code"); - CRLF(); - Expr = Pop(); - Print_Expression(Expr, "Expression"); - printf("\n"); - if ((Datum(Temp) == RC_END_OF_COMPUTATION) || - (Datum(Temp) == RC_HALT)) return true; - if (Datum(Temp) == RC_JOIN_STACKLETS) - Stack_Pointer = Previous_Stack_Pointer(Expr); - return false; -} - -/* Back_Trace relies on (a) only a call to Save_Cont puts a return code on the - stack; (b) Save_Cont pushes the expression first. */ - -void -Back_Trace() -{ - Pointer Temp, *Old_Stack; - - Back_Trace_Entry_Hook(); - Old_Stack = Stack_Pointer; - while (true) - { if (Return_Hook_Address == &Top_Of_Stack()) - { Temp = Pop(); - if (Temp != Make_Non_Pointer(TC_RETURN_CODE, RC_RETURN_TRAP_POINT)) - printf("\n--> Return trap is missing here <--\n"); - else - { printf("\n[Return trap found here as expected]\n"); - Temp = Old_Return_Code; - } - } - else Temp = Pop(); - if (Type_Code(Temp) == TC_RETURN_CODE) - { if (Print_One_Continuation_Frame(Temp)) - break; - } - else - { Print_Expression(Temp, " ..."); - if (Type_Code(Temp) == TC_MANIFEST_NM_VECTOR) - { Stack_Pointer = Simulate_Popping(Get_Integer(Temp)); - printf(" (skipping)"); - } - printf("\n"); - } - } - Stack_Pointer = Old_Stack; - Back_Trace_Exit_Hook(); -} - -void -Print_Stack(SP) - Pointer *SP; -{ - Pointer *Saved_SP; - - Saved_SP = Stack_Pointer; - Stack_Pointer = SP; - Back_Trace(); - Stack_Pointer = Saved_SP; - return; -} - -Boolean -Prt_PName(Number) - long Number; -{ - extern char *primitive_to_name(); - char *name; - - name = primitive_to_name(Number); - if (name == ((char *) NULL)) - { - printf("Unknown primitive 0x%08x", Number); - return false; - } - else - { - printf("%s", name); - return true; - } -} - -void Print_Primitive(Number) - long Number; -{ - - extern long primitive_to_arity(); - char buffer1[40], buffer2[40]; - int NArgs, i; - - printf("Primitive: "); - if (Prt_PName(Number)) - NArgs = primitive_to_arity(Number); - else - NArgs = 3; /* Unknown primitive */ - printf("\n"); - - for (i = 0; i < NArgs; i++) - { - sprintf(buffer1, "Stack_Ref(%d)", i); - sprintf(buffer2, "...Arg %d", (i + 1)); - Print_Expression(buffer1, buffer2); - printf("\n"); - } -} - -Debug_Printer(Expr) -Pointer Expr; -{ Print_Expression(Expr, ""); - putchar('\n'); -} - -/* (DEBUGGING-PRINTER OBJECT) - A cheap, built-in printer intended for debugging the - interpreter. -*/ -Built_In_Primitive(Prim_Temp_Printer, 1, "DEBUGGING-PRINTER", 0xB2) -{ - Primitive_1_Arg(); - - Debug_Printer(Arg1); - return TRUTH; -} - -/* Code for interactively setting and clearing the interpreter - debugging flags. Invoked via the "D" command to the ^B - handler or during each FASLOAD. -*/ - -#ifdef ENABLE_DEBUGGING_TOOLS -#define D_EVAL 0 -#define D_HEX_INPUT 1 -#define D_FILE_LOAD 2 -#define D_RELOC 3 -#define D_INTERN 4 -#define D_CONT 5 -#define D_PRIMITIVE 6 -#define D_LOOKUP 7 -#define D_DEFINE 8 -#define D_GC 9 -#define D_UPGRADE 10 -#define D_DUMP 11 -#define D_TRACE_ON_ERROR 12 -#define D_PER_FILE 13 -#define D_BIGNUM 14 -#define D_FLUIDS 15 -#define LAST_NORMAL_SWITCH 15 - -Boolean *Find_Flag(Num) -int Num; -{ switch (Num) - { case D_EVAL: return &Eval_Debug; - case D_HEX_INPUT: return &Hex_Input_Debug; - case D_FILE_LOAD: return &File_Load_Debug; - case D_RELOC: return &Reloc_Debug; - case D_INTERN: return &Intern_Debug; - case D_CONT: return &Cont_Debug; - case D_PRIMITIVE: return &Primitive_Debug; - case D_LOOKUP: return &Lookup_Debug ; - case D_DEFINE: return &Define_Debug; - case D_GC: return &GC_Debug; - case D_UPGRADE: return &Upgrade_Debug; - case D_DUMP: return &Dump_Debug; - case D_TRACE_ON_ERROR: return &Trace_On_Error; - case D_PER_FILE: return &Per_File; - case D_BIGNUM: return &Bignum_Debug; - case D_FLUIDS: return &Fluids_Debug; - More_Debug_Flag_Cases(); - default: show_flags(true); return NULL; - } -} - -set_flag(Num, Value) -int Num; -Boolean Value; -{ Boolean *Flag = Find_Flag(Num); - if (Flag != NULL) *Flag = Value; - Set_Flag_Hook(); -} - -char *Flag_Name(Num) -int Num; -{ switch(Num) - { case D_EVAL: return "Eval_Debug"; - case D_HEX_INPUT: return "Hex_Input_Debug"; - case D_FILE_LOAD: return "File_Load_Debug"; - case D_RELOC: return "Reloc_Debug"; - case D_INTERN: return "Intern_Debug"; - case D_CONT: return "Cont_Debug"; - case D_PRIMITIVE: return "Primitive_Debug"; - case D_LOOKUP: return "Lookup_Debug"; - case D_DEFINE: return "Define_Debug"; - case D_GC: return "GC_Debug"; - case D_UPGRADE: return "Upgrade_Debug"; - case D_DUMP: return "Dump_Debug"; - case D_TRACE_ON_ERROR: return "Trace_On_Error"; - case D_PER_FILE: return "Per_File"; - case D_BIGNUM: return "Bignum_Debug"; - case D_FLUIDS: return "Fluids_Debug"; - More_Debug_Flag_Names(); - default: return "Unknown Debug Flag"; - } -} - -show_flags(All) -Boolean All; -{ int i; - for (i=0; i <= LAST_SWITCH; i++) - { Boolean Value = *Find_Flag(i); - if (All || Value) - { printf("Flag %d (%s) is %s.\n", - i, Flag_Name(i), Value? "set" : "clear"); - } - } -} - -extern int OS_tty_tyi(); - -#define C_STRING_LENGTH 256 - -void Handle_Debug_Flags() -{ char c, input_string[C_STRING_LENGTH]; - int Which, free; - Boolean interrupted; - show_flags(false); - while (true) - { interrupted = false; - printf("Clear, Set, Done, ?, or Halt: "); - OS_Flush_Output_Buffer(); - - /* Considerably haired up to go through standard (safe) interface */ - - c = (char) OS_tty_tyi(false, &interrupted); - if (interrupted) return; - for (free = 0; free < C_STRING_LENGTH; free++) - { input_string[free] = OS_tty_tyi(false, &interrupted); - if (interrupted) return; - if (input_string[free] == '\n') - { input_string[free] = '\0'; - break; - } - } - -/* Handle_Debug_Flags continues on the next page */ - -/* Handle_Debug_Flags, continued */ - - switch (c) - { case 'c': - case 'C': Which=debug_getdec(input_string); - set_flag(Which, false); - break; - case 's': - case 'S': Which=debug_getdec(input_string); - set_flag(Which, true); - break; - case 'd': - case 'D': return; - case 'h': - case 'H': Microcode_Termination(TERM_HALT); - - case '?': - default : show_flags(true); - break; - } - } -} - -int normal_debug_getdec(str) -{ int Result; - sscanf(str, "%d", &Result); - return Result; -} - -#else /* ENABLE_DEBUGGING_TOOLS */ -void Handle_Debug_Flags() -{ fprintf(stderr, "Not a debugging version. No flags to handle.\n"); - return; -} -#endif /* not ENABLE_DEBUGGING_TOOLS */ diff --git a/v7/src/microcode/default.h b/v7/src/microcode/default.h deleted file mode 100644 index 745ea61e3..000000000 --- a/v7/src/microcode/default.h +++ /dev/null @@ -1,295 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/default.h,v 9.22 1987/04/16 02:20:58 jinx Exp $ - * - * This file contains default definitions for some hooks which - * various machines require. These machines define these hooks - * in CONFIG.H and this file defines them only if they remain - * undefined. - * - */ - -/* Compiler bug fixes. */ - -#ifndef And2 -#define And2(x, y) ((x) && (y)) -#define And3(x, y, z) ((x) && (y) && (z)) -#define Or2(x, y) ((x) || (y)) -#define Or3(x, y, z) ((x) || (y) || (z)) -#endif - -#ifndef Fetch -/* These definitions allow a true multi-processor with shared memory - but no atomic longword operations (Butterfly and Concert, - for example) to supply their own atomic operators in config.h. -*/ -#define Fetch(P) (P) -#define Store(P, S) (P) = (S) -#endif - -#ifndef Get_Fixed_Obj_Slot -#define Get_Fixed_Obj_Slot(N) Fast_User_Vector_Ref(Fixed_Objects, N) -#define Set_Fixed_Obj_Slot(N,S) Fast_User_Vector_Set(Fixed_Objects, N, S) -#define Update_FObj_Slot(N, S) Set_Fixed_Obj_Slot(N, S) -#define Declare_Fixed_Objects() Pointer Fixed_Objects; -#define Valid_Fixed_Obj_Vector() \ - (Type_Code(Fixed_Objects) == TC_VECTOR) -#define Save_Fixed_Obj(Save_FO) \ - Save_FO = Fixed_Objects; \ - Fixed_Objects = NIL; -#define Restore_Fixed_Obj(Save_FO) \ - Fixed_Objects = Save_FO -#endif - - -/* Atomic swapping hook. Used extensively. */ - -#ifndef Swap_Pointers -extern Pointer Swap_Temp; -#define Swap_Pointers(P, S) \ -(Swap_Temp = *(P), *(P) = (S), Swap_Temp) -#endif - -#ifndef Set_Pure_Top -#ifndef USE_STACKLETS -#define Set_Pure_Top() \ - Align_Float(Free_Constant); \ - Set_Stack_Guard(Free_Constant+STACK_GUARD_SIZE) -#define Test_Pure_Space_Top(New_Top) \ - ((New_Top+STACK_GUARD_SIZE) <= Stack_Pointer) -#define Absolute_Stack_Base Free_Constant - -#ifndef Initialize_Stack -#define Initialize_Stack() \ - Stack_Top = Highest_Allocated_Address; \ - Stack_Pointer = Stack_Top; \ - Set_Stack_Guard(Free_Constant + STACK_GUARD_SIZE) -#endif - -#else /* Stacklets in use */ - -#define Set_Pure_Top() Align_Float(Free_Constant) -#define Test_Pure_Space_Top(New_Top) \ - (New_Top <= Highest_Allocated_Address) -#endif -#endif - -/* Character IO hooks. Used extensively. */ - -#ifndef OS_Put_C -#define OS_Put_C putc -#endif - -#ifndef OS_Get_C -#define OS_Get_C getc -#endif - -/* Used in BOOT.C */ - -#ifndef term_type -#define term_type void -#endif - -#ifndef Command_Line_Hook -#define Command_Line_Hook() -#endif - -#ifndef Exit_Scheme_Declarations -#define Exit_Scheme_Declarations -#endif - -#ifndef Init_Exit_Scheme -#define Init_Exit_Scheme() -#endif - -#ifndef Exit_Scheme -#define Exit_Scheme exit -#endif - -/* Used in various places. */ - -#ifndef Init_Fixed_Objects -#define Init_Fixed_Objects() \ - Default_Init_Fixed_Objects(Fixed_Objects) -#endif - -#ifndef Set_Fixed_Obj_Hook -#define Set_Fixed_Obj_Hook(New_Vector) \ - Fixed_Objects = New_Vector -#endif - -#ifndef Entry_Hook -#define Entry_Hook() -#endif - -#ifndef Exit_Hook -#define Exit_Hook() -#endif - -#ifndef Sys_Clock -#define Sys_Clock() System_Clock() -#endif - -/* Used in DEBUG.C */ - -#ifndef Back_Trace_Entry_Hook -#define Back_Trace_Entry_Hook() -#endif - -#ifndef Back_Trace_Exit_Hook -#define Back_Trace_Exit_Hook() -#endif - -#ifndef More_Debug_Flag_Cases -#define More_Debug_Flag_Cases() -#endif - -#ifndef Set_Flag_Hook -#define Set_Flag_Hook() -#endif - -#ifndef More_Debug_Flag_Names -#define More_Debug_Flag_Names() -#endif - -#ifndef LAST_SWITCH -#define LAST_SWITCH LAST_NORMAL_SWITCH -#endif - -#ifndef debug_getdec -#define debug_getdec normal_debug_getdec -#endif - -/* Used in EXTERN.H */ - -#ifndef More_Debug_Flag_Externs -#define More_Debug_Flag_Externs() -#endif - -/* Used in FASDUMP.C */ - -#ifndef Band_Dump_Permitted -#define Band_Dump_Permitted() -#endif - -#ifndef Band_Load_Hook -#define Band_Load_Hook() -#endif - -#ifndef Fasdump_Exit_Hook -#define Fasdump_Exit_Hook() -#endif - -#ifndef Fasdump_Free_Calc -#define Fasdump_Free_Calc(NewFree, NewMemtop, ignored) \ - NewFree = Unused_Heap; \ - NewMemTop = Unused_Heap_Top -#endif - -/* Used in FASLOAD.C */ - -#ifndef Open_File_Hook -#define Open_File_Hook(ignore) -#endif - -#ifndef Close_File_Hook -#define Close_File_Hook() -#endif - -/* Used in FLONUM.H and GENERIC.C */ - -#ifndef double_into_fixnum -#define double_into_fixnum(what, target) \ - target = Make_Non_Pointer(TC_FIXNUM, ((long) (what))) -#endif - -/* Used in INTERPRET.C */ - -/* Primitive calling code. */ - -#ifndef ENABLE_DEBUGGING_TOOLS -#define Apply_Primitive(N) Internal_Apply_Primitive(N) -#else -extern Pointer Apply_Primitive(); -#endif - -#ifndef Metering_Apply_Primitive -#define Metering_Apply_Primitive(Loc, N) \ -Loc = Apply_Primitive(N) -#endif - -#ifndef Eval_Ucode_Hook() -#define Eval_Ucode_Hook() -#endif - -#ifndef Pop_Return_Ucode_Hook() -#define Pop_Return_Ucode_Hook() -#endif - -#ifndef Apply_Ucode_Hook() -#define Apply_Ucode_Hook() -#endif - -#ifndef End_GC_Hook -#define End_GC_Hook() -#endif - -/* Used in STORAGE.C */ - -#ifndef More_Debug_Flag_Allocs -#define More_Debug_Flag_Allocs() -#endif - -/* Used in UTILS.C */ - -#ifndef Global_Interrupt_Hook -#define Global_Interrupt_Hook() -#endif - -#ifndef Error_Exit_Hook -#define Error_Exit_Hook() -#endif - -/* Used in LOOKUP.C */ - -/* Permit caching of incrementally defined variables */ -#ifndef Allow_Aux_Compilation -#define Allow_Aux_Compilation true -#endif - -/* This is how we support future numbering for external metering */ -#ifndef New_Future_Number -#define New_Future_Number() NIL -#else -Pointer Get_New_Future_Number(); -#endif diff --git a/v7/src/microcode/dmpwrld.c b/v7/src/microcode/dmpwrld.c deleted file mode 100644 index 43040560a..000000000 --- a/v7/src/microcode/dmpwrld.c +++ /dev/null @@ -1,246 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dmpwrld.c,v 9.24 1987/04/16 02:21:08 jinx Exp $ - * - * This file contains a primitive to dump an executable version of Scheme. - * It uses unexec.c from GNU Emacs. - * Look at unexec.c for more information. - */ - -#include "scheme.h" -#include "primitive.h" - -#ifndef unix -#include "Error: dumpworld.c does not work on non-unix machines." -#endif - -/* Compatibility definitions for GNU Emacs's unexec.c. - Taken from the various m-*.h and s-*.h files for GNU Emacs. -*/ - -#ifdef vax -#define UNEXEC_AVAILABLE -#endif - -#ifdef hp9000s200 -#define UNEXEC_AVAILABLE -#define ADJUST_EXEC_HEADER \ - hdr.a_magic = ((ohdr.a_magic.file_type == OLDMAGIC.file_type) ? \ - NEWMAGIC : ohdr.a_magic); - -#endif - -#ifdef sun3 -#define UNEXEC_AVAILABLE -#define SEGMENT_MASK (SEGSIZ - 1) -#define A_TEXT_OFFSET(HDR) sizeof (HDR) -#define TEXT_START (PAGSIZ + (sizeof(struct exec))) -#endif - -/* I haven't tried any below this point. */ - -#if defined(umax) -#define UNEXEC_AVAILABLE -#define HAVE_GETPAGESIZE -#define COFF -#define UMAX -#define SECTION_ALIGNMENT pagemask -#define SEGMENT_MASK (64 * 1024 - 1) -#endif - -#ifdef celerity -#define UNEXEC_AVAILABLE -#endif - -#ifdef sun2 -#define UNEXEC_AVAILABLE -#define SEGMENT_MASK (SEGSIZ - 1) -#endif - -#ifndef UNEXEC_AVAILABLE -#include "Error: dumpworld.c only works on a few machines." -#endif - -#ifndef TEXT_START -#define TEXT_START 0 -#endif - -#ifndef SEGMENT_MASK -#define DATA_START (&etext) -#else -#define DATA_START \ -(((((unsigned) &etext) - 1) & ~SEGMENT_MASK) + (SEGMENT_MASK + 1)) -#endif - -#ifdef hpux -#define USG -#define HPUX -#endif - -/* More compatibility definitions for unexec. */ - -extern int end, etext, edata; -char *start_of_text(), *start_of_data(); -void bzero(); - -#include "unexec.c" - -char -*start_of_text() -{ - return ((char *) TEXT_START); -} - -char -*start_of_data() -{ - return ((char *) DATA_START); -} - -void -bzero (b, length) - register char *b; - register int length; -{ - while (length-- > 0) - *b++ = 0; -} - -/* Making sure that IO will be alright when restored. */ - -Boolean -there_are_open_files() -{ - register int i; - - i = FILE_CHANNELS; - while (i > 0) - if (Channels[--i] != NULL) return true; - return false; -} - -/* These two procedures depend on the internal structure of a - FILE object. See /usr/include/stdio.h for details. */ - -long -Save_Input_Buffer() -{ - long result; - - result = (stdin)->_cnt; - (stdin)->_cnt = 0; - return result; -} - -void -Restore_Input_Buffer(Buflen) - fast long Buflen; -{ - (stdin)->_cnt = Buflen; - return; -} - -/* The primitive visible from Scheme. */ - -extern Boolean Was_Scheme_Dumped; -extern unix_find_pathname(); - -Define_Primitive(Prim_Dump_World, 1, "DUMP-WORLD") -{ - char *fname, path_buffer[FILE_NAME_LENGTH]; - Boolean Saved_Dumped_Value, Saved_Photo_Open; - int Result; - long Buflen; - Primitive_1_Arg(); - - Arg_1_Type(TC_CHARACTER_STRING); - - if (there_are_open_files()) - Primitive_Error(ERR_OUT_OF_FILE_HANDLES); - - fname = Scheme_String_To_C_String(Arg1); - - /* Set up for restore */ - - Saved_Dumped_Value = Was_Scheme_Dumped; - Saved_Photo_Open = Photo_Open; - - /* IO: flushing pending output, and flushing cached input. */ - - fflush(stdout); - fflush(stderr); - - if (Photo_Open) - { - fflush(Photo_File_Handle); - Photo_Open = false; - } - - Buflen = Save_Input_Buffer(); - - Was_Scheme_Dumped = true; - Val = TRUTH; - OS_Quit(); - Pop_Primitive_Frame(1); - - /* Dump! */ - - unix_find_pathname(Saved_argv[0], path_buffer); - Result = unexec(fname, - path_buffer, - ((unsigned) 0), /* default */ - ((unsigned) 0), /* default */ - ((unsigned) start_of_text()) - ); - - /* Restore State */ - - OS_Re_Init(); - Val = NIL; - Was_Scheme_Dumped = Saved_Dumped_Value; - - /* IO: Restoring cached input for this job. */ - - Restore_Input_Buffer(Buflen); - Photo_Open = Saved_Photo_Open; - - if (Result != 0) - { - Push(Arg1); /* Since popped above */ - Primitive_Error(ERR_EXTERNAL_RETURN); - } - - longjmp(*Back_To_Eval, PRIM_POP_RETURN); - /*NOTREACHED*/ -} - diff --git a/v7/src/microcode/dump.c b/v7/src/microcode/dump.c deleted file mode 100644 index 569de1df9..000000000 --- a/v7/src/microcode/dump.c +++ /dev/null @@ -1,85 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dump.c,v 9.22 1987/04/03 00:11:11 jinx Exp $ - * - * This file contains common code for dumping internal format binary files. - */ - -#include "fasl.h" - -Write_File(Heap_Count, Heap_Relocation, Dumped_Object, - Constant_Count, Constant_Relocation, Prim_Exts) -Pointer *Heap_Relocation, *Dumped_Object, - *Constant_Relocation, *Prim_Exts; -long Heap_Count, Constant_Count; -{ Pointer Buffer[FASL_HEADER_LENGTH]; - long i; - -#ifdef DEBUG -#ifndef Heap_In_Low_Memory - fprintf(stderr, "\nMemory_Base = 0x%x\n", Memory_Base); -#endif - fprintf(stderr, "\nHeap_Relocation=0x%x, dumped as 0x%x\n", - Heap_Relocation, Make_Pointer(TC_BROKEN_HEART, Heap_Relocation)); - fprintf(stderr, "\nDumped object=0x%x, dumped as 0x%x\n", - Dumped_Object, Make_Pointer(TC_BROKEN_HEART, Dumped_Object)); -#endif - Buffer[FASL_Offset_Marker] = FASL_FILE_MARKER; - Buffer[FASL_Offset_Heap_Count] = - Make_Non_Pointer(TC_BROKEN_HEART, Heap_Count); - Buffer[FASL_Offset_Heap_Base] = - Make_Pointer(TC_BROKEN_HEART, Heap_Relocation); - Buffer[FASL_Offset_Dumped_Obj] = - Make_Pointer(TC_BROKEN_HEART, Dumped_Object); - Buffer[FASL_Offset_Const_Count] = - Make_Non_Pointer(TC_BROKEN_HEART, Constant_Count); - Buffer[FASL_Offset_Const_Base] = - Make_Pointer(TC_BROKEN_HEART, Constant_Relocation); - Buffer[FASL_Offset_Version] = - Make_Version(FASL_FORMAT_VERSION, - FASL_SUBVERSION, FASL_INTERNAL_FORMAT); - Buffer[FASL_Offset_Stack_Top] = -#ifdef USE_STACKLETS - Make_Pointer(TC_BROKEN_HEART, 0); /* Nothing in stack area */ -#else - Make_Pointer(TC_BROKEN_HEART, Stack_Top); -#endif - Buffer[FASL_Offset_Ext_Loc] = - Make_Pointer(TC_BROKEN_HEART, Prim_Exts); - for (i=FASL_Offset_First_Free; i < FASL_HEADER_LENGTH; i++) - Buffer[i] = NIL; - Write_Data(FASL_HEADER_LENGTH, (char *) Buffer); - if (Heap_Count != 0) Write_Data(Heap_Count, (char *) Heap_Relocation); - if (Constant_Count != 0) - Write_Data(Constant_Count, (char *) Constant_Relocation); -} diff --git a/v7/src/microcode/errors.h b/v7/src/microcode/errors.h deleted file mode 100644 index 611b7bacd..000000000 --- a/v7/src/microcode/errors.h +++ /dev/null @@ -1,128 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/errors.h,v 9.24 1987/04/03 00:11:24 jinx Rel $ - * - * Error and termination code declarations. This must correspond - * to UTABMD.SCM - * - */ - -/* All error and termination codes must be positive - * to allow primitives to return either an error code - * or a primitive flow control value (see CONST.H) - */ - -#define ERR_BAD_ERROR_CODE 0x00 -#define ERR_UNBOUND_VARIABLE 0x01 -#define ERR_UNASSIGNED_VARIABLE 0x02 -#define ERR_INAPPLICABLE_OBJECT 0x03 -/* #define ERR_OUT_OF_HASH_NUMBERS 0x04 */ -/* #define ERR_ENVIRONMENT_CHAIN_TOO_DEEP 0x05 */ -#define ERR_BAD_FRAME 0x06 -#define ERR_BROKEN_COMPILED_VARIABLE 0x07 -#define ERR_UNDEFINED_USER_TYPE 0x08 -#define ERR_UNDEFINED_PRIMITIVE 0x09 -#define ERR_EXTERNAL_RETURN 0x0A -#define ERR_EXECUTE_MANIFEST_VECTOR 0x0B -#define ERR_WRONG_NUMBER_OF_ARGUMENTS 0x0C -#define ERR_ARG_1_WRONG_TYPE 0x0D -#define ERR_ARG_2_WRONG_TYPE 0x0E -#define ERR_ARG_3_WRONG_TYPE 0x0F -#define ERR_ARG_1_BAD_RANGE 0x10 -#define ERR_ARG_2_BAD_RANGE 0x11 -#define ERR_ARG_3_BAD_RANGE 0x12 -/* #define ERR_BAD_COMBINATION 0x13 */ -/* #define ERR_FASDUMP_OVERFLOW 0x14 */ -#define ERR_BAD_INTERRUPT_CODE 0x15 /* Not generated */ -/* #define ERR_NO_ERRORS 0x16 */ -#define ERR_FASL_FILE_TOO_BIG 0x17 -#define ERR_FASL_FILE_BAD_DATA 0x18 -#define ERR_IMPURIFY_OUT_OF_SPACE 0x19 - -/* The following do not exist in the 68000 version */ -#define ERR_WRITE_INTO_PURE_SPACE 0x1A -/* #define ERR_LOSING_SPARE_HEAP 0x1B */ -/* #define ERR_NO_HASH_TABLE 0x1C */ -#define ERR_BAD_SET 0x1D -#define ERR_ARG_1_FAILED_COERCION 0x1E -#define ERR_ARG_2_FAILED_COERCION 0x1F -#define ERR_OUT_OF_FILE_HANDLES 0x20 -/* #define ERR_SHELL_DIED 0x21 */ - -/* Late additions to both 68000 and C world */ -#define ERR_ARG_4_BAD_RANGE 0x22 -#define ERR_ARG_5_BAD_RANGE 0x23 -#define ERR_ARG_6_BAD_RANGE 0x24 -#define ERR_ARG_7_BAD_RANGE 0x25 -#define ERR_ARG_8_BAD_RANGE 0x26 -#define ERR_ARG_9_BAD_RANGE 0x27 -#define ERR_ARG_10_BAD_RANGE 0x28 -#define ERR_ARG_4_WRONG_TYPE 0x29 -#define ERR_ARG_5_WRONG_TYPE 0x2A -#define ERR_ARG_6_WRONG_TYPE 0x2B -#define ERR_ARG_7_WRONG_TYPE 0x2C -#define ERR_ARG_8_WRONG_TYPE 0x2D -#define ERR_ARG_9_WRONG_TYPE 0x2E -#define ERR_ARG_10_WRONG_TYPE 0x2F -#define ERR_INAPPLICABLE_CONTINUATION 0x30 -#define ERR_COMPILED_CODE_ERROR 0x31 -#define ERR_FLOATING_OVERFLOW 0x32 -#define ERR_UNIMPLEMENTED_PRIMITIVE 0x33 - -#define MAX_ERROR 0x33 - -/* Termination codes: the interpreter halts on these */ - -#define TERM_HALT 0x00 -#define TERM_DISK_RESTORE 0x01 -#define TERM_BROKEN_HEART 0x02 -#define TERM_NON_POINTER_RELOCATION 0x03 -#define TERM_BAD_ROOT 0x04 -#define TERM_NON_EXISTENT_CONTINUATION 0x05 -#define TERM_BAD_STACK 0x06 -#define TERM_STACK_OVERFLOW 0x07 -#define TERM_STACK_ALLOCATION_FAILED 0x08 -#define TERM_NO_ERROR_HANDLER 0x09 -#define TERM_NO_INTERRUPT_HANDLER 0x0A -#define TERM_UNIMPLEMENTED_CONTINUATION 0x0B -#define TERM_EXIT 0x0C -#define TERM_BAD_PRIMITIVE_DURING_ERROR 0x0D -#define TERM_EOF 0x0E -#define TERM_BAD_PRIMITIVE 0x0F -#define TERM_TERM_HANDLER 0x10 -#define TERM_END_OF_COMPUTATION 0x11 -#define TERM_INVALID_TYPE_CODE 0x12 -#define TERM_COMPILER_DEATH 0x13 -#define TERM_GC_OUT_OF_SPACE 0x14 -#define TERM_NO_SPACE 0x15 -#define TERM_SIGNAL 0x16 diff --git a/v7/src/microcode/extern.c b/v7/src/microcode/extern.c deleted file mode 100644 index ca6fd8029..000000000 --- a/v7/src/microcode/extern.c +++ /dev/null @@ -1,95 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.c,v 9.22 1987/04/16 02:21:18 jinx Rel $ */ - -#include "scheme.h" -#include "primitive.h" - -/* (GET-EXTERNAL-COUNTS) - Returns a CONS of the number of external primitives defined in this - interpreter and the number of external primitives referenced but - not defined. -*/ - -Built_In_Primitive(Prim_Get_External_Count, 0, "GET-EXTERNAL-COUNTS", 0x101) -{ - Primitive_0_Args(); - - *Free++ = Make_Unsigned_Fixnum(MAX_EXTERNAL_PRIMITIVE + 1); - *Free++ = Make_Unsigned_Fixnum(NUndefined()); - return Make_Pointer(TC_LIST, Free - 2); -} - -/* (GET-EXTERNAL-NAME n) - Given a number, return the string for the name of the corresponding - external primitive. An error if the number is out of range. - External primitives start at 0. -*/ - -Built_In_Primitive(Prim_Get_Ext_Name, 1, "GET-EXTERNAL-NAME", 0x102) -{ - extern Pointer external_primitive_name(); - long Number, TC; - Primitive_1_Arg(); - - TC = Type_Code(Arg1); - if ((TC != TC_FIXNUM) && (TC != TC_PRIMITIVE_EXTERNAL)) - Primitive_Error(ERR_ARG_1_WRONG_TYPE); - Range_Check(Number, Arg1, 0, MAX_EXTERNAL_PRIMITIVE+NUndefined(), - ERR_ARG_1_BAD_RANGE); - if (Number <= MAX_EXTERNAL_PRIMITIVE) - return external_primitive_name(Number); - else return User_Vector_Ref(Undefined_Externals, - (Number - MAX_EXTERNAL_PRIMITIVE)); -} - -/* (GET-EXTERNAL-NUMBER name intern?) - Given a symbol (name), return the external primitive object - corresponding to this name. - If intern? is true, then an external object is created if one - didn't exist before. - If intern? is false, NIL is returned if the primitive is not - implemented even if the name alredy exists. - Otherwise, NIL is returned if the primitive does not exist and - the name does not exist either. -*/ - -Built_In_Primitive(Prim_Get_Ext_Number, 2, "GET-EXTERNAL-NUMBER", 0x103) -{ - extern long make_external_primitive(); - Primitive_2_Args(); - - Arg_1_Type(TC_INTERNED_SYMBOL); - Touch_In_Primitive(Arg2, Arg2); - return make_external_primitive(Arg1, Arg2); -} diff --git a/v7/src/microcode/extern.h b/v7/src/microcode/extern.h deleted file mode 100644 index c779eabbc..000000000 --- a/v7/src/microcode/extern.h +++ /dev/null @@ -1,197 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.h,v 9.24 1987/04/16 02:21:28 jinx Exp $ - * - * External declarations. - * - */ - -#ifdef ENABLE_DEBUGGING_TOOLS - -extern Boolean Eval_Debug, Hex_Input_Debug, Cont_Debug, - File_Load_Debug, Reloc_Debug, Intern_Debug, - Primitive_Debug, Define_Debug, Lookup_Debug, GC_Debug, - Upgrade_Debug, Trace_On_Error, Dump_Debug, Per_File, - Bignum_Debug, Fluids_Debug; - -extern sp_record_list SP_List; -extern void Pop_Return_Break_Point(); -extern int debug_slotno, debug_nslots, local_slotno, local_nslots, - debug_circle[], local_circle[]; -#else -#define Eval_Debug false -#define Hex_Input_Debug false -#define File_Load_Debug false -#define Reloc_Debug false -#define Intern_Debug false -#define Cont_Debug false -#define Primitive_Debug false -#define Lookup_Debug false -#define Define_Debug false -#define GC_Debug false -#define Upgrade_Debug false -#define Trace_On_Error false -#define Dump_Debug false -#define Per_File false -#define Bignum_Debug false -#define Fluids_Debug false -#endif - -/* The register block */ - -extern Pointer Registers[]; - -extern Pointer - *Ext_History, /* History register */ - *Free, /* Next free word in heap */ - *MemTop, /* Top of heap space available */ - *Ext_Stack_Pointer, /* Next available slot in control stack */ - *Stack_Top, /* Top of control stack */ - *Stack_Guard, /* Guard area at end of stack */ - *Free_Stacklets, /* Free list of stacklets */ - *Constant_Space, /* Bottom of constant+pure space */ - *Free_Constant, /* Next free cell in constant+pure area */ - *Heap_Top, /* Top of current heap space */ - *Heap_Bottom, /* Bottom of current heap space */ - *Unused_Heap_Top, /* Top of unused heap for GC */ - *Unused_Heap, /* Bottom of unused heap for GC */ - *Local_Heap_Base, /* Per-processor CONSing area */ - *Heap, /* Bottom of all heap space */ - Current_State_Point, /* Dynamic state point */ - Fluid_Bindings, /* Fluid bindings AList */ - return_to_interpreter, /* Return address/code left by interpreter - when calling compiled code */ - *last_return_code; /* Address of the most recent return code in the stack. - This is only meaningful while in compiled code. - *** This must be changed when stacklets are used. *** - */ - -extern Declare_Fixed_Objects(); - -extern long IntCode, /* Interrupts requesting */ - IntEnb, /* Interrupts enabled */ - GC_Reserve, /* Scheme pointer overflow space in heap */ - GC_Space_Needed, /* Amount of space needed when GC triggered */ - /* Used to signal microcode errors from compiled code. */ - compiled_code_error_code; - -/* The lookup routines receive the slot location using these: */ -extern Pointer Lookup_Base; -extern long Lookup_Offset; - -extern char *Return_Names[]; -extern long MAX_RETURN; - -extern char *CONT_PRINT_RETURN_MESSAGE, - *CONT_PRINT_EXPR_MESSAGE, - *RESTORE_CONT_RETURN_MESSAGE, - *RESTORE_CONT_EXPR_MESSAGE; - -extern int GC_Type_Map[]; - -extern Boolean Photo_Open; /* Photo file open */ -extern jmp_buf *Back_To_Eval; -extern Boolean Trapping; -extern Pointer Old_Return_Code, *Return_Hook_Address; - -extern Pointer *Prev_Restore_History_Stacklet; -extern long Prev_Restore_History_Offset; - -/* And file "channels" */ - -extern FILE *(Channels[FILE_CHANNELS]); -extern FILE *File_Handle; /* Used by Fasload/Fasdump */ -extern FILE *Photo_File_Handle; /* Used by Photo */ - -extern int Saved_argc; -extern char **Saved_argv; -extern char *OS_Name, *OS_Variant; -extern long Heap_Size, Constant_Size, Stack_Size; -extern Pointer *Highest_Allocated_Address; - -/* Environment lookup utilities. */ - -extern long Lex_Ref(), Local_Set(), Lex_Set(), - Symbol_Lex_Ref(), Symbol_Lex_Set(); - -/* String utilities */ - -extern Pointer C_String_To_Scheme_String(); - -#define Scheme_String_To_C_String(Scheme_String) \ - ((char *) Nth_Vector_Loc(Scheme_String, STRING_CHARS)) - -/* Numeric utilities */ - -extern int Scheme_Integer_To_C_Integer(); -extern Pointer C_Integer_To_Scheme_Integer(), Allocate_Float(), - Float_To_Big(), Big_To_Float(), Big_To_Fix(), - Fix_To_Big(); - -/* Random and OS utilities */ - -extern int Parse_Option(); -extern Boolean Open_File(), Restore_History(), Open_Dump_File(); -extern long NColumns(), NLines(), System_Clock(); -extern void OS_Flush_Output_Buffer(); -extern void Load_Data(), Write_Data(), OS_Re_Init(); - -/* Memory management utilities */ - -extern Pointer Purify_Pass_2(), Fasload(); -extern Boolean Pure_Test(); - -/* Interpreter utilities */ - -extern term_type Microcode_Termination(); -extern void Interpret(), Do_Micro_Error(), Setup_Interrupt(), - Back_Out_Of_Primitive(), Translate_To_Point(), - Stop_History(), Stack_Death(); - -#ifdef USE_STACKLETS -extern void Allocate_New_Stacklet(); -#endif - -extern Pointer *Make_Dummy_History(), Find_State_Space(); - -/* Debugging utilities */ - -extern void Back_Trace(), Handle_Debug_Flags(), - Find_Symbol(), Show_Env(), Show_Pure(), - Print_Return(), Print_Expression(), Print_Primitive(); - -/* Conditional utilities */ - -#if false -extern void Clear_Perfinfo_Data(); -#endif diff --git a/v7/src/microcode/fasdump.c b/v7/src/microcode/fasdump.c deleted file mode 100644 index 8643b6233..000000000 --- a/v7/src/microcode/fasdump.c +++ /dev/null @@ -1,338 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasdump.c,v 9.25 1987/04/16 14:34:02 jinx Exp $ - - This file contains code for fasdump and dump-band. -*/ - -#include "scheme.h" -#include "primitive.h" -#define In_Fasdump -#include "gccode.h" -#include "trap.h" -#include "lookup.h" -#include "dump.c" - -extern Pointer Make_Prim_Exts(); - -/* Some statics used freely in this file */ -Pointer *NewFree, *NewMemTop, *Fixup, *Orig_New_Free; - -/* FASDUMP: - - Hair squared! ... in order to dump an object it must be traced (as - in a garbage collection), but with some significant differences. - First, the copy must have the global value cell of symbols set to - UNBOUND and variables uncompiled. Second, and worse, all the - broken hearts created during the process must be restored to their - original values. This last is done by growing the copy of the - object in the bottom of spare heap, keeping track of the locations - of broken hearts and original contents at the top of the spare - heap. - - FASDUMP is called with three arguments: - Argument 1: Base of spare heap - Argument 2: Top of spare heap - Argument 3: Hunk 3, # - where the flag is #!true for a dump into constant - space at reload time, () for a dump into heap. - - As with Purify, dumping an object for reloading into constant space - requires dividing it into pure and constant parts and building a - standard Pure/Constant block. -*/ - -/* - Copy of GCLoop, except (a) copies out of constant space into the - object to be dumped; (b) changes symbols and variables as - described; (c) keeps track of broken hearts and their original - contents (e) To_Pointer is now NewFree. -*/ - -#define Dump_Pointer(Code) \ -Old = Get_Pointer(Temp); \ -Code - -#define Setup_Pointer_for_Dump(Extra_Code) \ -Dump_Pointer(Fasdump_Setup_Pointer(Extra_Code, Normal_BH(false, continue))) - -/* Dump_Mode is currently a fossil. It should be resurrected. */ - -/* Should be big enough for the largest fixed size object (a Quad) - and 2 for the Fixup. - */ - -#define FASDUMP_FIX_BUFFER 10 - -Boolean DumpLoop(Scan, Dump_Mode) -fast Pointer *Scan; -int Dump_Mode; -{ fast Pointer *To, *Old, Temp, New_Address, *Fixes; - - To = NewFree; - Fixes = Fixup; - - for ( ; Scan != To; Scan++) - { Temp = *Scan; - - Switch_by_GC_Type(Temp) - { case TC_BROKEN_HEART: - if (Datum(Temp) != 0) - { fprintf(stderr, "\nDump: Broken heart in scan.\n"); - Microcode_Termination(TERM_BROKEN_HEART); - } - break; - - case TC_MANIFEST_NM_VECTOR: - case TC_MANIFEST_SPECIAL_NM_VECTOR: - Scan += Get_Integer(Temp); - break; - - /* This should really be case_Fasdump_Non_Pointer, - and PRIMITIVE_EXTERNAL should be handled specially - */ - case_Non_Pointer: - break; - - case_compiled_entry_point: - Dump_Pointer(Fasdump_Setup_Pointer(Transport_Compiled(), - Compiled_BH(false, continue))); - - case_Cell: - Setup_Pointer_for_Dump(Transport_Cell()); - - case TC_REFERENCE_TRAP: - if (Datum(Temp) <= TRAP_MAX_IMMEDIATE) - { - /* It is a non pointer. */ - break; - } - /* Fall through. */ - case TC_WEAK_CONS: - case_Fasdump_Pair: - Setup_Pointer_for_Dump(Transport_Pair()); - - case TC_INTERNED_SYMBOL: - Setup_Pointer_for_Dump(Fasdump_Symbol(Make_Broken_Heart(0))); - - case TC_UNINTERNED_SYMBOL: - Setup_Pointer_for_Dump(Fasdump_Symbol(UNBOUND_OBJECT)); - - case_Triple: - Setup_Pointer_for_Dump(Transport_Triple()); - - case TC_VARIABLE: - Setup_Pointer_for_Dump(Fasdump_Variable()); - -/* DumpLoop continues on the next page */ - -/* DumpLoop, continued */ - - case_Quadruple: - Setup_Pointer_for_Dump(Transport_Quadruple()); - -#ifdef FLOATING_ALIGNMENT - case TC_BIG_FLONUM: - Setup_Pointer_for_Dump(Transport_Flonum()); -#else - case TC_BIG_FLONUM: - /* Fall through */ -#endif - case_Vector: - Setup_Pointer_for_Dump(Transport_Vector()); - - case TC_FUTURE: - Setup_Pointer_for_Dump(Transport_Future()); - - default: - fprintf(stderr, - "DumpLoop: Bad type code = 0x%02x\n", - Type_Code(Temp)); - Invalid_Type_Code(); - - } /* Switch_by_GC_Type */ - } /* For loop */ - NewFree = To; - Fixup = Fixes; - return true; -} /* DumpLoop */ - -void -Fasdump_Exit() -{ - fast Pointer *Fixes; - - Fixes = Fixup; - fclose(File_Handle); - while (Fixes != NewMemTop) - { - fast Pointer *Fix_Address; - - Fix_Address = Get_Pointer(*Fixes++); /* Where it goes. */ - *Fix_Address = *Fixes++; /* Put it there. */ - } - Fixup = Fixes; - Fasdump_Exit_Hook(); -} - -/* (PRIMITIVE-FASDUMP object-to-dump file-name flag) - Dump an object into a file so that it can be loaded using - BINARY-FASLOAD. A spare heap is required for this operation. - The first argument is the object to be dumped. The second is - the filename and the third a flag. The flag, if #!TRUE, means - that the object is to be dumped for reloading into constant - space. This is currently disabled. If the flag is NIL, it means - that it will be reloaded into the heap. The primitive returns - #!TRUE or NIL indicating whether it successfully dumped the - object (it can fail on an object that is too large). - - The code for dumping pure is severely broken and conditionalized out. -*/ -Built_In_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP", 0x56) -{ - Pointer Object, File_Name, Flag, *New_Object, - *Addr_Of_New_Object, Prim_Exts; - long Pure_Length, Length; - Primitive_3_Args(); - - Object = Arg1; - File_Name = Arg2; - Flag = Arg3; - if (Type_Code(File_Name) != TC_CHARACTER_STRING) - Primitive_Error(ERR_ARG_2_WRONG_TYPE); - if (!Open_Dump_File(File_Name, WRITE_FLAG)) - Primitive_Error(ERR_ARG_2_BAD_RANGE); -#if false - if ((Flag != NIL) && (Flag != TRUTH)) -#else - if (Flag != NIL) -#endif - Primitive_Error(ERR_ARG_3_WRONG_TYPE); - - Fasdump_Free_Calc(NewFree, NewMemTop, Orig_New_Free); - Fixup = NewMemTop; - Prim_Exts = Make_Prim_Exts(); - New_Object = NewFree; - *NewFree++ = Object; - *NewFree++ = Prim_Exts; - -#if false - if (Flag == TRUTH) - { if (!DumpLoop(New_Object, PURE_COPY)) - { - Fasdump_Exit(); - return NIL; - } - /* Can't align. - Align_Float(NewFree); - */ - Pure_Length = (NewFree-New_Object) + 1; - *NewFree++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1); - *NewFree++ = Make_Non_Pointer(CONSTANT_PART, Pure_Length); - if (!DumpLoop(New_Object, CONSTANT_COPY)) - { - Fasdump_Exit(); - return NIL; - } - Length = NewFree-New_Object+2; - *NewFree++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1); - *NewFree++ = Make_Non_Pointer(END_OF_BLOCK, Length-1); - Addr_Of_New_Object = Get_Pointer(New_Object[0]); - Prim_Exts = New_Object[1]; - New_Object[0] = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, - Pure_Length); - New_Object[1] = Make_Non_Pointer(PURE_PART, Length-1); - Write_File(0, 0x000000, Addr_Of_New_Object, - Length, New_Object, Prim_Exts); - } - else /* Dumping for reload into heap */ -#endif - { if (!DumpLoop(New_Object, NORMAL_GC)) - { - Fasdump_Exit(); - return NIL; - } - /* Aligning might screw up some of the counters. - Align_Float(NewFree); - */ - Length = NewFree-New_Object; - Write_File(Length, New_Object, New_Object, - 0, Constant_Space, New_Object+1); - } - Fasdump_Exit(); - return TRUTH; -} - -/* (DUMP-BAND PROCEDURE FILE-NAME) - Saves all of the heap and pure space on FILE-NAME. When the - file is loaded back using BAND_LOAD, PROCEDURE is called with an - argument of NIL. -*/ -Built_In_Primitive(Prim_Band_Dump, 2, "DUMP-BAND", 0xB7) -{ - Pointer Combination, Ext_Prims; - long Arg1Type; - Primitive_2_Args(); - - Band_Dump_Permitted(); - Arg1Type = Type_Code(Arg1); - if ((Arg1Type != TC_CONTROL_POINT) && - (Arg1Type != TC_PRIMITIVE) && - (Arg1Type != TC_PRIMITIVE_EXTERNAL) && - (Arg1Type != TC_EXTENDED_PROCEDURE)) Arg_1_Type(TC_PROCEDURE); - Arg_2_Type(TC_CHARACTER_STRING); - if (!Open_Dump_File(Arg2, WRITE_FLAG)) - Primitive_Error(ERR_ARG_2_BAD_RANGE); - /* Free cannot be saved around this code since Make_Prim_Exts will - intern the undefined externals and potentially allocate space. - */ - Ext_Prims = Make_Prim_Exts(); - Combination = Make_Pointer(TC_COMBINATION_1, Free); - Free[COMB_1_FN] = Arg1; - Free[COMB_1_ARG_1] = NIL; - Free += 2; - *Free++ = Combination; - *Free++ = return_to_interpreter; - *Free = Make_Pointer(TC_LIST, Free-2); - Free++; /* Some compilers are TOO clever about this and increment Free - before calculating Free-2! */ - *Free++ = Ext_Prims; - /* Aligning here confuses some of the counts computed. - Align_Float(Free); - */ - Write_File(((long) (Free-Heap_Bottom)), Heap_Bottom, Free-2, - ((long) (Free_Constant-Constant_Space)), - Constant_Space, Free-1); - fclose(File_Handle); - return TRUTH; -} diff --git a/v7/src/microcode/fasl.h b/v7/src/microcode/fasl.h deleted file mode 100644 index a65a9837d..000000000 --- a/v7/src/microcode/fasl.h +++ /dev/null @@ -1,93 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasl.h,v 9.23 1987/04/03 00:12:15 jinx Exp $ - - Contains information relating to the format of FASL files. - Some information is contained in CONFIG.H. -*/ - -/* FASL Version */ - -#define FASL_FILE_MARKER 0XFAFAFAFA - -/* The FASL file has a header which begins as follows: */ - -#define FASL_HEADER_LENGTH 50 /* Scheme objects in header */ -#define FASL_OLD_LENGTH 8 /* Size of header earlier */ -#define FASL_Offset_Marker 0 /* Marker to indicate FASL format */ -#define FASL_Offset_Heap_Count 1 /* Count of objects in heap */ -#define FASL_Offset_Heap_Base 2 /* Address of heap when dumped */ -#define FASL_Offset_Dumped_Obj 3 /* Where dumped object was */ -#define FASL_Offset_Const_Count 4 /* Count of objects in const. area */ -#define FASL_Offset_Const_Base 5 /* Address of const. area at dump */ -#define FASL_Offset_Version 6 /* FASL format version info. */ -#define FASL_Offset_Stack_Top 7 /* Top of stack when dumped */ -#define FASL_Offset_Ext_Loc 8 /* Where ext. prims. vector is */ - -#define FASL_Offset_First_Free 9 /* Used to clear header */ - -/* Version information encoding */ - -#define MACHINE_TYPE_LENGTH (POINTER_LENGTH/2) -#define MACHINE_TYPE_MASK ((1<> MACHINE_TYPE_LENGTH) & SUB_VERSION_MASK) -#define The_Version(P) Type_Code(P) -#define Make_Version(V, S, M) \ - Make_Non_Pointer((V), (((S) << MACHINE_TYPE_LENGTH) | (M))) - -#define WRITE_FLAG "w" -#define OPEN_FLAG "r" - -/* "Memorable" FASL versions -- ones where we modified something - and want to remain backwards compatible. -*/ - -/* Versions. */ - -#define FASL_FORMAT_ADDED_STACK 1 - -/* Subversions of highest numbered version. */ - -#define FASL_LONG_HEADER 3 -#define FASL_DENSE_TYPES 4 -#define FASL_PADDED_STRINGS 5 -#define FASL_REFERENCE_TRAP 6 - -/* Current parameters. */ - -#define FASL_FORMAT_VERSION FASL_FORMAT_ADDED_STACK -#define FASL_SUBVERSION FASL_REFERENCE_TRAP -#define FASL_OLDEST_SUPPORTED FASL_PADDED_STRINGS diff --git a/v7/src/microcode/fasload.c b/v7/src/microcode/fasload.c deleted file mode 100644 index fb4988f38..000000000 --- a/v7/src/microcode/fasload.c +++ /dev/null @@ -1,650 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.25 1987/04/16 02:21:50 jinx Exp $ - - The "fast loader" which reads in and relocates binary files and then - interns symbols. It is called with one argument: the (character - string) name of a file to load. It is called as a primitive, and - returns a single object read in. - */ - -#include "scheme.h" -#include "primitive.h" -#include "gccode.h" -#include "trap.h" - -#define CCheck_or_Reloc_Debug Or2(Consistency_Check, Reloc_Debug) -#define Reloc_or_Load_Debug Or2(Reloc_Debug, File_Load_Debug) - -#include "load.c" - -void -Load_File(Name) - Pointer Name; -{ - char *Char; - long N, i; - Boolean File_Opened; - - File_Opened = Open_Dump_File(Name, OPEN_FLAG); - if (Per_File) - Handle_Debug_Flags(); - if (!File_Opened) - Primitive_Error(ERR_ARG_1_BAD_RANGE); - - if (!Read_Header()) - { fprintf(stderr, - "\nLoad_File: The file does not appear to be in FASL format.\n"); - goto CANNOT_LOAD; - } - if (File_Load_Debug) - printf("\nMachine type %d, Version %d, Subversion %d\n", - Machine_Type, Version, Sub_Version); - -#ifdef BYTE_INVERSION - if ((Sub_Version != FASL_SUBVERSION)) -#else - if ((Sub_Version != FASL_SUBVERSION) || - (Machine_Type != FASL_INTERNAL_FORMAT)) -#endif - - { - fprintf(stderr, - "\nLoad_File: FASL File Version %4d Subversion %4d Machine Type %4d.\n", - Version, Sub_Version , Machine_Type); - fprintf(stderr, - " Expected: Version %4d Subversion %4d Machine Type %4d.\n", - FASL_FORMAT_VERSION, FASL_SUBVERSION, FASL_INTERNAL_FORMAT); -CANNOT_LOAD: - fclose(File_Handle); - Primitive_Error(ERR_FASL_FILE_BAD_DATA); - } - if (!Test_Pure_Space_Top(Free_Constant+Const_Count)) - { - fclose(File_Handle); - Primitive_Error(ERR_FASL_FILE_TOO_BIG); - } - if (GC_Check(Heap_Count)) - { - fclose(File_Handle); - Request_GC(Heap_Count); - Primitive_Interrupt(); - } - /* Aligning Free here confuses the counters - Align_Float(Free); - */ - Load_Data(Heap_Count, (char *) Free); -#ifdef BYTE_INVERSION - Byte_Invert_Region((char *) Free, Heap_Count); -#endif - Free += Heap_Count; - Load_Data(Const_Count, (char *) Free_Constant); -#ifdef BYTE_INVERSION - Byte_Invert_Region((char *) Free_Constant, Const_Count); -#endif - Free_Constant += Const_Count; - /* Same - Align_Float(Free); - */ - fclose(File_Handle); - return; -} - -/* Statics used by Relocate, below */ - -relocation_type Heap_Relocation, Const_Reloc, Stack_Relocation; - -/* Relocate a pointer as read in from the file. If the pointer used - to point into the heap, relocate it into the heap. If it used to - be constant area, relocate it to constant area. Otherwise give an - error. -*/ - -#ifdef ENABLE_DEBUGGING_TOOLS -static Boolean Warned = false; -Pointer * -Relocate(P) - long P; -{ - Pointer *Result; - - if ((P >= Heap_Base) && (P < Dumped_Heap_Top)) - Result = (Pointer *) (P + Heap_Relocation); - else if ((P >= Const_Base) && (P < Dumped_Constant_Top)) - Result = (Pointer *) (P + Const_Reloc); - else if (P < Dumped_Stack_Top) - Result = (Pointer *) (P + Stack_Relocation); - else - { - printf("Pointer out of range: 0x%x\n", P, P); - if (!Warned) - { - printf("Heap: %x-%x, Constant: %x-%x, Stack: ?-0x%x\n", - Heap_Base, Dumped_Heap_Top, - Const_Base, Dumped_Constant_Top, Dumped_Stack_Top); - Warned = true; - } - Result = (Pointer *) 0; - } - if (Reloc_Debug) - printf("0x%06x -> 0x%06x\n", P, Result); - return Result; -} - -#define Relocate_Into(Loc, P) (Loc) = Relocate(P) - -#else - -#define Relocate_Into(Loc, P) \ -if ((P) < Const_Base) \ - (Loc) = ((Pointer *) ((P) + Heap_Relocation)); \ -else if ((P) < Dumped_Constant_Top) \ - (Loc) = ((Pointer *) ((P) + Const_Reloc)); \ -else \ - (Loc) = ((Pointer *) ((P) + Stack_Relocation)) - -#ifndef Conditional_Bug -#define Relocate(P) \ - ((P < Const_Base) ? \ - ((Pointer *) (P + Heap_Relocation)) : \ - ((P < Dumped_Constant_Top) ? \ - ((Pointer *) (P + Const_Reloc)) : \ - ((Pointer *) (P + Stack_Relocation)))) -#else -static Pointer *Relocate_Temp; -#define Relocate(P) \ - (Relocate_Into(Relocate_Temp, P), Relocate_Temp) -#endif -#endif - -/* Next_Pointer starts by pointing to the beginning of the block of - memory to be handled. This loop relocates all pointers in the - block of memory. -*/ - -long -Relocate_Block(Next_Pointer, Stop_At) - fast Pointer *Next_Pointer, *Stop_At; -{ - if (Reloc_Debug) - fprintf(stderr, - "Relocation beginning, block=0x%x, length=0x%x, end=0x%x.\n", - Next_Pointer, (Stop_At-Next_Pointer)-1, Stop_At); - while (Next_Pointer < Stop_At) - { - fast Pointer Temp; - - Temp = *Next_Pointer; - Switch_by_GC_Type(Temp) - { case TC_BROKEN_HEART: - case TC_MANIFEST_SPECIAL_NM_VECTOR: - case_Fasdump_Non_Pointer: - Next_Pointer += 1; - break; - - case TC_PRIMITIVE_EXTERNAL: - Found_Ext_Prims = true; - Next_Pointer += 1; - break; - - case TC_MANIFEST_NM_VECTOR: - Next_Pointer += Get_Integer(Temp)+1; - break; - -#ifdef BYTE_INVERSION - case TC_CHARACTER_STRING: - String_Inversion(Relocate(Datum(Temp))); - /* THEN FALL THROUGH */ -#endif - - case TC_REFERENCE_TRAP: - if (Datum(Temp) <= TRAP_MAX_IMMEDIATE) - { - Next_Pointer += 1; - break; - } - /* It is a pointer, fall through. */ - case_compiled_entry_point: - /* Compiled entry points work automagically. */ - default: - { - fast long Next; - - Next = Datum(Temp); - *Next_Pointer++ = Make_Pointer(Type_Code(Temp), Relocate(Next)); - } - } - } -} - -extern void Intern(); - -void -Intern_Block(Next_Pointer, Stop_At) - Pointer *Next_Pointer, *Stop_At; -{ - if (Reloc_Debug) - printf("Interning a block.\n"); - - while (Next_Pointer <= Stop_At) /* BBN has < for <= */ - { - switch (Type_Code(*Next_Pointer)) - { case TC_MANIFEST_NM_VECTOR: - Next_Pointer += Get_Integer(*Next_Pointer)+1; - break; - - case TC_INTERNED_SYMBOL: - if (Type_Code(Vector_Ref(*Next_Pointer, SYMBOL_GLOBAL_VALUE)) == - TC_BROKEN_HEART) - { - Pointer Old_Symbol; - - Old_Symbol = *Next_Pointer; - Vector_Set(*Next_Pointer, SYMBOL_GLOBAL_VALUE, UNBOUND_OBJECT); - Intern(Next_Pointer); - Primitive_GC_If_Needed(0); - if (*Next_Pointer != Old_Symbol) - { - Vector_Set(Old_Symbol, SYMBOL_NAME, - Make_New_Pointer(TC_BROKEN_HEART, *Next_Pointer)); - } - } - else if (Type_Code(Vector_Ref(*Next_Pointer, SYMBOL_NAME)) == - TC_BROKEN_HEART) - { - *Next_Pointer = - Make_New_Pointer(Type_Code(*Next_Pointer), - Fast_Vector_Ref(*Next_Pointer, - SYMBOL_NAME)); - } - Next_Pointer += 1; - break; - - default: Next_Pointer += 1; - } - } - if (Reloc_Debug) - printf("Done interning block.\n"); - return; -} - -/* Install the external primitives vector. This requires changing - the Ext_Prim_Vector from a vector of symbols (which is what is - in the FASL file) into a vector of (C format) numbers representing - the corresponding external primitives numbers for this interpreter. - If an external primitive is known, then the existing assigned number - is used. If not, the symbol is added to the list of assigned - numbers. In the case of a band load (as opposed to a fasload), - the existing vector of known but unimplemented external primitives - is ignored and a completely new one will be built. -*/ - -void -Install_Ext_Prims(Normal_FASLoad) - Boolean Normal_FASLoad; -{ - long i; - Pointer *Next; - - Vector_Set(Ext_Prim_Vector, 0, - Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Ext_Prim_Count)); - Next = Nth_Vector_Loc(Ext_Prim_Vector, 1); - if (Normal_FASLoad) - for (i = 0; i < Ext_Prim_Count; i++) Intern(Next++); - else Undefined_Externals = NIL; - return; -} - -void -Update_Ext_Prims(Next_Pointer, Stop_At) - fast Pointer *Next_Pointer, *Stop_At; -{ - extern long make_external_primitive(); - - for ( ; Next_Pointer < Stop_At; Next_Pointer++) - { switch (Type_Code(*Next_Pointer)) - { case TC_MANIFEST_NM_VECTOR: - Next_Pointer += Get_Integer(*Next_Pointer); - break; - - case TC_PRIMITIVE_EXTERNAL: - { - long Which; - - Which = Address(*Next_Pointer); - - if (Which > Ext_Prim_Count) - fprintf(stderr, "\nExternal Primitive 0x%x out of range.\n", Which); - else - { - Pointer New_Value; - - New_Value = User_Vector_Ref(Ext_Prim_Vector, Which); - if (Type_Code(New_Value) == TC_INTERNED_SYMBOL) - { - New_Value = ((Pointer) make_external_primitive(New_Value, TRUTH)); - User_Vector_Set(Ext_Prim_Vector, Which, New_Value); - } - Store_Address(*Next_Pointer, New_Value); - } - } - - default: break; - } - } - return; -} - -Pointer -Fasload(FileName, Not_From_Band_Load) - Pointer FileName; - Boolean Not_From_Band_Load; -{ - Pointer *Heap_End, *Constant_End, *Orig_Heap, *Orig_Constant, *Xtemp; - -#ifdef ENABLE_DEBUGGING_TOOLS - Warned = false; -#endif - - if (Type_Code(FileName) != TC_CHARACTER_STRING) - Primitive_Error(ERR_ARG_1_WRONG_TYPE); - - /* Read File */ - - Orig_Heap = Free; - Orig_Constant = Free_Constant; - Load_File(FileName); - Heap_End = Free; - Constant_End = Free_Constant; - Heap_Relocation = ((relocation_type) Orig_Heap) - Heap_Base; - Const_Reloc = ((relocation_type) Orig_Constant) - Const_Base; - Stack_Relocation = ((relocation_type) Stack_Top) - Dumped_Stack_Top; - - if (Reloc_Debug) - printf("Heap_relocation = %d = %x; Const_Reloc = %d = %x\n", - Heap_Relocation, Heap_Relocation, - Const_Reloc, Const_Reloc); - - /* Relocate the new Data */ - -#ifdef BYTE_INVERSION - Setup_For_String_Inversion(); -#endif - - Found_Ext_Prims = false; - Relocate_Block(Orig_Heap, Free); - Relocate_Block(Orig_Constant, Free_Constant); - -#ifdef BYTE_INVERSION - Finish_String_Inversion(); -#endif - - if (Not_From_Band_Load) - { - Intern_Block(Orig_Constant, Constant_End); - Intern_Block(Orig_Heap, Heap_End); - } - - /* Update External Primitives */ - - if ((Ext_Prim_Vector != NIL) && Found_Ext_Prims) - { - Relocate_Into(Xtemp, Address(Ext_Prim_Vector)); - Ext_Prim_Vector = *Xtemp; - Ext_Prim_Count = Vector_Length(Ext_Prim_Vector); - Install_Ext_Prims(Not_From_Band_Load); - Update_Ext_Prims(Orig_Heap, Free); - Update_Ext_Prims(Orig_Constant, Free_Constant); - } - - Set_Pure_Top(); - Relocate_Into(Xtemp, Dumped_Object); - return *Xtemp; -} - -/* (BINARY-FASLOAD FILE-NAME) - Load the contents of FILE-NAME into memory. The file was - presumably made by a call to PRIMITIVE-FASDUMP, and may contain - data for the heap and/or the pure area. The value returned is - the object which was dumped. Typically (but not always) this - will be a piece of SCode which is then evaluated to perform - definitions in some environment. -*/ -Built_In_Primitive(Prim_Binary_Fasload, 1, "BINARY-FASLOAD", 0x57) -{ - Primitive_1_Arg(); - return Fasload(Arg1, true); -} - -/* Band loading. */ - -static char *reload_band_name = ((char *) NULL); - -/* (RELOAD-BAND-NAME) - Returns the filename (as a Scheme string) from which the runtime system - was band loaded (load-band'ed ?), or NIL if the system was fasl'ed. -*/ -Built_In_Primitive(Prim_reload_band_name, 0, "RELOAD-BAND-NAME", 0x1A3) -{ - Primitive_0_Args(); - - if (reload_band_name == NULL) - return NIL; - - return C_String_To_Scheme_String(reload_band_name); -} - -/* (LOAD-BAND FILE-NAME) - Restores the heap and pure space from the contents of FILE-NAME, - which is typically a file created by DUMP-BAND. The file can, - however, be any file which can be loaded with BINARY-FASLOAD. -*/ -Built_In_Primitive(Prim_Band_Load, 1, "LOAD-BAND", 0xB9) -{ - Pointer Save_FO, *Save_Free, *Save_Free_Constant, - Save_Undefined, *Save_Stack_Pointer, - *Save_Stack_Guard, Result; - - long Jump_Value; - jmp_buf Swapped_Buf, *Saved_Buf; - Pointer scheme_band_name; - char *band_name; - int length; - Primitive_1_Arg(); - - band_name = ((char *) NULL); - Save_Fixed_Obj(Save_FO); - Save_Undefined = Undefined_Externals; - Undefined_Externals = NIL; - Save_Free = Free; - Free = Heap_Bottom; - Save_Free_Constant = Free_Constant; - Free_Constant = Constant_Space; - Save_Stack_Pointer = Stack_Pointer; - Save_Stack_Guard = Stack_Guard; - -/* Prim_Band_Load continues on next page */ - -/* Prim_Band_Load, continued */ - - /* There is some jiggery-pokery going on here to make sure - that all returns from Fasload (including error exits) return to - the clean-up code before returning on up the C call stack. - */ - Saved_Buf = Back_To_Eval; - Jump_Value = setjmp(Swapped_Buf); - if (Jump_Value == 0) - { extern char *malloc(); - extern strcpy(), free(); - - length = Get_Integer(Fast_Vector_Ref(Arg1, STRING_LENGTH)); - band_name = malloc(length); - if (band_name != ((char *) NULL)) - strcpy(band_name, Scheme_String_To_C_String(Arg1)); - - Back_To_Eval = (jmp_buf *) Swapped_Buf; - Result = Fasload(Arg1, false); - Back_To_Eval = Saved_Buf; - - if (reload_band_name != ((char *) NULL)) - free(reload_band_name); - reload_band_name = band_name; - History = Make_Dummy_History(); - Initialize_Stack(); - Store_Return(RC_END_OF_COMPUTATION); - Store_Expression(NIL); - Save_Cont(); - Store_Expression(Vector_Ref(Result,0)); - /* Primitive externals handled by Fasload */ - return_to_interpreter = Vector_Ref(Result, 1); - Store_Env(Make_Non_Pointer(GLOBAL_ENV, GO_TO_GLOBAL)); - Set_Pure_Top(); - Band_Load_Hook(); - longjmp(*Back_To_Eval, PRIM_DO_EXPRESSION); - } - else - { if (band_name != ((char *) NULL)) - free(band_name); - Back_To_Eval = Saved_Buf; - Free = Save_Free; - Free_Constant = Save_Free_Constant; - Stack_Pointer = Save_Stack_Pointer; - Set_Stack_Guard(Save_Stack_Guard); - Undefined_Externals = Save_Undefined; - Restore_Fixed_Obj(Save_FO); - if (Jump_Value == PRIM_INTERRUPT) - { printf("\nFile too large for memory.\n"); - Jump_Value = ERR_FASL_FILE_BAD_DATA; - } - Primitive_Error(Jump_Value); - } -} - -#ifdef BYTE_INVERSION - -#define MAGIC_OFFSET (TC_FIXNUM + 1) - -Pointer String_Chain, Last_String; -extern Boolean Byte_Invert_Fasl_Files; - -Setup_For_String_Inversion() -{ - if (!Byte_Invert_Fasl_Files) - return; - String_Chain = NIL; - Last_String = NIL; -} - -Finish_String_Inversion() -{ while (String_Chain != NIL) - { long Count; - Pointer Next; - - if (!Byte_Invert_Fasl_Files) return; - - Count = Get_Integer(Fast_Vector_Ref(String_Chain, STRING_HEADER)); - Count = 4*(Count-2)+Type_Code(String_Chain)-MAGIC_OFFSET; - if (Reloc_Debug) - printf("String at 0x%x: restoring length of %d.\n", - Address(String_Chain), Count); - Next = Fast_Vector_Ref(String_Chain, STRING_LENGTH); - Fast_Vector_Set(String_Chain, STRING_LENGTH, Make_Unsigned_Fixnum(Count)); - String_Chain = Next; - } -} - -#define print_char(C) printf(((C < ' ') || (C > '|')) ? \ - "\\%03o" : "%c", (C && MAX_CHAR)); - -String_Inversion(Orig_Pointer) -Pointer *Orig_Pointer; -{ Pointer *Pointer_Address; - char *To_Char; - long Code; - - if (!Byte_Invert_Fasl_Files) return; - - Code = Type_Code(Orig_Pointer[STRING_LENGTH]); - if (Code == TC_FIXNUM || Code == 0) /* Already reversed? */ - { long Count, old_size, new_size, i; - - old_size = Get_Integer(Orig_Pointer[STRING_HEADER]); - new_size = - 2+(Get_Integer(Orig_Pointer[STRING_LENGTH]))/4; - - if (Reloc_Debug) - printf("\nString at 0x%x with %d characters", - Orig_Pointer, - Get_Integer(Orig_Pointer[STRING_LENGTH])); - - if (old_size != new_size) - { printf("\nWord count changed from %d to %d: ", - old_size , new_size); - printf("\nWhich, of course, is impossible!!\n"); - Microcode_Termination(TERM_EXIT); - } - - Count = Get_Integer(Orig_Pointer[STRING_LENGTH])%4; - if (Count==0) Count = 4; - if (Last_String == NIL) - String_Chain = Make_Pointer(Count+MAGIC_OFFSET, Orig_Pointer); - else Fast_Vector_Set(Last_String, STRING_LENGTH, - Make_Pointer(Count+MAGIC_OFFSET, Orig_Pointer)); - Last_String = Make_Pointer(TC_NULL, Orig_Pointer); - Orig_Pointer[STRING_LENGTH] = NIL; - Count = Get_Integer(Orig_Pointer[STRING_HEADER])-1; - if (Reloc_Debug) - printf("\nCell count=%d\n", Count); - Pointer_Address = &(Orig_Pointer[STRING_CHARS]); - To_Char = (char *) Pointer_Address; - for (i=0; i < Count; i++, Pointer_Address++) - { int C1, C2, C3, C4; - C4 = Type_Code(*Pointer_Address) & 0xFF; - C3 = (((long) *Pointer_Address)>>16) & 0xFF; - C2 = (((long) *Pointer_Address)>>8) & 0xFF; - C1 = ((long) *Pointer_Address) & 0xFF; - if (Reloc_Debug || (old_size != new_size)) - { print_char(C1); - print_char(C2); - print_char(C3); - print_char(C4); - } - *To_Char++ = C1; - *To_Char++ = C2; - *To_Char++ = C3; - *To_Char++ = C4; - } - } - if (Reloc_Debug) printf("\n"); -} -#endif /* BYTE_INVERSION */ diff --git a/v7/src/microcode/fft.c b/v7/src/microcode/fft.c deleted file mode 100644 index 7ea4f7af8..000000000 --- a/v7/src/microcode/fft.c +++ /dev/null @@ -1,674 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/fft.c,v 9.21 1987/01/22 14:24:33 jinx Rel $ */ - -/* FFT scheme primitive, using YEKTA FFT */ - -#include "scheme.h" -#include "primitive.h" -#include "flonum.h" -#include "zones.h" -#include -#include "array.h" -#include "image.h" - -#define mult(pf1, pf2, pg1, pg2, w1, w2) \ - { int x, y, p2, p3, p4, p5, p6, p7; \ - REAL tmp1, tmp2; \ - a = a / 2; \ - p2 = - a; \ - p3 = 0; \ - for ( x = 1; x <= n2; x = x + a ) { \ - p2 = p2 + a; \ - for( y = 1; y <= a; ++y ) { \ - ++p3; \ - p4 = p2 + 1; \ - p5 = p2 + p3; \ - p5 = ((p5-1) % n) + 1; \ - p6 = p5 + a; \ - tmp1 = w1[p4-1] * pf1[p6-1] \ - - w2[p4-1] * pf2[p6-1]; \ - tmp2 = w1[p4-1] * pf2[p6-1] \ - + w2[p4-1] * pf1[p6-1]; \ - pg1[p3-1] = pf1[p5-1] + tmp1; \ - pg2[p3-1] = pf2[p5-1] + tmp2; \ - p7 = p3 + n2; \ - pg1[p7-1] = pf1[p5-1] - tmp1; \ - pg2[p7-1] = pf2[p5-1] - tmp2; \ - } \ - } \ -} - -/* n is length, nu is power, w1,w2 are locations for twiddle tables, */ -/* f1,f2,g1,g2 are locations for fft, and flag is for forward(1) or inverse(-1) */ -/* w1,w2 are half the size of f1,f2,g1,g2 */ - -/* f1,f2 contain the real and imaginary parts of the signal */ -/* The answer is left in f1, f2 */ - -C_Array_FFT(flag, nu, n, f1, f2, g1,g2,w1,w2) long flag, nu, n; REAL f1[], f2[], g1[], g2[], w1[], w2[]; -{ long n2=n>>1, a; - long i, l, m; - REAL twopi = 6.28318530717958, tm, k; - - a = n; /* initially equal to length */ - if (flag == 1) k=1.0; - else k = -1.0; - /* if ( nu > 12 ) Primitive_Error(ERR_ARG_2_BAD_RANGE); */ /* maximum power FFT */ - - for (m=0; m do one more mult */ - mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */ - }} - else { /* backward fft */ - tm = 1. / ((REAL) n); /* normalizing factor */ - if (l==1) { /* even power */ - for (m=0; m do one more mult */ - mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */ - for (m=0; m>1, a; - long i, l, m; - REAL twopi = 6.28318530717958, tm, k; - - a = n; /* initially equal to length */ - if (flag == 1) k=1.0; - else k = -1.0; - - for (m=0; m do one more mult */ - mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */ - }} - else { /* backward fft */ - tm = 1. / ((REAL) n); /* normalizing factor */ - if (l==1) { /* even power */ - for (m=0; m do one more mult */ - mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */ - for (m=0; m1; ncols_power++) { /* FIND/CHECK POWERS OF ROWS,COLS */ - if ( (i % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE); - i=i/2; } - for (nrows_power=0, i=nrows; i>1; nrows_power++) { - if ( (i % 2) == 1) Primitive_Error(ERR_ARG_1_BAD_RANGE); - i=i/2; } - - Primitive_GC_If_Needed(Length*REAL_SIZE + ((max(nrows,ncols))*3*REAL_SIZE)); - Work_Here = (REAL *) Free; - g1 = Work_Here; - g2 = Work_Here + ncols; - w1 = Work_Here + (ncols<<1); - w2 = Work_Here + (ncols<<1) + (ncols>>1); - Make_Twiddle_Tables(w1,w2,ncols, flag); - for (i=0;i>1); - Make_Twiddle_Tables(w1,w2,nrows,flag); - for (i=0;i1; nrows_power++) { /* FIND/CHECK POWERS OF ROWS */ - if ( (i % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE); - i=i/2; } - Primitive_GC_If_Needed(nrows*3*REAL_SIZE); - Work_Here = (REAL *) Free; - g1 = Work_Here; - g2 = Work_Here + nrows; - w1 = Work_Here + (nrows<<1); - w2 = Work_Here + (nrows<<1) + (nrows>>1); - Make_Twiddle_Tables(w1, w2, nrows, flag); /* MAKE TABLES */ - for (i=0;i1; ndeps_power++) { /* FIND/CHECK POWERS OF DEPS,ROWS,COLS */ - if ( (l % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE); - l=l/2; } - for (nrows_power=0, m=nrows; m>1; nrows_power++) { - if ( (m % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE); - m=m/2; } - for (ncols_power=0, n=ncols; n>1; ncols_power++) { - if ( (n % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE); - n=n/2; } - - printf("3D FFT implemented only for cubic-spaces.\n"); - printf("aborted\n."); - } -} - -Cube_Space_3D_FFT_In_Scheme_Heap(flag, ndeps, Real_Array, Imag_Array) - long flag, ndeps; REAL *Real_Array, *Imag_Array; -{ register long l, m, n; - register long ndeps_power, Surface_Length; - register REAL *From_Real, *From_Imag; - register REAL *f1,*f2,*g1,*g2,*w1,*w2, *Work_Here; - - for (ndeps_power=0, l=ndeps; l>1; ndeps_power++) { /* FIND/CHECK POWER OF NDEPS */ - if ( (l % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE); - l=l/2; } - Primitive_GC_If_Needed(ndeps*3*REAL_SIZE); - Work_Here = (REAL *) Free; - g1 = Work_Here; - g2 = Work_Here + ndeps; - w1 = Work_Here + (ndeps<<1); - w2 = Work_Here + (ndeps<<1) + (ndeps>>1); - Make_Twiddle_Tables(w1, w2, ndeps, flag); /* MAKE TABLES */ - - Surface_Length=ndeps*ndeps; - From_Real = Real_Array; From_Imag = Imag_Array; - - for (l=0; l forward FFT), otherwise inverse FFT */ - -Define_Primitive(Prim_Array_FFT, 3, "ARRAY-FFT!") -{ long length, length1, power, flag, i; - Pointer answer; - REAL *f1,*f2,*g1,*g2,*w1,*w2; - REAL *Work_Here; - - Primitive_3_Args(); - Arg_1_Type(TC_FIXNUM); /* flag */ - Arg_2_Type(TC_ARRAY); /* real */ - Arg_3_Type(TC_ARRAY); /* imag */ - Set_Time_Zone(Zone_Math); - - flag = Get_Integer(Arg1); - length = Array_Length(Arg2); - length1 = Array_Length(Arg3); - - if (length != length1) Primitive_Error(ERR_ARG_2_BAD_RANGE); - power=0; - for (power=0, i=length; i>1; power++) { - if ( (i % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE); - i=i/2; - } - - f1 = Scheme_Array_To_C_Array(Arg2); - f2 = Scheme_Array_To_C_Array(Arg3); - if (f1==f2) Primitive_Error(ERR_ARG_2_WRONG_TYPE); - - Primitive_GC_If_Needed(length*3*REAL_SIZE); - Work_Here = (REAL *) Free; - g1 = Work_Here; - g2 = Work_Here + length; - w1 = Work_Here + (length<<1); - w2 = Work_Here + (length<<1) + (length>>1); - - C_Array_FFT(flag, power, length, f1,f2,g1,g2,w1,w2); - - Primitive_GC_If_Needed(4); - answer = Make_Pointer(TC_LIST, Free); - *Free++ = Arg2; - *Free = Make_Pointer(TC_LIST, Free+1); - Free += 1; - *Free++ = Arg3; - *Free++ = NIL; - return answer; -} - -Define_Primitive(Prim_Array_2D_FFT, 5, "ARRAY-2D-FFT!") -{ long flag, i, j; - Pointer answer; - REAL *Real_Array, *Imag_Array, *Temp_Array; - REAL *f1,*f2,*g1,*g2,*w1,*w2; - REAL *Work_Here; - long Length, nrows, ncols, nrows_power, ncols_power; - - Primitive_5_Args(); - Arg_1_Type(TC_FIXNUM); /* flag */ - Range_Check(nrows, Arg2, 1, 512, ERR_ARG_2_BAD_RANGE); - Range_Check(ncols, Arg3, 1, 512, ERR_ARG_3_BAD_RANGE); - Arg_4_Type(TC_ARRAY); /* real image */ - Arg_5_Type(TC_ARRAY); /* imag image */ - Set_Time_Zone(Zone_Math); /* for timing */ - - Sign_Extend(Arg1, flag); /* should be 1 or -1 */ - Length = Array_Length(Arg4); - if (Length != (nrows*ncols)) Primitive_Error(ERR_ARG_5_BAD_RANGE); - if (Length != (Array_Length(Arg5))) Primitive_Error(ERR_ARG_5_BAD_RANGE); - Real_Array = Scheme_Array_To_C_Array(Arg4); - Imag_Array = Scheme_Array_To_C_Array(Arg5); - if (f1==f2) Primitive_Error(ERR_ARG_5_WRONG_TYPE); - - for (ncols_power=0, i=ncols; i>1; ncols_power++) { /* FIND/CHECK POWERS OF ROWS,COLS */ - if ( (i % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE); - i=i/2; } - for (nrows_power=0, i=nrows; i>1; nrows_power++) { - if ( (i % 2) == 1) Primitive_Error(ERR_ARG_1_BAD_RANGE); - i=i/2; } - - if (nrows==ncols) { /* SQUARE IMAGE, OPTIMIZE... */ - Primitive_GC_If_Needed(nrows*3*REAL_SIZE); - Work_Here = (REAL *) Free; - g1 = Work_Here; - g2 = Work_Here + ncols; - w1 = Work_Here + (ncols<<1); - w2 = Work_Here + (ncols<<1) + (ncols>>1); - for (i=0;i>1); - for (i=0;i>1); - for (i=0;i1; ncols_power++) { /* FIND/CHECK POWERS OF ROWS,COLS */ - if ( (i % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE); - i=i/2; } - for (nrows_power=0, i=nrows; i>1; nrows_power++) { - if ( (i % 2) == 1) Primitive_Error(ERR_ARG_1_BAD_RANGE); - i=i/2; } - - if (nrows==ncols) { /* SQUARE IMAGE, OPTIMIZE... */ - Primitive_GC_If_Needed(nrows*3*REAL_SIZE); - Work_Here = (REAL *) Free; - g1 = Work_Here; - g2 = Work_Here + ncols; - w1 = Work_Here + (ncols<<1); - w2 = Work_Here + (ncols<<1) + (ncols>>1); - Make_Twiddle_Tables(w1, w2, ncols, flag); /* MAKE TABLES */ - for (i=0;i>1); - Make_Twiddle_Tables(w1,w2,ncols, flag); - for (i=0;i>1); - Make_Twiddle_Tables(w1,w2,nrows,flag); - for (i=0;i - -/* For macros toupper, isalpha, etc, - supposedly on the standard library. -*/ - -#include - -extern int strcmp(), strlen(); - -typedef int boolean; -#define TRUE 1 -#define FALSE 0 - -#ifdef vms -/* VMS version 3 has no void. */ -/* #define void */ -#define normal_exit() return -#else -#define normal_exit() exit(0) -#endif - -/* The 4.2 bsd vax compiler has a bug which forces the following. */ - -#define pseudo_void int - -#define error_exit(do_it) \ -{ \ - if (do_it) \ - dump(TRUE); \ - exit(1); \ -} - -#ifdef DEBUGGING -#define dprintf(one, two) fprintf(stderr, one, two) -#else -#define dprintf(one, two) -#endif - -/* Maximum number of primitives that can be handled. */ - -#ifndef BUFFER_SIZE -#define BUFFER_SIZE 0x400 -#endif - -static boolean Built_in_p; -static long Built_in_table_size; - -static char *The_Token; -static char Built_in_Token[] = "Built_In_Primitive"; -static char External_Token[] = "Define_Primitive"; - -static char *The_Table; -static char Built_in_Table[] = "Primitive"; -static char External_Table[] = "External"; - -static char *The_Variable; -static char Built_in_Variable[] = "MAX_PRIMITIVE"; -static char External_Variable[] = "MAX_EXTERNAL_PRIMITIVE"; - -static FILE *input, *output; -static char *name; -static char *file_name; - -static pseudo_void (*create_entry)(); - -main(argc, argv) - int argc; - char *argv[]; -{ - void process(), sort(), dump(); - FILE *fopen(); - - name = argv[0]; - - /* Check for specified output file */ - - if ((argc >= 2) && (strcmp("-o", argv[1]) == 0)) - { - if ((output = fopen(argv[2], "w")) == NULL) - { - fprintf(stderr, "Error: %s can't open %s\n", name, argv[2]); - error_exit(FALSE); - } - argv += 2; - argc -= 2; - } - else - output = stdout; - - /* Check whether to produce the built-in table instead. - The argument after the option letter is the size of the - table to build. - */ - - if ((argc >= 2) && (strcmp("-b", argv[1]) == 0)) - { - void initialize_builtin(); - - initialize_builtin(argv[2]); - argv += 2; - argc -= 2; - } - else - { - void initialize_external(); - - initialize_external(); - } - - /* Check whether there are any files left. */ - - if (argc == 1) - { - dump(FALSE); - normal_exit(); - } - - while (--argc > 0) - { - file_name = *++argv; - if (strcmp("-", file_name)==0) - { - input = stdin; - file_name = "stdin"; - dprintf("About to process %s\n", "STDIN"); - process(); - } - else if ((input = fopen(file_name, "r")) == NULL) - { - fprintf(stderr, "Error: %s can't open %s\n", name, file_name); - error_exit(TRUE); - } - else - { - dprintf("About to process %s\n", file_name); - process(); - fclose(input); - } - } - dprintf("About to sort %s\n", ""); - sort(); - dprintf("About to dump %s\n", ""); - dump(TRUE); - if (output != stdout) - fclose(output); - normal_exit(); -} - -#define DONE 0 -#define FOUND 1 - -/* Search for tokens and when found, create primitive entries. */ - -void -process() -{ - int scan(); - - while ((scan() != DONE)) - { - dprintf("Process: place found.%s\n", ""); - (*create_entry)(); - } - return; -} - -/* Search for token and stop when found. If you hit open comment - * character, read until you hit close comment character. - * *** FIX *** : It is not a complete C parser, thus it may be fooled, - * currently the token must always begin a line. -*/ - -int -scan() -{ - register char c, *temp; - - c = '\n'; - while(c != EOF) - { - switch(c) - { case '/': - if ((c = getc(input)) == '*') - { - c = getc(input); - while (TRUE) - { while (c != '*') - { if (c == EOF) - { fprintf(stderr, - "Error: EOF in comment in file %s, or %s confused\n", - file_name, name); - error_exit(TRUE); - } - c = getc(input); - } - if ((c = getc(input)) == '/') break; - } - } - else if (c != '\n') break; - - case '\n': - temp = &The_Token[0]; - while ((c = getc(input)) == *temp++) {} - if (temp[-1] == '\0') return FOUND; - ungetc(c, input); - break; - - default: {} - } - c = getc(input); - } - return DONE; -} - -boolean -whitespace(c) - char c; -{ - switch(c) - { case ' ': - case '\t': - case '\n': - case '(': - case ')': - case ',': return TRUE; - default: return FALSE; - } -} - -void -scan_to_token_start() -{ - char c; - - while (whitespace(c = getc(input))) {}; - ungetc(c, input); - return; -} - -/* *** FIX *** This should check for field overflow (n too small) */ - -void -copy_token(s, cap, Size) - char s[]; - boolean cap; - int *Size; -{ - register char c; - register int n = 0; - - while (!(whitespace(c = getc(input)))) - s[n++] = ((cap && isalpha(c) && islower(c))? toupper(c) : c); - s[n] = '\0'; - if (n > *Size) - *Size = n; - return; -} - -void -copy_string(is, s, cap, Size) - register char *is; - char s[]; - boolean cap; - int *Size; -{ - register char c; - register int n = 0; - - while ((c = *is++) != '\0') - s[n++] = ((cap && isalpha(c) && islower(c))? toupper(c) : c); - s[n] = '\0'; - if (n > *Size) - *Size = n; - return; -} - -#define STRING_SIZE 80 -#define ARITY_SIZE 6 - -typedef struct dsc -{ char C_Name[STRING_SIZE]; /* The C name of the function */ - char Arity[ARITY_SIZE]; /* Number of arguments */ - char Scheme_Name[STRING_SIZE]; /* Scheme name of the primitive */ - char File_Name[STRING_SIZE]; /* File where found. */ -} descriptor; - -/* - * *** FIX *** - * This should really be malloced incrementally, but for the time being ... - * - */ - -static int buffer_index = 0; -descriptor Data_Buffer[BUFFER_SIZE]; -descriptor *Result_Buffer[BUFFER_SIZE]; - -static descriptor Dummy_Entry = -{ "Dummy_Primitive", - "0", - "\"DUMMY-PRIMITIVE\"", - "Findprim.c" -}; - -static char Dummy_Error_String[] = - "Microcode_Termination(TERM_BAD_PRIMITIVE)"; - -static descriptor Inexistent_Entry = -{ "Prim_Inexistent", - "0", - "No_Name", - "Findprim.c" -}; - -static char Inexistent_Real_Name[] = - "\"INEXISTENT-PRIMITIVE\""; -static char Inexistent_Error_String[] = - "Primitive_Error(ERR_UNIMPLEMENTED_PRIMITIVE)"; - -static int C_Size = 0; -static int A_Size = 0; -static int S_Size = 0; -static int F_Size = 0; - -#define DONT_CAP FALSE -#define DO_CAP TRUE - -pseudo_void -create_external_entry() -{ - if (buffer_index >= BUFFER_SIZE) - { - fprintf(stderr, "Error: %s cannot handle so many primitives.\n", name); - fprintf(stderr, "Recompile %s with BUFFER_SIZE larger than %d.\n", - name, BUFFER_SIZE); - error_exit(FALSE); - } - scan_to_token_start(); - copy_token((Data_Buffer[buffer_index]).C_Name, DONT_CAP, &C_Size); - scan_to_token_start(); - copy_token((Data_Buffer[buffer_index]).Arity, DONT_CAP, &A_Size); - scan_to_token_start(); - copy_token((Data_Buffer[buffer_index]).Scheme_Name, DO_CAP, &S_Size); - copy_string(file_name, (Data_Buffer[buffer_index]).File_Name, DONT_CAP, &F_Size); - Result_Buffer[buffer_index] = &Data_Buffer[buffer_index]; - buffer_index++; - return; -} - -void -initialize_external() -{ - Built_in_p = FALSE; - The_Token = &External_Token[0]; - The_Table = &External_Table[0]; - The_Variable = &External_Variable[0]; - create_entry = create_external_entry; - return; -} - -void -initialize_from_entry(entry) - descriptor *entry; -{ - C_Size = strlen(entry->C_Name); - A_Size = strlen(entry->Arity); - S_Size = strlen(entry->Scheme_Name); - F_Size = strlen(entry->File_Name); - return; -} - -int -read_index(arg) - char *arg; -{ - int result = 0; - - if ((arg[0] == '0') && (arg[1] == 'x')) - sscanf(&arg[2], "%x", &result); - else - sscanf(&arg[0], "%d", &result); - return result; -} - -pseudo_void -create_builtin_entry() -{ - static char index_buffer[STRING_SIZE]; - int index = 0; - - scan_to_token_start(); - copy_token((Data_Buffer[buffer_index]).C_Name, DONT_CAP, &C_Size); - scan_to_token_start(); - copy_token((Data_Buffer[buffer_index]).Arity, DONT_CAP, &A_Size); - scan_to_token_start(); - copy_token((Data_Buffer[buffer_index]).Scheme_Name, DO_CAP, &S_Size); - copy_string(file_name, (Data_Buffer[buffer_index]).File_Name, DONT_CAP, &F_Size); - scan_to_token_start(); - copy_token(index_buffer, DONT_CAP, &index); - index = read_index(index_buffer); - if (index >= Built_in_table_size) - { - fprintf(stderr, "%s: Table size = %d; Found Primitive %d.\n", - name, Built_in_table_size, index); - error_exit(FALSE); - } - if (Result_Buffer[index] != &Inexistent_Entry) - { - void print_entry(), initialize_index_size(); - - fprintf(stderr, "%s: redefinition of primitive %d.\n", name, index); - fprintf(stderr, "previous definition:\n"); - initialize_index_size(); - output = stderr, - print_entry(index, Result_Buffer[index]); - fprintf(stderr, "\n"); - fprintf(stderr, "new definition:\n"); - print_entry(index, &Data_Buffer[buffer_index]); - fprintf(stderr, "\n"); - error_exit(FALSE); - } - Result_Buffer[index] = &Data_Buffer[buffer_index]; - buffer_index++; - return; -} - -void -initialize_builtin(arg) - char *arg; -{ - register int index; - - Built_in_p = TRUE; - Built_in_table_size = read_index(arg); - if (Built_in_table_size > BUFFER_SIZE) - { - fprintf(stderr, "%s: built_in_table_size > BUFFER_SIZE.\n", name); - fprintf(stderr, "Recompile with a larger value of BUFFER_SIZE.\n"); - error_exit(FALSE); - } - The_Token = &Built_in_Token[0]; - The_Table = &Built_in_Table[0]; - The_Variable = &Built_in_Variable[0]; - create_entry = create_builtin_entry; - for (index = Built_in_table_size; --index >= 0; ) - Result_Buffer[index] = &Inexistent_Entry; - initialize_from_entry(&Inexistent_Entry); - return; -} - -/* *** FIX *** No-op for now */ - -void -sort() -{ - return; -} - -static int max, max_index_size; -static char index_buffer[STRING_SIZE]; - -#define find_index_size(index, size) \ -{ \ - sprintf(index_buffer, "%x", (index)); \ - size = strlen(index_buffer); \ -} - -void -initialize_index_size() -{ - if (Built_in_p) - max = Built_in_table_size; - else - max = buffer_index; - find_index_size(max, max_index_size); - max -= 1; - return; -} - -void -print_spaces(how_many) - register int how_many; -{ - for(; --how_many >= 0;) - putc(' ', output); - return; -} - -void -print_entry(index, entry) - int index; - descriptor *entry; -{ - int index_size; - - fprintf(output, " %s ", (entry->C_Name)); - print_spaces(C_Size - (strlen(entry->C_Name))); - fprintf(output, "/%c ", '*'); - print_spaces(A_Size - (strlen(entry->Arity))); - fprintf(output, - "%s %s", - (entry->Arity), - (entry->Scheme_Name)); - print_spaces(S_Size-(strlen(entry->Scheme_Name))); - fprintf(output, " %s ", ((Built_in_p) ? "Primitive" : "External")); - find_index_size(index, index_size); - print_spaces(max_index_size - index_size); - fprintf(output, "0x%x in %s %c/", index, (entry->File_Name), '*'); - return; -} - -void -print_procedure(entry, error_string) - descriptor *entry; - char *error_string; -{ - fprintf(output, "Pointer\n"); - fprintf(output, "%s()\n", (entry->C_Name)); - fprintf(output, "{\n"); - fprintf(output, " Primitive_%s_Args();\n", (entry->Arity)); - fprintf(output, "\n"); - fprintf(output, " %s;\n", error_string); - fprintf(output, "}\n\n"); - return; -} - -void -print_primitives(last) - register int last; -{ - - register int count; - - /* Print the procedure table. */ - - fprintf(output, "Pointer (*(%s_Procedure_Table[]))() = {\n", The_Table); - - for (count = 0; count < last; count++) - { - print_entry(count, Result_Buffer[count]); - fprintf(output, ",\n"); - } - print_entry(last, Result_Buffer[last]); - fprintf(output, "\n};\n\n"); - - /* Print the arity table. */ - - fprintf(output, "int %s_Arity_Table[] = {\n", The_Table); - - for (count = 0; count < last; count++) - { - fprintf(output, " %s,\n", ((Result_Buffer[count])->Arity)); - } - fprintf(output, " %s\n", ((Result_Buffer[last])->Arity)); - fprintf(output, "};\n\n"); - - /* Print the names table. */ - - fprintf(output, "char *%s_Name_Table[] = {\n", The_Table); - - for (count = 0; count < last; count++) - { - fprintf(output, " %s,\n", ((Result_Buffer[count])->Scheme_Name)); - } - fprintf(output, " %s\n", ((Result_Buffer[last])->Scheme_Name)); - fprintf(output, "};\n\n"); - - return; -} - -/* Produce C source. */ - -void -dump(check) - boolean check; -{ - register int count, end; - - initialize_index_size(); - - /* Print header. */ - - fprintf(output, "/%c Emacs: This is -*- C -*- code. %c/\n\n", '*', '*'); - - fprintf(output, "/%c %s primitive declarations %c/\n\n", - '*', ((Built_in_p) ? "Built in" : "User defined" ), '*'); - - fprintf(output, "#include \"usrdef.h\"\n\n"); - - fprintf(output, "long %s = %d;\n\n", The_Variable, max); - if (Built_in_p) - fprintf(output, - "/%c The number of implemented primitives is %d. %c/\n\n", - '*', buffer_index, '*'); - - if (max < 0) - { - if (check) - fprintf(stderr, "No primitives found!\n"); - - /* C does not understand the empty array, thus it must be faked. */ - - fprintf(output, "/%c C does not understand the empty array, ", '*'); - fprintf(output, "thus it must be faked. %c/\n\n", '*'); - - /* Dummy entry */ - - Result_Buffer[0] = &Dummy_Entry; - initialize_from_entry(&Dummy_Entry); - print_procedure(&Dummy_Entry, &Dummy_Error_String[0]); - - } - - else - { - /* Print declarations. */ - - fprintf(output, "extern Pointer\n"); - - end = (Built_in_p ? buffer_index : max); - for (count = 0; count < end; count++) - { - fprintf(output, " %s(),\n", &(Data_Buffer[count].C_Name)[0]); - } - - if (Built_in_p) - { - fprintf(output, " %s();\n\n", &(Inexistent_Entry.C_Name)[0]); - - fprintf(output, - "static char %s[] = %s;\n\n", - Inexistent_Entry.Scheme_Name, - Inexistent_Real_Name); - print_procedure(&Inexistent_Entry, &Inexistent_Error_String[0]); - } - else - fprintf(output, " %s();\n\n", &(Data_Buffer[end].C_Name)[0]); - - } - - print_primitives((max < 0) ? 0 : max); - return; -} diff --git a/v7/src/microcode/fixnum.c b/v7/src/microcode/fixnum.c deleted file mode 100644 index d90cf5661..000000000 --- a/v7/src/microcode/fixnum.c +++ /dev/null @@ -1,243 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fixnum.c,v 9.22 1987/04/16 02:22:24 jinx Exp $ - * - * Support for fixed point arithmetic (24 bit). Mostly superceded - * by generic arithmetic. - */ - -#include "scheme.h" -#include "primitive.h" - - /***************************/ - /* UNARY FIXNUM OPERATIONS */ - /***************************/ - -/* These operations return NIL if their argument is not a fixnum. - Otherwise, they return the appropriate fixnum if the result is - expressible as a fixnum. If the result is out of range, they - return NIL. -*/ - -Built_In_Primitive(Prim_One_Plus_Fixnum, 1, "ONE-PLUS-FIXNUM", 0x42) -{ - fast long A, Result; - Primitive_1_Arg(); - - Arg_1_Type(TC_FIXNUM); - Sign_Extend(Arg1, A); - Result = A + 1; - if (Fixnum_Fits(Result)) - return Make_Non_Pointer(TC_FIXNUM, Result); - else - return NIL; -} - -Built_In_Primitive(Prim_M_1_Plus_Fixnum, 1, "MINUS-ONE-PLUS-FIXNUM", 0x43) -{ - fast long A, Result; - Primitive_1_Arg(); - - Arg_1_Type(TC_FIXNUM); - Sign_Extend(Arg1, A); - Result = A - 1; - if (Fixnum_Fits(Result)) - return Make_Non_Pointer(TC_FIXNUM, Result); - else - return NIL; -} - - /****************************/ - /* BINARY FIXNUM PREDICATES */ - /****************************/ - -/* Binary fixnum predicates return NIL if their argument is not a - fixnum, 1 if the predicate is true, or 0 if the predicate is false. -*/ - -#define Binary_Predicate_Fixnum(Op) \ -{ \ - fast long A, B; \ - Primitive_2_Args(); \ - \ - Arg_1_Type(TC_FIXNUM); \ - Arg_2_Type(TC_FIXNUM); \ - Sign_Extend(Arg1, A); \ - Sign_Extend(Arg2, B); \ - return Make_Unsigned_Fixnum(((A Op B) ? 1 : 0)); \ -} - -Built_In_Primitive(Prim_Equal_Fixnum, 2, "EQUAL-FIXNUM?", 0x3F) -{ - Binary_Predicate_Fixnum(==); -} - -Built_In_Primitive(Prim_Greater_Fixnum, 2, "LESS-THAN-FIXNUM?", 0x40) -{ - Binary_Predicate_Fixnum(>); -} - -Built_In_Primitive(Prim_Less_Fixnum, 2, "GREATER-THAN-FIXNUM?", 0x81) -{ - Binary_Predicate_Fixnum(<); -} - - /****************************/ - /* BINARY FIXNUM OPERATIONS */ - /****************************/ - -/* All binary fixnum operations take two arguments and return NIL if - either is not a fixnum. If both arguments are fixnums and the - result fits as a fixnum, then the result is returned. If the - result will not fit as a fixnum, NIL is returned. -*/ - -#define Binary_Fixnum(Op) \ -{ \ - fast long A, B, Result; \ - Primitive_2_Args(); \ - \ - Arg_1_Type(TC_FIXNUM); \ - Arg_2_Type(TC_FIXNUM); \ - Sign_Extend(Arg1, A); \ - Sign_Extend(Arg2, B); \ - Result = A Op B; \ - if (Fixnum_Fits(Result)) \ - return Make_Non_Pointer(TC_FIXNUM, Result); \ - else \ - return NIL; \ -} - -Built_In_Primitive(Prim_Plus_Fixnum, 2, "PLUS-FIXNUM", 0x3B) -{ - Binary_Fixnum(+); -} - -Built_In_Primitive(Prim_Minus_Fixnum, 2, "MINUS-FIXNUM", 0x3C) -{ - Binary_Fixnum(-); -} - -Built_In_Primitive(Prim_Multiply_Fixnum, 2, "MULTIPLY-FIXNUM", 0x3D) -{ - /* Mul, which does the multiplication with overflow handling is - machine dependent. Therefore, it is in os.c - */ - extern Pointer Mul(); - Primitive_2_Args(); - - Arg_1_Type(TC_FIXNUM); - Arg_2_Type(TC_FIXNUM); - return Mul(Arg1, Arg2); -} - -Built_In_Primitive(Prim_Divide_Fixnum, 2, "DIVIDE-FIXNUM", 0x3E) -{ - - /* Returns the CONS of quotient and remainder */ - fast long A, B, Quotient, Remainder; - Primitive_2_Args(); - - Arg_1_Type(TC_FIXNUM); - Arg_2_Type(TC_FIXNUM); - Sign_Extend(Arg1, A); Sign_Extend(Arg2, B); - if (B == 0) - Primitive_Error(ERR_ARG_2_BAD_RANGE); - Primitive_GC_If_Needed(2); - Quotient = A/B; - Remainder = A%B; - if (Fixnum_Fits(Quotient)) - { Free[CONS_CAR] = Make_Non_Pointer(TC_FIXNUM, Quotient); - Free[CONS_CDR] = Make_Non_Pointer(TC_FIXNUM, Remainder); - Free += 2; - return Make_Pointer(TC_LIST, Free-2); - } - return NIL; -} - -Built_In_Primitive(Prim_Gcd_Fixnum, 2, "GCD-FIXNUM", 0x66) -{ - /* Returns the Greatest Common Divisor */ - fast long A, B, C; - Primitive_2_Args(); - - Arg_1_Type(TC_FIXNUM); - Arg_2_Type(TC_FIXNUM); - Sign_Extend(Arg1, A); Sign_Extend(Arg2, B); - while (B != 0) - { C = A; - A = B; - B = C % B; - } - return Make_Non_Pointer(TC_FIXNUM, A); -} - -/* (NEGATIVE-FIXNUM? NUMBER) - Returns NIL if NUMBER isn't a fixnum. Returns 0 if NUMBER < 0, 1 - if NUMBER >= 0. -*/ -Built_In_Primitive(Prim_Negative_Fixnum, 1, "NEGATIVE-FIXNUM?", 0x7F) -{ - long Value; - Primitive_1_Arg(); - - Arg_1_Type(TC_FIXNUM); - Sign_Extend(Arg1, Value); - return Make_Unsigned_Fixnum(((Value < 0) ? 1 : 0)); -} - -/* (POSITIVE-FIXNUM? NUMBER) - Returns 1 if NUMBER is a positive fixnum, 0 for other fixnums, - or NIL. -*/ -Built_In_Primitive(Prim_Positive_Fixnum, 1, "POSITIVE-FIXNUM?", 0x41) -{ - long Value; - Primitive_1_Arg(); - - Arg_1_Type(TC_FIXNUM); - Sign_Extend(Arg1, Value); - return Make_Unsigned_Fixnum(((Value > 0) ? 1 : 0)); -} - -/* (ZERO-FIXNUM? NUMBER) - Returns NIL if NUMBER isn't a fixnum. Otherwise, returns 0 if - NUMBER is 0 or 1 if it is. -*/ -Built_In_Primitive(Prim_Zero_Fixnum, 1, "ZERO-FIXNUM?", 0x46) -{ - Primitive_1_Arg(); - - Arg_1_Type(TC_FIXNUM); - return Make_Unsigned_Fixnum(((Get_Integer(Arg1) == 0) ? 1 : 0)); -} diff --git a/v7/src/microcode/fixobj.h b/v7/src/microcode/fixobj.h deleted file mode 100644 index ba8933919..000000000 --- a/v7/src/microcode/fixobj.h +++ /dev/null @@ -1,75 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fixobj.h,v 9.24 1987/04/03 00:12:59 jinx Exp $ - * - * Declarations of user offsets into the Fixed Objects Vector. - * This should correspond to the file UTABMD.SCM - */ - -#define Non_Object 0x00 /* Used for unassigned variables */ -#define System_Interrupt_Vector 0x01 /* Handlers for interrups */ -#define System_Error_Vector 0x02 /* Handlers for errors */ -#define OBArray 0x03 /* Array for interning symbols */ -#define Types_Vector 0x04 /* Type number -> Name map */ -#define Returns_Vector 0x05 /* Return code -> Name map */ -#define Primitives_Vector 0x06 /* Primitive code -> Name map */ -#define Errors_Vector 0x07 /* Error code -> Name map */ -#define Identification_Vector 0x08 /* ID Vector index -> name map */ -#define GC_Daemon 0x0B /* Procedure to run after GC */ -#define Trap_Handler 0x0C /* Continue after disaster */ -#define Stepper_State 0x0E /* NOT IMPLEMENTED YET */ -#define Fixed_Objects_Slots 0x0F /* Names of these slots */ -#define External_Primitives 0x10 /* Names of external prims */ -#define State_Space_Tag 0x11 /* Tag for state spaces */ -#define State_Point_Tag 0x12 /* Tag for state points */ -#define Dummy_History 0x13 /* Empty history structure */ -#define Bignum_One 0x14 /* Cache for bignum one */ -#define System_Scheduler 0x15 /* Scheduler for touched futures */ -#define Termination_Vector 0x16 /* Names for terminations */ -#define Termination_Proc_Vector 0x17 /* Handlers for terminations */ -#define Me_Myself 0x18 /* The actual shared vector */ -/* The next slot is used only in multiprocessor mode */ -#define The_Work_Queue 0x19 /* Where work is stored */ -/* These two slots are only used if logging futures */ -#define Future_Logger 0x1A /* Routine to log touched futures */ -#define Touched_Futures 0x1B /* Vector of touched futures */ -#define Precious_Objects 0x1C /* Objects that should not be lost! */ -#define Error_Procedure 0x1D /* User invoked error handler */ -#define Unsnapped_Link 0x1E /* Handler for call to compiled code */ -#define Utilities_Vector 0x1F /* ??? */ -#define Compiler_Err_Procedure 0x20 /* ??? */ -#define Lost_Objects_Base 0x21 /* Free at the end of the "real" gc. */ -#define State_Space_Root 0x22 /* Root of state space */ - -#define NFixed_Objects 0x23 - diff --git a/v7/src/microcode/flonum.c b/v7/src/microcode/flonum.c deleted file mode 100644 index 1fd34e20e..000000000 --- a/v7/src/microcode/flonum.c +++ /dev/null @@ -1,301 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/flonum.c,v 9.22 1987/04/16 02:22:34 jinx Rel $ - * - * This file contains support for floating point arithmetic. Most - * of these primitives have been superceded by generic arithmetic. - */ - -#include "scheme.h" -#include "primitive.h" -#include "flonum.h" -#include "zones.h" - - /************************************/ - /* BINARY FLOATING POINT OPERATIONS */ - /************************************/ - -/* The binary floating point operations return NIL if either argument - is not a floating point number. Otherwise they return the - appropriate result. -*/ - -Built_In_Primitive(Prim_Plus_Flonum, 2, "PLUS-FLONUM", 0x69) -{ - Primitive_2_Args(); - - Arg_1_Type(TC_BIG_FLONUM); - Arg_2_Type(TC_BIG_FLONUM); - Set_Time_Zone(Zone_Math); - Flonum_Result(Get_Float(Arg1) + Get_Float(Arg2)); -} - -Built_In_Primitive(Prim_Minus_Flonum, 2, "MINUS-FLONUM", 0x6A) -{ - Primitive_2_Args(); - - Arg_1_Type(TC_BIG_FLONUM); - Arg_2_Type(TC_BIG_FLONUM); - Set_Time_Zone(Zone_Math); - Flonum_Result(Get_Float(Arg1) - Get_Float(Arg2)); -} - -Built_In_Primitive(Prim_Multiply_Flonum, 2, "MULTIPLY-FLONUM", 0x6B) -{ - Primitive_2_Args(); - - Arg_1_Type(TC_BIG_FLONUM); - Arg_2_Type(TC_BIG_FLONUM); - Set_Time_Zone(Zone_Math); - Flonum_Result(Get_Float(Arg1) * Get_Float(Arg2)); -} - -Built_In_Primitive(Prim_Divide_Flonum, 2, "DIVIDE-FLONUM", 0x6C) -{ - Primitive_2_Args(); - - Arg_1_Type(TC_BIG_FLONUM); - Arg_2_Type(TC_BIG_FLONUM); - Set_Time_Zone(Zone_Math); - if (Get_Float(Arg2) == 0) - Primitive_Error(ERR_ARG_2_BAD_RANGE); - Flonum_Result(Get_Float(Arg1) / Get_Float(Arg2)); -} - - /************************************/ - /* BINARY FLOATING POINT PREDICATES */ - /************************************/ - -/* The binary flonum predicates return NIL if either of the arguments - is not a flonum. Otherwise, return a fixnum 1 if the predicate is - true, or a fixnum 0 if it is false. -*/ - -Built_In_Primitive(Prim_Equal_Flonum, 2, "EQUAL-FLONUM?", 0x6D) -{ - Primitive_2_Args(); - - Arg_1_Type(TC_BIG_FLONUM); - Arg_2_Type(TC_BIG_FLONUM); - Set_Time_Zone(Zone_Math); - return - Make_Unsigned_Fixnum(((Get_Float(Arg1)) == (Get_Float(Arg2))) ? 1 : 0); -} - -Built_In_Primitive(Prim_Greater_Flonum, 2, "GREATER-THAN-FLONUM?", 0xAA) -{ - Primitive_2_Args(); - - Arg_1_Type(TC_BIG_FLONUM); - Arg_2_Type(TC_BIG_FLONUM); - Set_Time_Zone(Zone_Math); - return - Make_Unsigned_Fixnum(((Get_Float(Arg1)) > (Get_Float(Arg2))) ? 1 : 0); -} - -Built_In_Primitive(Prim_Less_Flonum, 2, "LESS-THAN-FLONUM?", 0x6E) -{ - Primitive_2_Args(); - - Arg_1_Type(TC_BIG_FLONUM); - Arg_2_Type(TC_BIG_FLONUM); - Set_Time_Zone(Zone_Math); - return - Make_Unsigned_Fixnum(((Get_Float(Arg1)) < (Get_Float(Arg2))) ? 1 : 0); -} - - /***********************************/ - /* UNARY FLOATING POINT OPERATIONS */ - /***********************************/ - -/* The unary flonum operations return NIL if their argument is - not a flonum. Otherwise, they return the appropriate result. -*/ - -Built_In_Primitive(Prim_Sine_Flonum, 1, "SINE-FLONUM", 0x73) -{ - extern double sin(); - Primitive_1_Arg(); - - Arg_1_Type(TC_BIG_FLONUM); - Set_Time_Zone(Zone_Math); - Flonum_Result(sin(Get_Float(Arg1))); -} - -Built_In_Primitive(Prim_Cosine_Flonum, 1, "COSINE-FLONUM", 0x74) -{ - extern double cos(); - Primitive_1_Arg(); - - Arg_1_Type(TC_BIG_FLONUM); - Set_Time_Zone(Zone_Math); - Flonum_Result(cos(Get_Float(Arg1))); -} - -Built_In_Primitive(Prim_Arctan_Flonum, 1, "ARCTAN-FLONUM", 0x75) -{ - extern double atan(); - Primitive_1_Arg(); - - Arg_1_Type(TC_BIG_FLONUM); - Set_Time_Zone(Zone_Math); - Flonum_Result(atan(Get_Float(Arg1))); -} - -Built_In_Primitive(Prim_Exp_Flonum, 1, "EXP-FLONUM", 0x76) -{ - extern double exp(); - Primitive_1_Arg(); - - Arg_1_Type(TC_BIG_FLONUM); - Set_Time_Zone(Zone_Math); - Flonum_Result(exp(Get_Float(Arg1))); -} - -Built_In_Primitive(Prim_Ln_Flonum, 1, "LN-FLONUM", 0x77) -{ - extern double log(); - Primitive_1_Arg(); - - Arg_1_Type(TC_BIG_FLONUM); - Set_Time_Zone(Zone_Math); - if (Arg1 <= 0.0) - Primitive_Error(ERR_ARG_1_BAD_RANGE); - Flonum_Result(log(Get_Float(Arg1))); -} - -Built_In_Primitive(Prim_Sqrt_Flonum, 1, "SQRT-FLONUM", 0x78) -{ - extern double sqrt(); - double Arg; - Primitive_1_Arg(); - - Arg_1_Type(TC_BIG_FLONUM); - Set_Time_Zone(Zone_Math); - Arg = Get_Float(Arg1); - if (Arg < 0) - return NIL; - Flonum_Result(sqrt(Arg)); -} - -Built_In_Primitive(Prim_Zero_Flonum, 1, "ZERO-FLONUM?", 0xA7) -{ - Primitive_1_Arg(); - - Arg_1_Type(TC_BIG_FLONUM); - Set_Time_Zone(Zone_Math); - return Make_Unsigned_Fixnum((Get_Float(Arg1) == 0.0) ? 1 : 0); -} - -Built_In_Primitive(Prim_Positive_Flonum, 1, "POSITIVE-FLONUM?", 0xA8) -{ - Primitive_1_Arg(); - - Arg_1_Type(TC_BIG_FLONUM); - Set_Time_Zone(Zone_Math); - return Make_Unsigned_Fixnum((Get_Float(Arg1) > 0.0) ? 1 : 0); -} - -Built_In_Primitive(Prim_Negative_Flonum, 1, "NEGATIVE-FLONUM?", 0xA9) -{ - Primitive_1_Arg(); - - Arg_1_Type(TC_BIG_FLONUM); - Set_Time_Zone(Zone_Math); - return Make_Unsigned_Fixnum((Get_Float(Arg1) < 0.0) ? 1 : 0); -} - -/* (COERCE-INTEGER-TO-FLONUM FIXNUM-OR-BIGNUM) - Returns the floating point number (flonum) corresponding to - either a bignum or a fixnum. If the bignum is too large or small - to be converted to floating point, or if the argument isn't of - the correct type, FIXNUM-OR-BIGNUM is returned unchanged. -*/ -Built_In_Primitive(Prim_Int_To_Float, 1, "COERCE-INTEGER-TO-FLONUM", 0x72) -{ - Primitive_1_Arg(); - - Set_Time_Zone(Zone_Math); - if (Type_Code(Arg1)==TC_FIXNUM) - { - long Int; - - Sign_Extend(Arg1, Int); - return Allocate_Float((double) Int); - } - if (Type_Code(Arg1) == TC_BIG_FIXNUM) - return Big_To_Float(Arg1); - return Arg1; -} - -/* (TRUNCATE-FLONUM FLONUM) - Returns the integer corresponding to FLONUM when truncated. - Returns NIL if FLONUM isn't a floating point number -*/ -Built_In_Primitive(Prim_Truncate_Flonum, 1, "TRUNCATE-FLONUM", 0x70) -{ - fast double A; - long Answer; /* Faulty VAX/UNIX C optimizer */ - Primitive_1_Arg(); - - Arg_1_Type(TC_BIG_FLONUM); - Set_Time_Zone(Zone_Math); - A = Get_Float(Arg1); - if (flonum_exceeds_fixnum(A)) - return Float_To_Big(A); - Answer = (long) A; - return Make_Non_Pointer(TC_FIXNUM, Answer); -} - -/* (ROUND-FLONUM FLONUM) - Returns the integer found by rounding off FLONUM (upward), if - FLONUM is a floating point number. Otherwise returns FLONUM. -*/ -Built_In_Primitive(Prim_Round_Flonum, 1, "ROUND-FLONUM", 0x71) -{ - fast double A; - long Answer; /* Faulty VAX/UNIX C optimizer */ - Primitive_1_Arg(); - - Set_Time_Zone(Zone_Math); - if (Type_Code(Arg1) != TC_BIG_FLONUM) return Arg1; - A = Get_Float(Arg1); - if (A >= 0) - A += 0.5; - else - A -= 0.5; - if (flonum_exceeds_fixnum(A)) - return Float_To_Big(A); - Answer = (long) A; - return Make_Non_Pointer(TC_FIXNUM, Answer); -} diff --git a/v7/src/microcode/future.c b/v7/src/microcode/future.c deleted file mode 100644 index f9d4a3c4e..000000000 --- a/v7/src/microcode/future.c +++ /dev/null @@ -1,357 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/future.c,v 9.22 1987/04/16 02:22:53 jinx Exp $ - - Support code for futures -*/ - -#include "scheme.h" -#include "primitive.h" -#include "locks.h" - -#ifndef COMPILE_FUTURES -#include "Error: future.c is useless without COMPILE_FUTURES" -#endif - -/* - -A future is a VECTOR starting with , and -, - -where is #!false if no value is known yet, - #!true if value is known and future can vanish at GC, - otherwise value is known, but keep the slot - -and where is #!true if someone wants slot kept for a time. - -*/ - -Define_Primitive(Prim_Touch, 1, "TOUCH") -{ Pointer Result; - Primitive_1_Arg(); - Touch_In_Primitive(Arg1, Result); - return Result; -} - -Define_Primitive(Prim_Future_P, 1, "FUTURE?") -{ Primitive_1_Arg(); - return (Type_Code(Arg1) == TC_FUTURE) ? TRUTH : NIL; -} - -/* Utility setting routine for use by the various test and set if - equal operators. -*/ - -long Set_If_Equal(Base, Offset, New, Wanted) -Pointer Base, Wanted, New; -long Offset; -{ Lock_Handle lock; - Pointer Old_Value, Desired, Remember_Value; - long success; - - Touch_In_Primitive(Wanted, Desired); -Try_Again: - Remember_Value = Vector_Ref(Base, Offset); - Touch_In_Primitive(Remember_Value, Old_Value); - lock = Lock_Cell(Nth_Vector_Loc(Base, Offset)); - if (Remember_Value != Fast_Vector_Ref(Base, Offset)) - { Unlock_Cell(lock); - goto Try_Again; - } - if (Old_Value == Desired) - { Do_Store_No_Lock(Nth_Vector_Loc(Base, Offset), New); - success = true; - } - else success = false; - Unlock_Cell(lock); - return success; -} - -Define_Primitive(Prim_Set_Car_If_Eq, 3, "SET-CAR-IF-EQ?!") -/* (SET-CAR-IF-EQ?! ) - Replaces the CAR of with if it used to contain - . The value returned is either (if the modification - takes place) or '() if it does not. -*/ -{ Primitive_3_Args(); - Arg_1_Type(TC_LIST); - if (Set_If_Equal(Arg1, CONS_CAR, Arg2, Arg3)) return Arg1; - else return NIL; -} - -Define_Primitive(Prim_Set_Cdr_If_Eq, 3, "SET-CDR-IF-EQ?!") -/* (SET-CDR-IF-EQ?! ) - Replaces the CDR of with if it used to contain - . The value returned is either (if the modification - takes place) or '() if it does not. -*/ -{ Primitive_3_Args(); - Arg_1_Type(TC_LIST); - if (Set_If_Equal(Arg1, CONS_CDR, Arg2, Arg3)) return Arg1; - else return NIL; -} - -Define_Primitive(Prim_Vector_Set_If_Eq, 4, "VECTOR-SET-IF-EQ?!") -/* (VECTOR-SET-IF-EQ?! ) - Replaces the th element of with if it used - to contain . The value returned is either (if - the modification takes place) or '() if it does not. -*/ -{ long Offset; - Primitive_4_Args(); - Arg_1_Type(TC_VECTOR); - Arg_2_Type(TC_FIXNUM); - Range_Check(Offset, Arg2, - 0, Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE); - if (Set_If_Equal(Arg1, Offset, Arg3, Arg4)) return Arg1; - else return NIL; -} - -Define_Primitive(Prim_Set_Cxr_If_Eq, 4, "SET-CXR-IF-EQ?!") -/* (SET-CXR-IF-EQ?! ) - Replaces the th CXR of with if it used to - contain . The value returned is either (if - the modification takes place) or '() if it does not. -*/ -{ Pointer Arg4; - long Offset; - Primitive_3_Args(); - Arg4 = Stack_Ref(3); - Arg_1_Type(TC_HUNK3); - Arg_2_Type(TC_FIXNUM); - Range_Check(Offset, Arg2, 0, 2, ERR_ARG_2_BAD_RANGE); - if (Set_If_Equal(Arg1, Offset, Arg3, Arg4)) return Arg1; - else return NIL; -} - -Define_Primitive(Prim_Future_Ref, 2, "FUTURE-REF") -/* (FUTURE-REF ) - Returns the th slot from the future object. This is - the equivalent of SYSTEM-VECTOR-REF but works only on future - objects and doesn't touch. -*/ -{ long Offset; - Primitive_2_Args(); - Arg_1_Type(TC_FUTURE); - Arg_2_Type(TC_FIXNUM); - Range_Check(Offset, Arg2, - 0, Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE); - return User_Vector_Ref(Arg1, Offset); -} - -Define_Primitive(Prim_Future_Set, 3, "FUTURE-SET!") -/* (FUTURE-SET! ) - Modifies the th slot from the future object. This is - the equivalent of SYSTEM-VECTOR-SET! but works only on future - objects and doesn't touch. -*/ -{ long Offset; - Pointer Result; - Primitive_3_Args(); - Arg_1_Type(TC_FUTURE); - Arg_2_Type(TC_FIXNUM); - Range_Check(Offset, Arg2, - 0, Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE); - Result = User_Vector_Ref(Arg1, Offset); - User_Vector_Set(Arg1, Offset,Arg3); - return Result; -} - -Define_Primitive(Prim_Future_Size, 1, "FUTURE-SIZE") -/* (FUTURE-SIZE ) - Returns the number of slots in the future object. This is - the equivalent of SYSTEM-VECTOR-SIZE but works only on future - objects and doesn't touch. -*/ -{ Primitive_1_Arg(); - Arg_1_Type(TC_FUTURE); - return Make_Unsigned_Fixnum(Vector_Length(Arg1)); -} - -Define_Primitive(Prim_Lock_Future, 1, "LOCK-FUTURE!") -/* (LOCK-FUTURE! ) - Sets the lock flag on the future object, so that it won't be - spliced-out by the garbage collector. Returns #!false if the - argument isn't a future (might have been determined in the - interim), #!TRUE if it is a future. Hangs as long as necessary - for the lock to take, since Scheme code operates while locked. - Opposite of UNLOCK-FUTURE!. -*/ -{ Primitive_1_Arg(); - if (Type_Code(Arg1) != TC_FUTURE) return NIL; - while ((IntEnb & IntCode) == 0) - if (Swap_Pointers(Nth_Vector_Loc(Arg1, FUTURE_LOCK), - TRUTH) == NIL) - return TRUTH; - else Sleep(CONTENTION_DELAY); - Primitive_Interrupt(); -} - -Define_Primitive(Prim_Unlock_Future, 1, "UNLOCK-FUTURE!") -/* (UNLOCK-FUTURE! ) - Clears the lock flag on a locked future object, otherwise nothing. -*/ -{ Primitive_1_Arg(); - if (Type_Code(Arg1) != TC_FUTURE) return NIL; - if (!Future_Is_Locked(Arg1)) - Primitive_Error(ERR_ARG_1_WRONG_TYPE) - else - { Vector_Set(Arg1, FUTURE_LOCK, NIL); - return TRUTH; - }; -} - -Define_Primitive(Prim_Future_To_Vector, 1, "FUTURE->VECTOR") -/* (FUTURE->VECTOR ) - Create a COPY of but with type code vector. -*/ -{ Pointer Result = Make_Pointer(TC_VECTOR, Free); - long Size, i; - Primitive_1_Arg(); - if (Type_Code(Arg1) != TC_FUTURE) return NIL; - Size = Vector_Length(Arg1); - Primitive_GC_If_Needed(Size + 1); - for (i=0; i <= Size; i++) *Free++ = Vector_Ref(Arg1, i); - return Result; -} - -Define_Primitive(Prim_Future_Eq, 2, "NON-TOUCHING-EQ?") -{ Primitive_2_Args(); - return ((Arg1==Arg2) ? TRUTH : NIL); -} - -/* MAKE-INITIAL-PROCESS is called to create a small stacklet which - * will just call the specified thunk and then end the computation - */ - -Define_Primitive(Prim_Make_Initial_Process, 1, "MAKE-INITIAL-PROCESS") -{ Pointer Result; - long Useful_Length, Allocated_Length, Waste_Length; - Primitive_1_Arg(); - - Result = Make_Pointer(TC_CONTROL_POINT, Free); - Useful_Length = 3*CONTINUATION_SIZE+STACK_ENV_EXTRA_SLOTS+1; -#ifdef USE_STACKLETS - if ((Useful_Length+STACKLET_SLACK+STACKLET_HEADER_SIZE) < - Default_Stacklet_Size) - Allocated_Length = Default_Stacklet_Size; - else Allocated_Length = - Useful_Length+STACKLET_SLACK+STACKLET_HEADER_SIZE; - Primitive_GC_If_Needed(Allocated_Length+1); - Waste_Length = (Allocated_Length-Useful_Length-STACKLET_HEADER_SIZE)+1; - Free[STACKLET_LENGTH] = - Make_Pointer(TC_MANIFEST_VECTOR, Allocated_Length); - Free[STACKLET_UNUSED_LENGTH] = - DANGER_BIT | (Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, - Waste_Length)); - Free += Allocated_Length-Useful_Length+1; -#else - Free[STACKLET_LENGTH] = - Make_Non_Pointer(TC_MANIFEST_VECTOR, - Useful_Length + STACKLET_HEADER_SIZE - 1); - Free[STACKLET_UNUSED_LENGTH] = - Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0); - Free += STACKLET_HEADER_SIZE; -#endif -/* Make_Initial_Process continues on the next page */ - -/* Make_Initial_Process continued */ - - Free[CONTINUATION_EXPRESSION] = Make_Non_Pointer(TC_FIXNUM, IntEnb); - Free[CONTINUATION_RETURN_CODE] = - Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_INT_MASK); - Free += CONTINUATION_SIZE; - Free[CONTINUATION_EXPRESSION] = NIL; - Free[CONTINUATION_RETURN_CODE] = - Make_Non_Pointer(TC_RETURN_CODE, RC_INTERNAL_APPLY); - Free += CONTINUATION_SIZE; - *Free++ = STACK_FRAME_HEADER; - *Free++ = Arg1; - Free[CONTINUATION_EXPRESSION] = Arg1; /* For testing & debugging */ - Free[CONTINUATION_RETURN_CODE] = - Make_Non_Pointer(TC_RETURN_CODE, RC_END_OF_COMPUTATION); - Free += CONTINUATION_SIZE; - return Result; -} - -/* - Absolutely the cheapest future we can make. This includes - the I/O stuff and whatnot. Notice that the name is required. - - (make-cheap-future orig-code user-proc name) - -*/ - -Define_Primitive(Prim_Make_Cheap_Future, 3, "MAKE-CHEAP-FUTURE") -{ Pointer The_Future; - Pointer IO_Vector, IO_Cons, IO_Hunk3, Empty_Queue, IO_String; - Primitive_3_Args(); - - Primitive_GC_If_Needed(21); - - Empty_Queue=Make_Pointer(TC_LIST,Free); - *Free++=NIL; - *Free++=NIL; - - IO_String=Make_Pointer(TC_CHARACTER_STRING,Free); - *Free++=Make_Non_Pointer(TC_MANIFEST_NM_VECTOR,1); - *Free++=Make_Unsigned_Fixnum(0); - - IO_Cons=Make_Pointer(TC_LIST,Free); - *Free++=Make_Unsigned_Fixnum(0); - *Free++=IO_String; - - IO_Hunk3=Make_Pointer(TC_HUNK3,Free); - *Free++=NIL; - *Free++=Arg3; - *Free++=IO_Cons; - - IO_Vector=Make_Pointer(TC_VECTOR,Free); - *Free++=Make_Non_Pointer(TC_MANIFEST_VECTOR,1); - *Free++=IO_Hunk3; - - The_Future=Make_Pointer(TC_FUTURE,Free); - *Free++=Make_Non_Pointer(TC_MANIFEST_VECTOR,10); - *Free++=NIL; /* No value yet. */ - *Free++=NIL; /* Not locked. */ - *Free++=Empty_Queue; /* Put the empty queue here. */ - *Free++=Arg1; /* The process slot. */ - *Free++=TRUTH; /* Status slot. */ - *Free++=Arg2; /* Original code. */ - *Free++=IO_Vector; /* Put the I/O system stuff here. */ - *Free++=NIL; /* Waiting on list. */ - *Free++=New_Future_Number(); /* Metering number. */ - *Free++=NIL; /* User data slot */ - - return The_Future; } - diff --git a/v7/src/microcode/futures.h b/v7/src/microcode/futures.h deleted file mode 100644 index 59c5900fc..000000000 --- a/v7/src/microcode/futures.h +++ /dev/null @@ -1,194 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/futures.h,v 9.21 1987/01/22 14:26:05 jinx Exp $ - * - * This file contains macros useful for dealing with futures - */ - -/* Data structure definition */ - -/* The IS_DETERMINED slot has one of the following type of values: - * #!FALSE if the value is not yet known - * #!TRUE if the value is known and the garbage collector is free - * to remove the future object in favor of its value everywhere - * else the value is known, but the GC must leave the future object -*/ - -#define FUTURE_VECTOR_HEADER 0 -#define FUTURE_IS_DETERMINED 1 -#define FUTURE_LOCK 2 -#define FUTURE_VALUE 3 /* if known, else */ -#define FUTURE_QUEUE 3 /* tasks waiting for value */ -#define FUTURE_EXTRA_STUFF 4 /* rest for extensibility */ - -#define Future_Is_Locked(P) \ - (Vector_Ref((P), FUTURE_LOCK) != NIL) - -#define Future_Has_Value(P) \ - (Vector_Ref((P), FUTURE_IS_DETERMINED) != NIL) - -#define Future_Value(P) \ - Vector_Ref((P), FUTURE_VALUE) - -#define Future_Spliceable(P) \ - ((Vector_Ref((P), FUTURE_IS_DETERMINED) == TRUTH) && \ - (Vector_Ref((P), FUTURE_LOCK) == NIL)) - -#define Future_Is_Keep_Slot(P) \ -((Vector_Ref((P), FUTURE_IS_DETERMINED) != NIL) && \ - (Vector_Ref((P), FUTURE_IS_DETERMINED) != TRUTH)) - -#ifdef COMPILE_FUTURES -/* Touch_In_Primitive is used by primitives which are not - * strict in an argument but which touch it none the less. - */ - -#define Touch_In_Primitive(P, To_Where) \ -{ Pointer Value = (P); \ - while (Type_Code(Value) == TC_FUTURE) \ - { if (Future_Has_Value(Value)) \ - { if (Future_Is_Keep_Slot(Value)) Log_Touch_Of_Future(Value);\ - Value = Future_Value(Value); \ - } \ - else \ - { Back_Out_Of_Primitive(); \ - Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \ - Save_Cont(); \ - Push(Value); \ - Push(Get_Fixed_Obj_Slot(System_Scheduler)); \ - Push(STACK_FRAME_HEADER+1); \ - Pushed(); \ - longjmp(*Back_To_Eval, PRIM_APPLY); \ - } \ - } \ - To_Where = Value; \ -} - -/* NOTES ON FUTURES, derived from the rest of the interpreter code */ - -/* ASSUMPTION: The syntaxer is hereby assumed NEVER to generate primitive - combinations unless the primitive itself is output in the code stream. - Therefore, we don't have to explicitly check here that the expression - register has a primitive in it. - - ASSUMPTION: The SYMBOL slot of a VARIABLE does NOT contain a future, nor - do the cached lexical address slots. - - ASSUMPTION: Compiled code calls to the interpreter require the results - be touched before returning to the compiled code. This may be very wrong. - - ASSUMPTION: History objects are never created using futures. - - ASSUMPTION: State points, which are created only by the interpreter, - never contain FUTUREs except possibly as the thunks (which are handled - by the apply code). - -*/ - -/* OPTIMIZATIONS (?): - After a lot of discussion, we decided that variable reference will check - whether a value stored in the environment is a determined future which - is marked spliceable. If so, it will splice out the future from the - environment slot to speed up subsequent references. - - EQ? does a normal identity check and only if this fails does it touch the - arguments. The same thing does not speed up MEMQ or ASSQ in the normal - case, so it is omitted there. - - The following are NOT done, but might be useful later - (1) Splicing on SET! operations - (2) Splicing at apply and/or primitive apply - (3) Splicing all arguments when a primitive errors on any of them - (4) Splicing within the Arg_n_Type macro rather than after longjmping - to the error handler. -*/ - -/* KNOWN PROBLEMS: - (1) Garbage collector should be modified to splice out futures. - - (2) Purify should be looked at and we should decide what to do about - purifying an object with a reference to a future (it should probably - become constant but not pure). - - (3) Look at Impurify and Side-Effect-Impurify to see if futures - affect them in any way. -*/ - -#ifdef FUTURE_LOGGING -#define Touched_Futures_Vector() Get_Fixed_Obj_Slot(Touched_Futures) - -#define Logging_On() \ -(Valid_Fixed_Obj_Vector() && Touched_Futures_Vector()) - -/* Log_Touch_Of_Future adds the future which was touched to the vector - of touched futures about which the scheme portion of the system has - not yet been informed -*/ -#define Log_Touch_Of_Future(F) \ -if (Logging_On()) \ -{ Pointer TFV = Touched_Futures_Vector(); \ - long Count = Get_Integer(User_Vector_Ref(TFV, 0))+1; \ - User_Vector_Ref(TFV, 0) = FIXNUM_0 + Count; \ - if (Count < Vector_Length(TFV)) \ - User_Vector_Ref(TFV, Count) = Make_New_Pointer(TC_VECTOR, F); \ -} - -/* Call_Future_Logging calls a user defined scheme routine if the vector - of touched futures has a nonzero length. -*/ -#define Must_Report_References() \ -( Logging_On() && \ - (Get_Integer(User_Vector_Ref(Touched_Futures_Vector(), 0)) > 0)) - -#define Call_Future_Logging() \ -{ \ - Will_Push(STACK_ENV_EXTRA_SLOTS+2); \ - Push(Touched_Futures_Vector()); \ - Push(Get_Fixed_Obj_Slot(Future_Logger)); \ - Push(STACK_FRAME_HEADER+1); \ - Pushed(); \ - Touched_Futures_Vector() = NIL; \ - goto Apply_Non_Trapping; \ -} -#else -#define Log_Touch_Of_Future(F) { } -#define Call_Future_Logging() -#define Must_Report_References() (false) -#endif /* Logging */ - -#else /* Futures not compiled */ -#define Touch_In_Primitive(P, To_Where) To_Where = (P) -#define Log_Touch_Of_Future(F) { } -#define Call_Future_Logging() -#define Must_Report_References() (false) -#endif diff --git a/v7/src/microcode/gc.h b/v7/src/microcode/gc.h deleted file mode 100644 index abdd9ad5e..000000000 --- a/v7/src/microcode/gc.h +++ /dev/null @@ -1,102 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gc.h,v 9.22 1987/04/03 00:13:13 jinx Rel $ - * - * Garbage collection related macros of sufficient utility to be - * included in all compilations. - */ - -/* GC Types. */ - -#define GC_Non_Pointer 0 -#define GC_Cell 1 -#define GC_Pair 2 -#define GC_Triple 3 -#define GC_Hunk3 3 -#define GC_Quadruple 4 -#define GC_Hunk4 4 -#define GC_Undefined -1 /* Undefined types */ -#define GC_Special -2 /* Internal GC types */ -#define GC_Vector -3 -#define GC_Compiled -4 - -#define GC_Type_Code(TC) \ - ((GC_Type_Map[TC] != GC_Undefined) ? \ - GC_Type_Map[TC] : \ - (fprintf(stderr, "Bad Type code = 0x%02x\n", TC), \ - Invalid_Type_Code(), GC_Undefined)) - -#define GC_Type(Object) GC_Type_Code(Safe_Type_Code(Object)) - -#define GC_Type_Non_Pointer(Object) (GC_Type(Object) == GC_Non_Pointer) -#define GC_Type_Cell(Object) (GC_Type(Object) == GC_Cell) -#define GC_Type_List(Object) (GC_Type(Object) == GC_Pair) -#define GC_Type_Triple(Object) (GC_Type(Object) == GC_Triple) -#define GC_Type_Quadruple(Object) (GC_Type(Object) == GC_Quadruple) -#define GC_Type_Undefined(Object) (GC_Type(Object) == GC_Undefined) -#define GC_Type_Special(Object) (GC_Type(Object) == GC_Special) -#define GC_Type_Vector(Object) (GC_Type(Object) == GC_Vector) -#define GC_Type_Compiled(Object) (GC_Type(Object) == GC_Compiled) - -#define Invalid_Type_Code() \ - Microcode_Termination(TERM_INVALID_TYPE_CODE) - -/* Overflow detection, various cases */ - -#define GC_Check(Amount) (((Amount+Free) >= MemTop) && \ - ((IntEnb & INT_GC) != 0)) - -#define Space_Before_GC() (((IntEnb & INT_GC) != 0) ? \ - (MemTop - Free) : \ - (Heap_Top - Free)) - -#define Request_Interrupt(code) \ -{ \ - IntCode |= (code); \ - New_Compiler_MemTop(); \ -} - -#define Request_GC(Amount) \ -{ \ - Request_Interrupt( INT_GC); \ - GC_Space_Needed = Amount; \ -} - -#define Set_Mem_Top(Addr) \ - MemTop = Addr; New_Compiler_MemTop() - -#define Set_Stack_Guard(Addr) Stack_Guard = Addr - -#define New_Compiler_MemTop() \ - Regs[REGBLOCK_MEMTOP] = \ - ((IntCode & IntEnb)==0) ? ((Pointer) MemTop) : ((Pointer) -1) diff --git a/v7/src/microcode/gccode.h b/v7/src/microcode/gccode.h deleted file mode 100644 index fc291cddb..000000000 --- a/v7/src/microcode/gccode.h +++ /dev/null @@ -1,358 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gccode.h,v 9.23 1987/04/16 02:23:06 jinx Exp $ - * - * This file contains the macros for use in code which does GC-like - * loops over memory. It is only included in a few files, unlike - * GC.H which contains general purpose macros and constants. - * - */ - -/* A SWITCH on GC types, duplicates information in GC_Type_Map[], but exists - for efficiency reasons. Macros must be used by convention: first - Switch_by_GC_Type, then each of the case_ macros (in any order). The - default: case MUST be included in the switch. -*/ - -#define Switch_by_GC_Type(P) \ - switch(Safe_Type_Code(P)) - -#define case_simple_Non_Pointer \ - case TC_NULL: \ - case TC_TRUE: \ - case TC_THE_ENVIRONMENT: \ - case TC_RETURN_CODE: \ - case TC_PRIMITIVE: \ - case TC_PCOMB0: \ - case TC_STACK_ENVIRONMENT - -#define case_Fasdump_Non_Pointer \ - case TC_FIXNUM: \ - case TC_CHARACTER: \ - case_simple_Non_Pointer - -#define case_Non_Pointer \ - case TC_PRIMITIVE_EXTERNAL: \ - case_Fasdump_Non_Pointer - -/* Missing Non Pointer types (must always be treated specially): - TC_BROKEN_HEART - TC_MANIFEST_NM_VECTOR - TC_MANIFEST_SPECIAL_NM_VECTOR - TC_REFERENCE_TRAP -*/ - -#define case_compiled_entry_point \ - case TC_COMPILED_EXPRESSION: \ - case TC_RETURN_ADDRESS \ - -#define case_Cell \ - case TC_CELL - -/* No missing Cell types */ - -#define case_Fasdump_Pair \ - case TC_LIST: \ - case TC_SCODE_QUOTE: \ - case TC_COMBINATION_1: \ - case TC_EXTENDED_PROCEDURE: \ - case TC_PROCEDURE: \ - case TC_DELAY: \ - case TC_DELAYED: \ - case TC_COMMENT: \ - case TC_LAMBDA: \ - case TC_SEQUENCE_2: \ - case TC_PCOMB1: \ - case TC_ACCESS: \ - case TC_DEFINITION: \ - case TC_ASSIGNMENT: \ - case TC_IN_PACKAGE: \ - case TC_LEXPR: \ - case TC_DISJUNCTION: \ - case TC_COMPILED_PROCEDURE: \ - case TC_COMPILER_LINK: \ - case TC_COMPLEX - -#define case_Pair \ - case TC_INTERNED_SYMBOL: \ - case TC_UNINTERNED_SYMBOL: \ - case_Fasdump_Pair - -/* Missing pair types (must be treated specially): - TC_WEAK_CONS -*/ - -#define case_Triple \ - case TC_COMBINATION_2: \ - case TC_EXTENDED_LAMBDA: \ - case TC_HUNK3: \ - case TC_CONDITIONAL: \ - case TC_SEQUENCE_3: \ - case TC_PCOMB2 - -/* Missing triple types (must be treated specially): - TC_VARIABLE -*/ - -#define case_Quadruple \ - case TC_QUAD - -/* No missing quad types. */ - -#define case_simple_Vector \ - case TC_NON_MARKED_VECTOR: \ - case TC_VECTOR: \ - case TC_CONTROL_POINT: \ - case TC_COMBINATION: \ - case TC_PCOMB3: \ - case TC_VECTOR_1B: \ - case TC_VECTOR_16B - -#define case_Purify_Vector \ - case TC_BIG_FIXNUM: \ - case TC_CHARACTER_STRING: \ - case_simple_Vector - -#define case_Vector \ - case TC_ENVIRONMENT: \ - case_Purify_Vector - -/* Missing vector types (must be treated specially): - TC_FUTURE - TC_BIG_FLONUM -*/ - -/* Macros for the garbage collector and related programs. */ - -#define NORMAL_GC 0 -#define PURE_COPY 1 -#define CONSTANT_COPY 2 - -/* Pointer setup for the GC Type handlers. */ - -/* Check whether it has been relocated. */ - -#define Normal_BH(In_GC, then_what) \ -if (Type_Code(*Old) == TC_BROKEN_HEART) \ -{ *Scan = Make_New_Pointer(Type_Code(Temp), *Old); \ - then_what; \ -} - -#define Setup_Internal(In_GC, Extra_Code, BH_Code) \ -if And2(In_GC, Consistency_Check) \ - if ((Old >= Highest_Allocated_Address) || (Old < Heap)) \ - { fprintf(stderr, "Out of range pointer: %x.\n", Temp); \ - Microcode_Termination(TERM_EXIT); \ - } \ -if (Old >= Low_Constant) \ - continue; \ -BH_Code; \ -New_Address = (Make_Broken_Heart(C_To_Scheme(To))); \ -Extra_Code; \ -continue - -#define Setup_Pointer(In_GC, Extra_Code) \ -Setup_Internal(In_GC, Extra_Code, Normal_BH(In_GC, continue)) - -#define Pointer_End() \ -*Get_Pointer(Temp) = New_Address; \ -*Scan = Make_New_Pointer(Type_Code(Temp), New_Address) - -/* GC Type handlers. These do the actual work. */ - -#define Transport_Cell() \ -*To++ = *Old; \ -Pointer_End() - -#define Transport_Pair() \ -*To++ = *Old++; \ -*To++ = *Old; \ -Pointer_End() - -#define Transport_Triple() \ -*To++ = *Old++; \ -*To++ = *Old++; \ -*To++ = *Old; \ -Pointer_End() - -#define Transport_Quadruple() \ -*To++ = *Old++; \ -*To++ = *Old++; \ -*To++ = *Old++; \ -*To++ = *Old; \ -Pointer_End() - -#ifndef In_Fasdump - -/* The Get_Integer below gets the length of the vector. - Vector_Length(Temp) cannot be used because Temp does - not necessarily point to the first word of the object. - Currently only compiled entry points point to the - "middle" of vectors. - */ - -#define Real_Transport_Vector() \ -{ Pointer *Saved_Scan = Scan; \ - Scan = To + 1 + Get_Integer(*Old); \ - if ((Consistency_Check) && \ - (Scan >= Low_Constant) && \ - (To < Low_Constant)) \ - { fprintf(stderr, "\nVector Length %d\n", \ - Get_Integer(*Old)); \ - Microcode_Termination(TERM_EXIT); \ - } \ - while (To != Scan) *To++ = *Old++; \ - Scan = Saved_Scan; \ -} - -#else In_Fasdump - -#define Real_Transport_Vector() \ -{ Pointer *Saved_Scan = Scan; \ - Scan = To + 1 + Get_Integer(*Old); \ - if (Scan >= Fixes) \ - { Scan = Saved_Scan; \ - NewFree = To; \ - Fixup = Fixes; \ - return false; \ - } \ - while (To != Scan) *To++ = *Old++; \ - Scan = Saved_Scan; \ -} - -#endif - -#ifdef FLOATING_ALIGNMENT -#define Transport_Flonum() \ - Align_Float(To); \ - New_Address = (Make_Broken_Heart(C_To_Scheme(To))); \ - Real_Transport_Vector(); \ - Pointer_End() -#endif - -#define Transport_Vector() \ -Move_Vector: \ - Real_Transport_Vector(); \ - Pointer_End() - -#define Transport_Future() \ -if (!(Future_Spliceable(Temp))) \ - goto Move_Vector; \ -*Scan = Future_Value(Temp); \ -Scan -= 1 - -/* Weak Pointer code. The idea here is to support a post-GC pass which - removes any objects in the CAR of a WEAK_CONS cell which is no longer - referenced by other objects in the system. - - The idea is to maintain a (C based) list of weak conses in old - space. The head of this list is the variable Weak_Chain. During - the normal GC pass, weak cons cells are not copied in the normal - manner. Instead the following structure is built: - - Old Space | New Space - _______________________ | _______________________ - |Broken | New | | | NULL | Old CAR data | - |Heart | Location ======|==>| | | - |_______|_____________| | |______|______________| - |Old Car| Next in | | | Old CDR component | - | type | chain | | | | - |_____________________| | |_____________________| - -*/ - -extern Pointer Weak_Chain; - -#define Transport_Weak_Cons() \ -{ long Car_Type = Type_Code(*Old); \ - *To++ = Make_New_Pointer(TC_NULL, *Old); \ - Old += 1; \ - *To++ = *Old; \ - *Old = Make_New_Pointer(Car_Type, Weak_Chain); \ - Weak_Chain = Temp; \ - Pointer_End(); \ -} - -/* Special versions of the above for DumpLoop in Fasdump. This code - only differs from the code above in that it must check whether - there is enough space to remember the fixup. - */ - -#define Fasdump_Setup_Pointer(Extra_Code, BH_Code) \ -BH_Code; \ -/* It must be transported to New Space */ \ -New_Address = (Make_Broken_Heart(C_To_Scheme(To))); \ -if ((Fixes - To) < FASDUMP_FIX_BUFFER) \ -{ NewFree = To; \ - Fixup = Fixes; \ - return false; \ -} \ -*--Fixes = *Old; \ -*--Fixes = C_To_Scheme(Old); \ -Extra_Code; \ -continue - -/* Undefine Symbols */ - -#define Fasdump_Symbol(global_value) \ -*To++ = *Old; \ -*To++ = global_value; \ -Pointer_End() - -#define Fasdump_Variable() \ -*To++ = *Old; \ -*To++ = UNCOMPILED_VARIABLE; \ -*To++ = NIL; \ -Pointer_End() - -/* Compiled Code Relocation Utilities */ - -#ifdef CMPGCFILE -#include CMPGCFILE -#else - -/* Is there anything else that can be done here? */ - -#define Get_Compiled_Block(address) \ -fprintf(stderr, \ - "\nRelocating compiled code without compiler support!\n"); \ -Microcode_Termination(TERM_COMPILER_DEATH) - -#define Compiled_BH(flag, then_what) \ -fprintf(stderr, \ - "\nRelocating compiled code without compiler support!\n"); \ -Microcode_Termination(TERM_COMPILER_DEATH) - -#define Transport_Compiled() - -#endif diff --git a/v7/src/microcode/gcloop.c b/v7/src/microcode/gcloop.c deleted file mode 100644 index 0c66a1525..000000000 --- a/v7/src/microcode/gcloop.c +++ /dev/null @@ -1,150 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gcloop.c,v 9.24 1987/04/03 00:13:50 jinx Rel $ - * - * This file contains the code for the most primitive part - * of garbage collection. - * - */ - -#include "scheme.h" -#include "gccode.h" - -/* Exports */ - -extern Pointer *GCLoop(); - -#define GC_Pointer(Code) \ -Old = Get_Pointer(Temp); \ -Code - -#define Setup_Pointer_for_GC(Extra_Code) \ -GC_Pointer(Setup_Pointer(true, Extra_Code)) - -#ifdef ENABLE_DEBUGGING_TOOLS -static Pointer *gc_scan_trap = NULL; -static Pointer *gc_free_trap = NULL; -static Pointer gc_trap = Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_MAX_IMMEDIATE); -#endif - -Pointer -*GCLoop(Scan, To_Pointer) -fast Pointer *Scan; -Pointer **To_Pointer; -{ fast Pointer *To, *Old, Temp, *Low_Constant, New_Address; - - To = *To_Pointer; - Low_Constant = Constant_Space; - for ( ; Scan != To; Scan++) - { Temp = *Scan; - -#ifdef ENABLE_DEBUGGING_TOOLS - if ((Temp == gc_trap) || (Scan == gc_scan_trap) || (To == gc_free_trap)) - { - fprintf(stderr, "\nGCLoop: trap.\n"); - } -#endif - - Switch_by_GC_Type(Temp) - { case TC_BROKEN_HEART: - if (Scan == (Get_Pointer(Temp))) - { *To_Pointer = To; - return Scan; - } - fprintf(stderr, "GC: Broken heart in scan.\n"); - Microcode_Termination(TERM_BROKEN_HEART); - - case TC_MANIFEST_NM_VECTOR: - case TC_MANIFEST_SPECIAL_NM_VECTOR: - Scan += Get_Integer(Temp); - break; - - case_Non_Pointer: - break; - - case_compiled_entry_point: - GC_Pointer(Setup_Internal(true, - Transport_Compiled(), - Compiled_BH(true, continue))); - - case_Cell: - Setup_Pointer_for_GC(Transport_Cell()); - - case TC_REFERENCE_TRAP: - if (Datum(Temp) <= TRAP_MAX_IMMEDIATE) - { - /* It is a non pointer. */ - break; - } - /* It is a pair, fall through. */ - case_Pair: - Setup_Pointer_for_GC(Transport_Pair()); - - case TC_VARIABLE: - case_Triple: - Setup_Pointer_for_GC(Transport_Triple()); - -/* GCLoop continues on the next page */ - -/* GCLoop, continued */ - - case_Quadruple: - Setup_Pointer_for_GC(Transport_Quadruple()); - -#ifdef FLOATING_ALIGNMENT - case TC_BIG_FLONUM: - Setup_Pointer_for_GC(Transport_Flonum()); -#else - case TC_BIG_FLONUM: - /* Fall through */ -#endif - case_Vector: - Setup_Pointer_for_GC(Transport_Vector()); - - case TC_FUTURE: - Setup_Pointer_for_GC(Transport_Future()); - - case TC_WEAK_CONS: - Setup_Pointer_for_GC(Transport_Weak_Cons()); - - default: - fprintf(stderr, - "GCLoop: Bad type code = 0x%02x\n", - Type_Code(Temp)); - Invalid_Type_Code(); - - } /* Switch_by_GC_Type */ - } /* For loop */ - *To_Pointer = To; - return To; -} /* GCLoop */ diff --git a/v7/src/microcode/gctype.c b/v7/src/microcode/gctype.c deleted file mode 100644 index 5f3904700..000000000 --- a/v7/src/microcode/gctype.c +++ /dev/null @@ -1,187 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/gctype.c,v 9.22 1987/04/03 00:14:08 jinx Exp $ - * - * This file contains the table which maps between Types and - * GC Types. - * - */ - - /*********************************/ - /* Mapping GC_Type to Type_Codes */ - /*********************************/ - -int GC_Type_Map[MAX_SAFE_TYPE + 1] = { - GC_Non_Pointer, /* TC_NULL,etc */ - GC_Pair, /* TC_LIST */ - GC_Non_Pointer, /* TC_CHARACTER */ - GC_Pair, /* TC_SCODE_QUOTE */ - GC_Triple, /* TC_PCOMB2 */ - GC_Pair, /* TC_UNINTERNED_SYMBOL */ - GC_Vector, /* TC_BIG_FLONUM */ - GC_Pair, /* TC_COMBINATION_1 */ - GC_Non_Pointer, /* TC_TRUE */ - GC_Pair, /* TC_EXTENDED_PROCEDURE */ - GC_Vector, /* TC_VECTOR */ - GC_Non_Pointer, /* TC_RETURN_CODE */ - GC_Triple, /* TC_COMBINATION_2 */ - GC_Pair, /* TC_COMPILED_PROCEDURE */ - GC_Vector, /* TC_BIG_FIXNUM */ - GC_Pair, /* TC_PROCEDURE */ - GC_Non_Pointer, /* TC_PRIMITIVE_EXTERNAL */ - GC_Pair, /* TC_DELAY */ - GC_Vector, /* TC_ENVIRONMENT */ - GC_Pair, /* TC_DELAYED */ - GC_Triple, /* TC_EXTENDED_LAMBDA */ - GC_Pair, /* TC_COMMENT */ - GC_Vector, /* TC_NON_MARKED_VECTOR */ - GC_Pair, /* TC_LAMBDA */ - GC_Non_Pointer, /* TC_PRIMITIVE */ - GC_Pair, /* TC_SEQUENCE_2 */ - GC_Non_Pointer, /* TC_FIXNUM */ - GC_Pair, /* TC_PCOMB1 */ - GC_Vector, /* TC_CONTROL_POINT */ - GC_Pair, /* TC_INTERNED_SYMBOL */ - GC_Vector, /* TC_CHARACTER_STRING,TC_VECTOR_8B */ - GC_Pair, /* TC_ACCESS */ - GC_Undefined, /* 0x20 */ - GC_Pair, /* TC_DEFINITION */ - GC_Special, /* TC_BROKEN_HEART */ - GC_Pair, /* TC_ASSIGNMENT */ - GC_Triple, /* TC_HUNK3 */ - GC_Pair, /* TC_IN_PACKAGE */ - -/* GC_Type_Map continues on next page */ - -/* GC_Type_Map continued */ - - GC_Vector, /* TC_COMBINATION */ - GC_Special, /* TC_MANIFEST_NM_VECTOR */ - GC_Compiled, /* TC_COMPILED_EXPRESSION */ - GC_Pair, /* TC_LEXPR */ - GC_Vector, /* TC_PCOMB3 */ - GC_Special, /* TC_MANIFEST_SPECIAL_NM_VECTOR */ - GC_Triple, /* TC_VARIABLE */ - GC_Non_Pointer, /* TC_THE_ENVIRONMENT */ - GC_Vector, /* TC_FUTURE */ - GC_Vector, /* TC_VECTOR_1B,TC_BIT_STRING */ - GC_Non_Pointer, /* TC_PCOMB0 */ - GC_Vector, /* TC_VECTOR_16B */ - GC_Special, /* TC_REFERENCE_TRAP */ - GC_Triple, /* TC_SEQUENCE_3 */ - GC_Triple, /* TC_CONDITIONAL */ - GC_Pair, /* TC_DISJUNCTION */ - GC_Cell, /* TC_CELL */ - GC_Pair, /* TC_WEAK_CONS */ - GC_Quadruple, /* TC_QUAD */ - GC_Compiled, /* TC_RETURN_ADDRESS */ - GC_Pair, /* TC_COMPILER_LINK */ - GC_Non_Pointer, /* TC_STACK_ENVIRONMENT */ - GC_Pair, /* TC_COMPLEX */ - GC_Undefined, /* 0x3D */ - GC_Undefined, /* 0x3E */ - GC_Undefined, /* 0x3F */ - GC_Undefined, /* 0x40 */ - GC_Undefined, /* 0x41 */ - GC_Undefined, /* 0x42 */ - GC_Undefined, /* 0x43 */ - GC_Undefined, /* 0x44 */ - GC_Undefined, /* 0x45 */ - GC_Undefined, /* 0x46 */ - GC_Undefined, /* 0x47 */ - GC_Undefined, /* 0x48 */ - GC_Undefined, /* 0x49 */ - GC_Undefined, /* 0x4A */ - GC_Undefined, /* 0x4B */ - GC_Undefined, /* 0x4C */ - GC_Undefined, /* 0x4D */ - GC_Undefined, /* 0x4E */ - GC_Undefined, /* 0x4F */ - GC_Undefined, /* 0x50 */ - GC_Undefined, /* 0x51 */ - GC_Undefined, /* 0x52 */ - GC_Undefined, /* 0x53 */ - GC_Undefined, /* 0x54 */ - -/* GC_Type_Map continues on next page */ - -/* GC_Type_Map continued */ - - GC_Undefined, /* 0x55 */ - GC_Undefined, /* 0x56 */ - GC_Undefined, /* 0x57 */ - GC_Undefined, /* 0x58 */ - GC_Undefined, /* 0x59 */ - GC_Undefined, /* 0x5A */ - GC_Undefined, /* 0x5B */ - GC_Undefined, /* 0x5C */ - GC_Undefined, /* 0x5D */ - GC_Undefined, /* 0x5E */ - GC_Undefined, /* 0x5F */ - GC_Undefined, /* 0x60 */ - GC_Undefined, /* 0x61 */ - GC_Undefined, /* 0x62 */ - GC_Undefined, /* 0x63 */ - GC_Undefined, /* 0x64 */ - GC_Undefined, /* 0x65 */ - GC_Undefined, /* 0x66 */ - GC_Undefined, /* 0x67 */ - GC_Undefined, /* 0x68 */ - GC_Undefined, /* 0x69 */ - GC_Undefined, /* 0x6A */ - GC_Undefined, /* 0x6B */ - GC_Undefined, /* 0x6C */ - GC_Undefined, /* 0x6D */ - GC_Undefined, /* 0x6E */ - GC_Undefined, /* 0x6F */ - GC_Undefined, /* 0x70 */ - GC_Undefined, /* 0x71 */ - GC_Undefined, /* 0x72 */ - GC_Undefined, /* 0x73 */ - GC_Undefined, /* 0x74 */ - GC_Undefined, /* 0x75 */ - GC_Undefined, /* 0x76 */ - GC_Undefined, /* 0x77 */ - GC_Undefined, /* 0x78 */ - GC_Undefined, /* 0x79 */ - GC_Undefined, /* 0x7A */ - GC_Undefined, /* 0x7B */ - GC_Undefined, /* 0x7C */ - GC_Undefined, /* 0x7D */ - GC_Undefined, /* 0x7E */ - GC_Undefined /* 0x7F */ - }; - -#if (MAX_SAFE_TYPE != 0x7F) -#include "gctype.c and scheme.h inconsistent -- GC_Type_Map" -#endif diff --git a/v7/src/microcode/generic.c b/v7/src/microcode/generic.c deleted file mode 100644 index 63f778ef6..000000000 --- a/v7/src/microcode/generic.c +++ /dev/null @@ -1,954 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/generic.c,v 9.22 1987/04/16 02:23:19 jinx Rel $ */ - -#include "scheme.h" -#include "primitive.h" -#include "bignum.h" -#include "flonum.h" -#include "zones.h" - -Built_In_Primitive(Prim_Zero, 1, "ZERO?", 0xE6) -{ - Primitive_1_Arg(); - - Set_Time_Zone(Zone_Math); - switch (Type_Code(Arg1)) - { case TC_FIXNUM: if (Get_Integer(Arg1) == 0) return TRUTH; - else return NIL; - case TC_BIG_FLONUM: if (Get_Float(Arg1) == 0.0) return TRUTH; - else return NIL; - case TC_BIG_FIXNUM: if (ZERO_BIGNUM(Fetch_Bignum(Arg1))) return TRUTH; - else return NIL; - default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); - } - /*NOTREACHED*/ -} - -Pointer -C_Integer_To_Scheme_Integer(C) - long C; -{ - fast bigdigit *Answer, *SCAN, *size; - long Length; - - if (Fixnum_Fits(C)) - return Make_Non_Pointer(TC_FIXNUM, C); - Length = Align(C_INTEGER_LENGTH_AS_BIGNUM); - Primitive_GC_If_Needed(Length); - Answer = BIGNUM(Free); - Prepare_Header(Answer, 0, (C >= 0) ? POSITIVE : NEGATIVE); - size = &LEN(Answer); - if (C < 0) - C = - C; - for (SCAN = Bignum_Bottom(Answer); C != 0; *size += 1) - { - *SCAN++ = Rem_Radix(C); - C = Div_Radix(C); - } - *((Pointer *) Answer) = Make_Header(Align(*size)); - Free += Length; - Debug_Test(Free-Length); - return Make_Pointer(TC_BIG_FIXNUM, Free-Length); -} - -int -Scheme_Integer_To_C_Integer(Arg1, C) - Pointer Arg1; - long *C; -{ - int type = Type_Code(Arg1); - fast bigdigit *SCAN, *ARG1; - fast long Answer, i; - long Length; - - if (type == TC_FIXNUM) - { - Sign_Extend(Arg1, *C); - return PRIM_DONE; - } - if (type != TC_BIG_FIXNUM) - return ERR_ARG_1_WRONG_TYPE; - ARG1 = BIGNUM(Get_Pointer(Arg1)); - Length = LEN(ARG1); - if (Length == 0) - Answer = 0; - else if (Length > C_INTEGER_LENGTH_AS_BIGNUM) - return ERR_ARG_1_BAD_RANGE; - else if (Length < C_INTEGER_LENGTH_AS_BIGNUM) - for (SCAN=Bignum_Top(ARG1), i=0, Answer=0; i< Length; i++) - Answer = Mul_Radix(Answer) + *SCAN--; - else - /* Length == C_INTEGER_LENGTH_AS_BIGNUM */ - for (SCAN=Bignum_Top(ARG1), i=0, Answer=0; i< Length; i++) - /* Attempting to take care of overflow problems */ - { Answer = Mul_Radix(Answer); - if (Answer < 0) - return ERR_ARG_1_BAD_RANGE; - Answer = Answer + *SCAN--; - if (Answer < 0) - return ERR_ARG_1_BAD_RANGE; - } - if NEG_BIGNUM(ARG1) - Answer = - Answer; - *C = Answer; - return PRIM_DONE; -} - -Pointer -Fetch_Bignum_One() -{ - return Get_Fixed_Obj_Slot(Bignum_One); -} - -#define Sign_Check(Normal_Op, Big_Op) \ - Primitive_1_Arg(); \ - Set_Time_Zone(Zone_Math); \ - switch (Type_Code(Arg1)) \ - { case TC_FIXNUM: { long Value; \ - Sign_Extend(Arg1, Value); \ - if (Value Normal_Op 0) return TRUTH; \ - else return NIL; \ - } \ - case TC_BIG_FLONUM: if (Get_Float(Arg1) Normal_Op 0.0) return TRUTH;\ - else return NIL; \ -P2_Sign_Check(Big_Op) - -#define P2_Sign_Check(Big_Op) \ - case TC_BIG_FIXNUM: if ((LEN(Fetch_Bignum(Arg1)) != 0) \ - && Big_Op(Fetch_Bignum(Arg1))) \ - return TRUTH; \ - else return NIL; \ - default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \ - } - - -Built_In_Primitive(Prim_Positive, 1, "POSITIVE?", 0xE7) -{ - Sign_Check(>, POS_BIGNUM); - /*NOTREACHED*/ -} - -Built_In_Primitive(Prim_Negative, 1, "NEGATIVE?", 0xE8) -{ - Sign_Check(<, NEG_BIGNUM); - /*NOTREACHED*/ -} - -#define Inc_Dec(Normal_Op, Big_Op) \ - Primitive_1_Arg(); \ - Set_Time_Zone(Zone_Math); \ - switch (Type_Code(Arg1)) \ - { case TC_FIXNUM: \ - { fast long A, Result; \ - Sign_Extend(Arg1, A); \ - Result = A Normal_Op 1; \ - if (Fixnum_Fits(Result)) \ - return Make_Non_Pointer(TC_FIXNUM, Result); \ -P2_Inc_Dec(Normal_Op, Big_Op) - -#define P2_Inc_Dec(Normal_Op, Big_Op) \ - { Pointer Ans = Fix_To_Big(Arg1); \ - Bignum_Operation(Big_Op(Fetch_Bignum(Ans), \ - Fetch_Bignum(Fetch_Bignum_One())), \ - Ans); \ - return Ans; \ - } \ - } \ -P3_Inc_Dec(Normal_Op, Big_Op) - -#define P3_Inc_Dec(Normal_Op, Big_Op) \ - case TC_BIG_FLONUM: \ - Reduced_Flonum_Result(Get_Float(Arg1) Normal_Op 1); \ - case TC_BIG_FIXNUM: \ - { Pointer Ans; \ - Bignum_Operation(Big_Op(Fetch_Bignum(Arg1), \ - Fetch_Bignum(Fetch_Bignum_One())), \ - Ans); \ - return Ans; \ - } \ - default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \ - } - -Built_In_Primitive(Prim_One_Plus, 1, "1+", 0xF1) -{ - Inc_Dec(+, plus_signed_bignum); - /*NOTREACHED*/ -} - -Built_In_Primitive(Prim_M_1_Plus, 1, "-1+", 0xF2) -{ - Inc_Dec(-, minus_signed_bignum); - /*NOTREACHED*/ -} - -#define Two_Op_Comparator(GENERAL_OP, BIG_OP) \ - Primitive_2_Args(); \ - Set_Time_Zone(Zone_Math); \ - switch (Type_Code(Arg1)) \ - { case TC_FIXNUM: \ - { switch (Type_Code(Arg2)) \ - { case TC_FIXNUM: \ - { long A, B; \ - Sign_Extend(Arg1, A); \ - Sign_Extend(Arg2, B); \ - return (A GENERAL_OP B) ? TRUTH : NIL; \ - } \ -P2_Two_Op_Comparator(GENERAL_OP, BIG_OP) - -#define P2_Two_Op_Comparator(GENERAL_OP, BIG_OP) \ - case TC_BIG_FLONUM: \ - { long A; \ - Sign_Extend(Arg1, A); \ - return (A GENERAL_OP (Get_Float(Arg2))) ? TRUTH : NIL; \ - } \ - case TC_BIG_FIXNUM: \ - { Pointer Ans = Fix_To_Big(Arg1); \ - return (big_compare(Fetch_Bignum(Ans), \ - Fetch_Bignum(Arg2)) == BIG_OP) ? \ - TRUTH : NIL; \ - } \ -P3_Two_Op_Comparator(GENERAL_OP, BIG_OP) - -#define P3_Two_Op_Comparator(GENERAL_OP, BIG_OP) \ - default: \ - Primitive_Error(ERR_ARG_2_WRONG_TYPE); \ - } \ - } \ - case TC_BIG_FLONUM: \ - { switch (Type_Code(Arg2)) \ - { case TC_FIXNUM: \ - { long B; \ - Sign_Extend(Arg2, B); \ - return (Get_Float(Arg1) GENERAL_OP B) ? TRUTH : NIL; \ - } \ -P4_Two_Op_Comparator(GENERAL_OP, BIG_OP) - -#define P4_Two_Op_Comparator(GENERAL_OP, BIG_OP) \ - case TC_BIG_FLONUM: \ - return (Get_Float(Arg1) GENERAL_OP Get_Float(Arg2)) ? \ - TRUTH : NIL; \ - case TC_BIG_FIXNUM: \ - { Pointer A; \ - A = Big_To_Float(Arg2); \ - if (Type_Code(A) == TC_BIG_FLONUM) \ - return (Get_Float(Arg1) GENERAL_OP Get_Float(A)) ? \ - TRUTH : NIL; \ -P5_Two_Op_Comparator(GENERAL_OP, BIG_OP) - -#define P5_Two_Op_Comparator(GENERAL_OP, BIG_OP) \ - Primitive_Error(ERR_ARG_2_FAILED_COERCION); \ - } \ - default: \ - Primitive_Error(ERR_ARG_2_WRONG_TYPE); \ - } \ - } \ - case TC_BIG_FIXNUM: \ - { switch (Type_Code(Arg2)) \ - { case TC_FIXNUM: \ - { Pointer Ans = Fix_To_Big(Arg2); \ - return (big_compare(Fetch_Bignum(Arg1), \ - Fetch_Bignum(Ans)) == BIG_OP) ? \ - TRUTH : NIL; \ - } \ -P6_Two_Op_Comparator(GENERAL_OP, BIG_OP) - -#define P6_Two_Op_Comparator(GENERAL_OP, BIG_OP) \ - case TC_BIG_FLONUM: \ - { Pointer A = Big_To_Float(Arg1); \ - if (Type_Code(A) == TC_BIG_FLONUM) \ - return (Get_Float(A) GENERAL_OP Get_Float(Arg2)) ? \ - TRUTH : NIL; \ - Primitive_Error(ERR_ARG_1_FAILED_COERCION); \ - } \ -P7_Two_Op_Comparator(GENERAL_OP, BIG_OP) - -#define P7_Two_Op_Comparator(GENERAL_OP, BIG_OP) \ - case TC_BIG_FIXNUM: \ - return (big_compare(Fetch_Bignum(Arg1), \ - Fetch_Bignum(Arg2)) == BIG_OP) ? \ - TRUTH : NIL; \ - default: \ - Primitive_Error(ERR_ARG_2_WRONG_TYPE); \ - } \ - } \ - default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \ - } - -Built_In_Primitive(Prim_Equal_Number, 2, "&=", 0xE9) -{ - Two_Op_Comparator(==, EQUAL); - /*NOTREACHED*/ -} - -Built_In_Primitive(Prim_Less, 2, "&<", 0xEA) -{ - Two_Op_Comparator(<, TWO_BIGGER); - /*NOTREACHED*/ -} - -Built_In_Primitive(Prim_Greater, 2, "&>", 0xEB) -{ - Two_Op_Comparator(>, ONE_BIGGER); - /*NOTREACHED*/ -} - -#define Two_Op_Operator(GENERAL_OP, BIG_OP) \ - Primitive_2_Args(); \ - Set_Time_Zone(Zone_Math); \ - switch (Type_Code(Arg1)) \ - { case TC_FIXNUM: \ - { switch (Type_Code(Arg2)) \ - { case TC_FIXNUM: \ - { fast long A, B, Result; \ - Sign_Extend(Arg1, A); \ - Sign_Extend(Arg2, B); \ - Result = (A GENERAL_OP B); \ - if (Fixnum_Fits(Result)) \ - return Make_Non_Pointer(TC_FIXNUM, Result); \ -P2_Two_Op_Operator(GENERAL_OP, BIG_OP) - -#define P2_Two_Op_Operator(GENERAL_OP, BIG_OP) \ - { Pointer Big_Arg1, Big_Arg2, Big_Result; \ - Big_Arg1 = Fix_To_Big(Arg1); \ - Big_Arg2 = Fix_To_Big(Arg2); \ - Bignum_Operation(BIG_OP(Fetch_Bignum(Big_Arg1), \ - Fetch_Bignum(Big_Arg2)), \ - Big_Result); \ - return Big_Result; \ - } \ - } \ -P3_Two_Op_Operator(GENERAL_OP, BIG_OP) - -#define P3_Two_Op_Operator(GENERAL_OP, BIG_OP) \ - case TC_BIG_FLONUM: \ - { fast long A; \ - Sign_Extend(Arg1, A); \ - Reduced_Flonum_Result(A GENERAL_OP Get_Float(Arg2)); \ - } \ -P4_Two_Op_Operator(GENERAL_OP, BIG_OP) - -#define P4_Two_Op_Operator(GENERAL_OP, BIG_OP) \ - case TC_BIG_FIXNUM: \ - { Pointer Big_Arg1 = Fix_To_Big(Arg1); \ - Bignum_Operation(BIG_OP(Fetch_Bignum(Big_Arg1), \ - Fetch_Bignum(Arg2)), \ - Big_Arg1); \ - return Big_Arg1; \ - } \ - default: \ - Primitive_Error(ERR_ARG_2_WRONG_TYPE); \ - } \ - } \ -P5_Two_Op_Operator(GENERAL_OP, BIG_OP) - -#define P5_Two_Op_Operator(GENERAL_OP, BIG_OP) \ - case TC_BIG_FLONUM: \ - { switch (Type_Code(Arg2)) \ - { case TC_FIXNUM: \ - { fast long B; \ - Sign_Extend(Arg2, B); \ - Reduced_Flonum_Result(Get_Float(Arg1) GENERAL_OP B); \ - } \ - case TC_BIG_FLONUM: \ - Reduced_Flonum_Result(Get_Float(Arg1) GENERAL_OP \ - Get_Float(Arg2)); \ -P6_Two_Op_Operator(GENERAL_OP, BIG_OP) - -#define P6_Two_Op_Operator(GENERAL_OP, BIG_OP) \ - case TC_BIG_FIXNUM: \ - { Pointer B = Big_To_Float(Arg2); \ - if (Type_Code(B) == TC_BIG_FLONUM) \ - { Reduced_Flonum_Result(Get_Float(Arg1) GENERAL_OP \ - Get_Float(B)); \ - } \ - Primitive_Error(ERR_ARG_2_FAILED_COERCION); \ - } \ - default: \ - Primitive_Error(ERR_ARG_2_WRONG_TYPE); \ - } \ - } \ -P7_Two_Op_Operator(GENERAL_OP, BIG_OP) - -#define P7_Two_Op_Operator(GENERAL_OP, BIG_OP) \ - case TC_BIG_FIXNUM: \ - { switch (Type_Code(Arg2)) \ - { case TC_FIXNUM: \ - { Pointer Big_Arg2 = Fix_To_Big(Arg2); \ - Bignum_Operation(BIG_OP(Fetch_Bignum(Arg1), \ - Fetch_Bignum(Big_Arg2)), \ - Big_Arg2); \ - return Big_Arg2; \ - } \ -P8_Two_Op_Operator(GENERAL_OP, BIG_OP) - -#define P8_Two_Op_Operator(GENERAL_OP, BIG_OP) \ - case TC_BIG_FLONUM: \ - { Pointer A = Big_To_Float(Arg1); \ - if (Type_Code(A) == TC_BIG_FLONUM) \ - { Reduced_Flonum_Result(Get_Float(A) GENERAL_OP \ - Get_Float(Arg2)); \ - } \ - Primitive_Error(ERR_ARG_1_FAILED_COERCION); \ - } \ -P9_Two_Op_Operator(GENERAL_OP, BIG_OP) - -#define P9_Two_Op_Operator(GENERAL_OP, BIG_OP) \ - case TC_BIG_FIXNUM: \ - { Pointer Ans; \ - Bignum_Operation(BIG_OP(Fetch_Bignum(Arg1), \ - Fetch_Bignum(Arg2)), \ - Ans); \ - return Ans; \ - } \ - default: \ - Primitive_Error(ERR_ARG_2_WRONG_TYPE); \ - } \ - } \ - default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \ - } - -Built_In_Primitive(Prim_Plus, 2, "&+", 0xEC) -{ - Two_Op_Operator(+, plus_signed_bignum); - /*NOTREACHED*/ -} - -Built_In_Primitive(Prim_Minus, 2, "&-", 0xED) -{ - Two_Op_Operator(-, minus_signed_bignum); - /*NOTREACHED*/ -} - -Built_In_Primitive(Prim_Multiply, 2, "&*", 0xEE) -{ - /* Mul is machine dependent and lives in os.c */ - extern Pointer Mul(); - Primitive_2_Args(); - - Set_Time_Zone(Zone_Math); - switch (Type_Code(Arg1)) - { case TC_FIXNUM: - { switch (Type_Code(Arg2)) - { case TC_FIXNUM: - { fast Pointer Result; - Result = Mul(Arg1, Arg2); - if (Result != NIL) return Result; - { Pointer Big_Arg1, Big_Arg2; - Big_Arg1 = Fix_To_Big(Arg1); - Big_Arg2 = Fix_To_Big(Arg2); - Bignum_Operation(multiply_signed_bignum(Fetch_Bignum(Big_Arg1), - Fetch_Bignum(Big_Arg2)), - Big_Arg1); - return Big_Arg1; - } - } - case TC_BIG_FLONUM: - { fast long A; - Sign_Extend(Arg1, A); - Reduced_Flonum_Result(A * Get_Float(Arg2)); - } - -/* Prim_Multiply continues on the next page */ - -/* Prim_Multiply, continued */ - - case TC_BIG_FIXNUM: - { Pointer Big_Arg1 = Fix_To_Big(Arg1); - Bignum_Operation(multiply_signed_bignum(Fetch_Bignum(Big_Arg1), - Fetch_Bignum(Arg2)), - Big_Arg1); - return Big_Arg1; - } - default: - Primitive_Error(ERR_ARG_2_WRONG_TYPE); - } - /*NOTREACHED*/ - } - case TC_BIG_FLONUM: - { switch (Type_Code(Arg2)) - { case TC_FIXNUM: - { fast long B; - Sign_Extend(Arg2, B); - Reduced_Flonum_Result(Get_Float(Arg1) * B); - } - case TC_BIG_FLONUM: - Reduced_Flonum_Result(Get_Float(Arg1) * Get_Float(Arg2)); - case TC_BIG_FIXNUM: - { Pointer B = Big_To_Float(Arg2); - if (Type_Code(B) == TC_BIG_FLONUM) - { Reduced_Flonum_Result(Get_Float(Arg1) * Get_Float(B)); - } - Primitive_Error(ERR_ARG_2_FAILED_COERCION); - } - /*NOTREACHED*/ - default: - Primitive_Error(ERR_ARG_2_WRONG_TYPE); - } - /*NOTREACHED*/ - } - -/* Prim_Multiply continues on the next page */ - -/* Prim_Multiply, continued */ - - case TC_BIG_FIXNUM: - { switch (Type_Code(Arg2)) - { case TC_FIXNUM: - { Pointer Big_Arg2 = Fix_To_Big(Arg2); - Bignum_Operation(multiply_signed_bignum(Fetch_Bignum(Arg1), - Fetch_Bignum(Big_Arg2)), - Big_Arg2); - return Big_Arg2; - } - case TC_BIG_FLONUM: - { Pointer A = Big_To_Float(Arg1); - if (Type_Code(A) == TC_BIG_FLONUM) - { Reduced_Flonum_Result(Get_Float(A) * Get_Float(Arg2)); - } - Primitive_Error(ERR_ARG_1_FAILED_COERCION); - } - /*NOTREACHED*/ - case TC_BIG_FIXNUM: - { Pointer Ans; - Bignum_Operation(multiply_signed_bignum(Fetch_Bignum(Arg1), - Fetch_Bignum(Arg2)), - Ans); - return Ans; - } - default: - Primitive_Error(ERR_ARG_2_WRONG_TYPE); - } - /*NOTREACHED*/ - } - default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); - } - /*NOTREACHED*/ -} - -Built_In_Primitive(Prim_Divide, 2, "&/", 0xEF) -{ - Primitive_2_Args(); - - Set_Time_Zone(Zone_Math); - switch (Type_Code(Arg1)) - { case TC_FIXNUM: - { switch (Type_Code(Arg2)) - { case TC_FIXNUM: - { fast long A, B; - double Result; - Sign_Extend(Arg1, A); - Sign_Extend(Arg2, B); - if (B==0) Primitive_Error(ERR_ARG_2_BAD_RANGE); - Result = (double) A / (double) B; - Reduced_Flonum_Result(Result); - } - case TC_BIG_FLONUM: - { fast long A; - Sign_Extend(Arg1, A); - if (Get_Float(Arg2) == 0) - Primitive_Error(ERR_ARG_2_BAD_RANGE); - Reduced_Flonum_Result(((double) A) / Get_Float(Arg2)); - } - -/* Prim_Divide continues on the next page */ - -/* Prim_Divide, continued */ - - case TC_BIG_FIXNUM: - { Pointer Big_Arg1, Result, B; - long A; - if (ZERO_BIGNUM(Fetch_Bignum(Arg2))) - Primitive_Error(ERR_ARG_2_BAD_RANGE); - Big_Arg1 = Fix_To_Big(Arg1); - Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Big_Arg1), - Fetch_Bignum(Arg2)), - Result); - if (Vector_Ref(Result, CONS_CDR) == Make_Unsigned_Fixnum(0)) - return (Vector_Ref(Result, CONS_CAR)); - Sign_Extend(Arg1, A); - { B = Big_To_Float(Arg2); - if (Type_Code(B) == TC_BIG_FLONUM) - { Reduced_Flonum_Result(A / Get_Float(B)); - } - Primitive_Error(ERR_ARG_2_FAILED_COERCION); - } - /*NOTREACHED*/ - } - default: - Primitive_Error(ERR_ARG_2_WRONG_TYPE); - } - /*NOTREACHED*/ - } - case TC_BIG_FLONUM: - { switch (Type_Code(Arg2)) - { case TC_FIXNUM: - { fast long B; - Sign_Extend(Arg2, B); - if (B == 0) Primitive_Error(ERR_ARG_2_BAD_RANGE); - { Reduced_Flonum_Result(Get_Float(Arg1) / ((double) B)); - } - } - -/* Prim_Divide continues on the next page */ - -/* Prim_Divide, continued */ - - case TC_BIG_FLONUM: - if (Get_Float(Arg2) == 0) - Primitive_Error(ERR_ARG_2_BAD_RANGE); - Reduced_Flonum_Result(Get_Float(Arg1) / Get_Float(Arg2)); - case TC_BIG_FIXNUM: - { Pointer B; - if (ZERO_BIGNUM(Fetch_Bignum(Arg2))) - Primitive_Error(ERR_ARG_2_BAD_RANGE); - B = Big_To_Float(Arg2); - if (Type_Code(B) == TC_BIG_FLONUM) - { Reduced_Flonum_Result(Get_Float(Arg1) / Get_Float(B)); - } - Primitive_Error(ERR_ARG_2_FAILED_COERCION); - } - /*NOTREACHED*/ - default: - Primitive_Error(ERR_ARG_2_WRONG_TYPE); - } - /*NOTREACHED*/ - } - -/* Prim_Divide continues on the next page */ - -/* Prim_Divide, continued */ - - case TC_BIG_FIXNUM: - { switch (Type_Code(Arg2)) - { case TC_FIXNUM: - { Pointer Big_Arg2, Result, A; - Big_Arg2 = Fix_To_Big(Arg2); - if (ZERO_BIGNUM(Fetch_Bignum(Big_Arg2))) - Primitive_Error(ERR_ARG_2_BAD_RANGE); - Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Arg1), - Fetch_Bignum(Big_Arg2)), - Result); - if (Vector_Ref(Result, CONS_CDR) == Make_Unsigned_Fixnum(0)) - return (Vector_Ref(Result, CONS_CAR)); - A = Big_To_Float(Arg1); - if (Type_Code(A) == TC_BIG_FLONUM) - { long B; - Sign_Extend(Arg2, B); - Reduced_Flonum_Result(Get_Float(A) / ((double) B)); - } - Primitive_Error(ERR_ARG_1_FAILED_COERCION); - } - /*NOTREACHED*/ - case TC_BIG_FLONUM: - { Pointer A; - if (Get_Float(Arg2) == 0.0) - Primitive_Error(ERR_ARG_2_BAD_RANGE); - A = Big_To_Float(Arg1); - if (Type_Code(A) == TC_BIG_FLONUM) - { Reduced_Flonum_Result(Get_Float(A) / Get_Float(Arg2)); - } - Primitive_Error(ERR_ARG_1_FAILED_COERCION); - } - /*NOTREACHED*/ - -/* Prim_Divide continues on the next page */ - -/* Prim_Divide, continued */ - - case TC_BIG_FIXNUM: - { Pointer Result, A, B; - if (ZERO_BIGNUM(Fetch_Bignum(Arg2))) - Primitive_Error(ERR_ARG_2_BAD_RANGE); - Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Arg1), - Fetch_Bignum(Arg2)), - Result); - if (Vector_Ref(Result, CONS_CDR) == Make_Unsigned_Fixnum(0)) - return (Vector_Ref(Result, CONS_CAR)); - A = Big_To_Float(Arg1); - if (Type_Code(A) == TC_BIG_FLONUM) - { B = Big_To_Float(Arg2); - if (Type_Code(B) == TC_BIG_FLONUM) - { if (Get_Float(B) == 0) - Primitive_Error(ERR_ARG_2_BAD_RANGE); - { Reduced_Flonum_Result(Get_Float(A) / Get_Float(B)); - } - } - Primitive_Error(ERR_ARG_2_FAILED_COERCION); - } - /*NOTREACHED*/ - Primitive_Error(ERR_ARG_1_FAILED_COERCION); - } - default: - Primitive_Error(ERR_ARG_2_WRONG_TYPE); - } - /*NOTREACHED*/ - } - default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); - } - /*NOTREACHED*/ -} - -Built_In_Primitive(Prim_Integer_Divide, 2, "INTEGER-DIVIDE", 0xF0) -{ - Primitive_2_Args(); - - Set_Time_Zone(Zone_Math); - switch (Type_Code(Arg1)) - { case TC_FIXNUM: - { switch (Type_Code(Arg2)) - { case TC_FIXNUM: - { fast long A, B, C, D; - Pointer *Cons_Cell; - Sign_Extend(Arg1, A); - Sign_Extend(Arg2, B); - if (B == 0) - Primitive_Error(ERR_ARG_2_BAD_RANGE); - Primitive_GC_If_Needed(2); - /* These (C & D) are necessary because Make_Non_Pointer casts to - Pointer which is unsigned long, and then the arithmetic is wrong - if the operations are placed in the macro "call". */ - C = A / B; - D = A % B; - Cons_Cell = Free; - Free += 2; - Cons_Cell[CONS_CAR] = Make_Non_Pointer(TC_FIXNUM, C); - Cons_Cell[CONS_CDR] = Make_Non_Pointer(TC_FIXNUM, D); - return Make_Pointer(TC_LIST, Cons_Cell); - } - case TC_BIG_FIXNUM: - { Pointer Big_Arg1, Pair; - if (ZERO_BIGNUM(Fetch_Bignum(Arg2))) - Primitive_Error(ERR_ARG_2_BAD_RANGE); - Big_Arg1 = Fix_To_Big(Arg1); - Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Big_Arg1), - Fetch_Bignum(Arg2)), - Pair); - return Pair; - } - default: - Primitive_Error(ERR_ARG_2_WRONG_TYPE); - } - /*NOTREACHED*/ - } - -/* Prim_Integer_Divide continues on the next page */ - -/* Prim_Integer_Divide, continued */ - - case TC_BIG_FIXNUM: - { switch (Type_Code(Arg2)) - { case TC_FIXNUM: - { Pointer Big_Arg2, Pair; - if (Get_Integer(Arg2) == 0) - Primitive_Error(ERR_ARG_2_BAD_RANGE); - Big_Arg2 = Fix_To_Big(Arg2); - Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Arg1), - Fetch_Bignum(Big_Arg2)), - Pair); - return Pair; - } - case TC_BIG_FIXNUM: - { Pointer Pair; - if (ZERO_BIGNUM(Fetch_Bignum(Arg2))) - Primitive_Error(ERR_ARG_2_BAD_RANGE); - Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Arg1), - Fetch_Bignum(Arg2)), - Pair); - return Pair; - } - default: - Primitive_Error(ERR_ARG_2_WRONG_TYPE); - } - /*NOTREACHED*/ - } - default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); - } - /*NOTREACHED*/ -} - -/* Generic sqrt and transcendental functions are created by generalizing - their floating point counterparts. -*/ - -#define Generic_Function(Routine) \ - double Routine(); \ - Primitive_1_Arg(); \ - \ - Set_Time_Zone(Zone_Math); \ - switch (Type_Code(Arg1)) \ - { case TC_FIXNUM: \ - { long Arg; \ - Sign_Extend(Arg1, Arg); \ - Reduced_Flonum_Result(Routine((double) Arg)); \ - } \ - case TC_BIG_FLONUM: \ - Reduced_Flonum_Result(Routine(Get_Float(Arg1))); \ - case TC_BIG_FIXNUM: \ - { Pointer A = Big_To_Float(Arg1); \ - if (Type_Code(A) != TC_BIG_FLONUM) \ - Primitive_Error(ERR_ARG_1_FAILED_COERCION); \ - Reduced_Flonum_Result(Routine(Get_Float(A))); \ - } \ - default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \ - } - -/* This horrible hack because there are no lambda-expressions in C. */ - -#define Generic_Restriction(Lambda, Routine, Restriction) \ -double \ -Lambda(arg) \ - fast double arg; \ -{ \ - double Routine(); \ - \ - if (arg Restriction 0.0) \ - Primitive_Error(ERR_ARG_1_BAD_RANGE); \ - return Routine(arg); \ -} - -/* And here the functions themselves */ - -Generic_Restriction(Scheme_Sqrt, sqrt, <) -Generic_Restriction(Scheme_Ln, log, <=) - -Built_In_Primitive(Prim_Sqrt, 1, "SQRT", 0xF7) -{ - Generic_Function(Scheme_Sqrt); - /*NOTREACHED*/ -} - -Built_In_Primitive(Prim_Exp, 1, "EXP", 0xF8) -{ - Generic_Function(exp); - /*NOTREACHED*/ -} - -Built_In_Primitive(Prim_Ln, 1, "LOG", 0xF9) -{ - Generic_Function(Scheme_Ln); - /*NOTREACHED*/ -} - -Built_In_Primitive(Prim_Sine, 1, "SIN", 0xFA) -{ - Generic_Function(sin); - /*NOTREACHED*/ -} - -Built_In_Primitive(Prim_Cosine, 1, "COS", 0xFB) -{ - Generic_Function(cos); - /*NOTREACHED*/ -} - -Built_In_Primitive(Prim_Arctan, 1, "&ATAN", 0xFC) -{ - Generic_Function(atan); - /*NOTREACHED*/ -} - -/* Coercions from Floating point to integers. - - There are four possible ways to coerce: - - - Truncate : towards 0. - - Round : towards closest integer. - - Floor : towards -infinity. - - Ceiling : towards +infinity. - - All these primitives differ only in how floating point numbers - are mapped before they are truncated. - - If the system does not provide the double precision procedures - floor and ceil, Floor is incorrect for negative integers in - floating point format, and Ceiling is incorrect for positive - integers in floating point format. -*/ - -#define Truncate_Mapping(arg) arg -#define Round_Mapping(arg) ((arg) >= 0.0 ? ((arg) + 0.5) : ((arg) - 0.5)) - -#ifdef HAS_FLOOR - -extern double floor(), ceil(); -#define Floor_Mapping(arg) floor(arg) -#define Ceiling_Mapping(arg) ceil(arg) - -#else - -#define Floor_Mapping(arg) ((arg) >= 0.0 ? (arg) : ((arg) - 1.0)) -#define Ceiling_Mapping(arg) ((arg) >= 0.0 ? ((arg) + 1.0) : (arg)) - -#endif - -#define Flonum_To_Integer(How_To_Do_It) \ - Primitive_1_Arg(); \ - Set_Time_Zone(Zone_Math); \ - switch (Type_Code(Arg1)) \ - { case TC_FIXNUM : \ - case TC_BIG_FIXNUM: return Arg1; \ - case TC_BIG_FLONUM: \ - { fast double Arg = Get_Float(Arg1); \ - fast double temp = How_To_Do_It(Arg); \ - Pointer Result; \ - if (flonum_exceeds_fixnum(temp)) Result = Float_To_Big(temp); \ - else double_into_fixnum(temp, Result); \ - return Result; \ - } \ - default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \ - } - -Built_In_Primitive(Prim_Truncate, 1, "TRUNCATE", 0xF3) -{ - Flonum_To_Integer(Truncate_Mapping); - /*NOTREACHED*/ -} - -Built_In_Primitive(Prim_Round, 1, "ROUND", 0xF4) -{ - Flonum_To_Integer(Round_Mapping); - /*NOTREACHED*/ -} - -Built_In_Primitive(Prim_Floor, 1, "FLOOR", 0xF5) -{ - Flonum_To_Integer(Floor_Mapping); - /*NOTREACHED*/ -} - -Built_In_Primitive(Prim_Ceiling, 1, "CEILING", 0xF6) -{ - Flonum_To_Integer(Ceiling_Mapping); - /*NOTREACHED*/ -} diff --git a/v7/src/microcode/history.h b/v7/src/microcode/history.h deleted file mode 100644 index 3c1da862e..000000000 --- a/v7/src/microcode/history.h +++ /dev/null @@ -1,146 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/history.h,v 9.22 1987/04/16 02:23:38 jinx Rel $ - * - * History maintenance data structures and support. - * - */ - -/* - * The history consists of a "vertebra" which is a doubly linked ring, - * each entry pointing to a "rib". The rib consists of a singly - * linked ring whose entries contain expressions and environments. - */ - -#define HIST_RIB 0 -#define HIST_NEXT_SUBPROBLEM 1 -#define HIST_PREV_SUBPROBLEM 2 -#define HIST_MARK 1 - -#define RIB_EXP 0 -#define RIB_ENV 1 -#define RIB_NEXT_REDUCTION 2 -#define RIB_MARK 2 - -/* Save_History places a restore history frame on the stack. Such a - * frame consists of a normal continuation frame plus a pointer to the - * stacklet on which the last restore history is located and the - * offset within that stacklet. If the last restore history is in - * this stacklet then the history pointer is NIL to signify this. If - * there is no previous restore history then the history pointer is - * NIL and the offset is 0. - */ - -#define Save_History(Return_Code) \ -{ \ - if (Prev_Restore_History_Stacklet == NULL) \ - Push(NIL); \ - else \ - Push(Make_Pointer(TC_CONTROL_POINT, \ - Prev_Restore_History_Stacklet)); \ - Push(Make_Non_Pointer(TC_FIXNUM, Prev_Restore_History_Offset)); \ - Store_Expression(Make_Pointer(TC_HUNK3, History)); \ - Store_Return((Return_Code)); \ - Save_Cont(); \ - History = Get_Pointer(Get_Fixed_Obj_Slot(Dummy_History)); \ -} - -/* History manipulation in the interpreter. */ - -#ifdef COMPILE_HISTORY -#define New_Subproblem(Expr, Env) \ -{ fast Pointer *Rib; \ - History = Get_Pointer(History[HIST_NEXT_SUBPROBLEM]); \ - History[HIST_MARK] |= DANGER_BIT; \ - Rib = Get_Pointer(History[HIST_RIB]); \ - Rib[RIB_MARK] |= DANGER_BIT; \ - Rib[RIB_ENV] = Env; \ - Rib[RIB_EXP] = Expr; \ -} - -#define Reuse_Subproblem(Expr, Env) \ -{ fast Pointer *Rib; \ - Rib = Get_Pointer(History[HIST_RIB]); \ - Rib[RIB_MARK] |= DANGER_BIT; \ - Rib[RIB_ENV] = Env; \ - Rib[RIB_EXP] = Expr; \ -} - -#define New_Reduction(Expr, Env) \ -{ fast Pointer *Rib; \ - Rib = Get_Pointer(Fast_Vector_Ref(History[HIST_RIB], \ - RIB_NEXT_REDUCTION)); \ - History[HIST_RIB] = Make_Pointer(TC_HUNK3, Rib); \ - Rib[RIB_ENV] = Env; \ - Rib[RIB_EXP] = Expr; \ - Rib[RIB_MARK] &= ~DANGER_BIT; \ -} - -#define End_Subproblem() \ - History[HIST_MARK] &= ~DANGER_BIT; \ - History = Get_Pointer(History[HIST_PREV_SUBPROBLEM]); - -#else /* COMPILE_HISTORY */ -#define New_Subproblem(Expr, Env) { } -#define Reuse_Subproblem(Expr, Env) { } -#define New_Reduction(Expr, Env) { } -#define End_Subproblem() { } -#endif /* COMPILE_HISTORY */ - -/* History manipulation for the compiled code interface. */ - -#ifdef COMPILE_HISTORY - -#define Compiler_New_Reduction() \ -{ New_Reduction(NIL, \ - Make_Non_Pointer(TC_RETURN_CODE, \ - RC_POP_FROM_COMPILED_CODE)); \ -} - -#define Compiler_New_Subproblem() \ -{ New_Subproblem(NIL, \ - Make_Non_Pointer(TC_RETURN_CODE, \ - RC_POP_FROM_COMPILED_CODE)); \ -} - -#define Compiler_End_Subproblem() \ -{ End_Subproblem(); \ -} - -#else /* COMPILE_HISTORY */ - -#define Compiler_New_Reduction() -#define Compiler_New_Subproblem() -#define Compiler_End_Subproblem() - -#endif /* COMPILE_HISTORY */ diff --git a/v7/src/microcode/hooks.c b/v7/src/microcode/hooks.c deleted file mode 100644 index 8ffa26132..000000000 --- a/v7/src/microcode/hooks.c +++ /dev/null @@ -1,692 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.23 1987/04/16 02:23:49 jinx Exp $ - * - * This file contains various hooks and handles which connect the - * primitives with the main interpreter. - */ - -#include "scheme.h" -#include "primitive.h" -#include "winder.h" - -/* (APPLY FN LIST-OF-ARGUMENTS) - Calls the function FN to the arguments specified in the list - LIST-OF-ARGUMENTS. FN must be a primitive procedure, compound - procedure, or control point. */ - -Built_In_Primitive(Prim_Apply, 2, "APPLY", 0x5) -{ - fast Pointer scan_list, *scan_stack; - fast long number_of_args, i; -#ifdef butterfly - Pointer *saved_stack_pointer; -#endif - Primitive_2_Args(); - - /* Since this primitive must pop its own frame off and push a new - frame on the stack, it has to be careful. Its own stack frame is - needed if an error or GC is required. So these checks are done - first (at the cost of traversing the argument list twice), then - the primitive's frame is popped, and finally the new frame is - constructed. - - Originally this code tried to be clever by copying the argument - list into a linear (vector-like) form, so as to avoid the - overhead of traversing the list twice. Unfortunately, the - overhead of maintaining this other form (e.g. PRIMITIVE_GC_If_Needed) - is sufficiently high that it probably makes up for the time saved. */ - - Touch_In_Primitive( Arg2, scan_list); - number_of_args = 0; - while (Type_Code( scan_list) == TC_LIST) - { - number_of_args += 1; - Touch_In_Primitive( Vector_Ref( scan_list, CONS_CDR), scan_list); - } - if (scan_list != NIL) - Primitive_Error( ERR_ARG_2_WRONG_TYPE); -#ifdef USE_STACKLETS - /* This is conservative: if the number of arguments is large enough - the Will_Push below may try to allocate space on the heap for the - stack frame. */ - Primitive_GC_If_Needed(New_Stacklet_Size(number_of_args + - STACK_ENV_EXTRA_SLOTS + 1)); -#endif - Pop_Primitive_Frame( 2); - - Will_Push( (number_of_args + STACK_ENV_EXTRA_SLOTS + 1)); -#ifdef butterfly - saved_stack_pointer = Stack_Pointer; -#endif - scan_stack = Simulate_Pushing( number_of_args); - Stack_Pointer = scan_stack; - i = number_of_args; - Touch_In_Primitive( Arg2, scan_list); - while (i > 0) - { -#ifdef butterfly - /* Check for abominable case of someone bashing the arg list. */ - if (Type_Code( scan_list) != TC_LIST) - { - Stack_Pointer = saved_stack_pointer; - Primitive_Error( ERR_ARG_2_BAD_RANGE); - } -#endif - *scan_stack++ = Vector_Ref( scan_list, CONS_CAR); - Touch_In_Primitive( Vector_Ref( scan_list, CONS_CDR), scan_list); - i -= 1; - } - Push( Arg1); /* The procedure */ - Push( (STACK_FRAME_HEADER + number_of_args)); - Pushed(); - longjmp( *Back_To_Eval, PRIM_APPLY); - /*NOTREACHED*/ -} - -/* This code used to be in the middle of Make_Control_Point, replaced - * by CWCC below. Preprocessor conditionals do not work in macros. - */ - -#define CWCC(Return_Code) \ - fast Pointer *From_Where; \ - Primitive_1_Arg(); \ - CWCC_1(); \ - /* Implementation detail: in addition to setting aside the old \ - stacklet on a catch, the new stacklet is cleared and a return \ - code is placed at the base of the (now clear) stack indicating \ - that a return back through here requires restoring the stacklet. \ - The current enabled interrupts are also saved in the old stacklet. \ - \ - >>> Temporarily (maybe) the act of doing a CATCH will disable any \ - >>> return hook that may be in the stack. \ - \ - >>> Don't even think about adding COMPILER to this stuff! \ - */ \ - Pop_Primitive_Frame(1); \ - if (Return_Hook_Address != NULL) \ - { *Return_Hook_Address = Old_Return_Code; \ - Return_Hook_Address = NULL; \ - } \ -/* Put down frames to restore history and interrupts so that these \ - * operations will be performed on a throw. \ - */ \ - Will_Push(CONTINUATION_SIZE + HISTORY_SIZE); \ - Save_History(Return_Code); \ - Store_Expression(Make_Non_Pointer(TC_FIXNUM, IntEnb)); \ - Store_Return(RC_RESTORE_INT_MASK); \ - Save_Cont(); \ - Pushed(); \ -/* There is no history to use since the last control point was formed. \ - */ \ - Prev_Restore_History_Stacklet = NULL; \ - Prev_Restore_History_Offset = 0; \ - CWCC_2(); \ -/* Will_Push(3); -- we just cleared the stack so there MUST be room */ \ - Push(Control_Point); \ - Push(Arg1); /* Function */ \ - Push(STACK_FRAME_HEADER+1); -/* Pushed(); */ - -#ifdef USE_STACKLETS -#define CWCC_1() \ - Primitive_GC_If_Needed(2*Default_Stacklet_Size) - -#define CWCC_2() \ - Control_Point = Get_Current_Stacklet(); \ - Allocate_New_Stacklet(3) - -#else /* Not using stacklets, so full copy must be made */ -#define CWCC_1() \ - Primitive_GC_If_Needed((Stack_Top-Stack_Pointer) + \ - STACKLET_HEADER_SIZE - 1 + \ - CONTINUATION_SIZE + \ - HISTORY_SIZE) - -#define CWCC_2() \ -{ fast long i; \ - fast long Stack_Cells = (Stack_Top-Stack_Pointer); \ - Control_Point = Make_Pointer(TC_CONTROL_POINT, Free); \ - Free[STACKLET_LENGTH] = \ - Make_Non_Pointer(TC_MANIFEST_VECTOR, \ - Stack_Cells + STACKLET_HEADER_SIZE - 1); \ - Free[STACKLET_UNUSED_LENGTH] = \ - Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0); \ - Free += STACKLET_HEADER_SIZE; \ - for (i=0; i < Stack_Cells; i++) *Free++ = Pop(); \ - if (Consistency_Check) \ - if (Stack_Pointer != Stack_Top) \ - Microcode_Termination(TERM_BAD_STACK); \ - Will_Push(CONTINUATION_SIZE); \ - Store_Return(RC_JOIN_STACKLETS); \ - Store_Expression(Control_Point); \ - Save_Cont(); \ - Pushed(); \ -} -#endif - -/* (CALL-WITH-CURRENT-CONTINUATION PROCEDURE) - Creates a control point (a pointer to the current stack) and - passes it to PROCEDURE as its only argument. The inverse - operation, typically called THROW, is performed by using the - control point as you would a procedure. A control point accepts - one argument which is then returned as the value of the CATCH - which created the control point. If the dangerous bit of the - unused length word in the stacklet is clear then the control - point may be reused as often as desired since the stack will be - copied on every throw. The user level CATCH is built on this - primitive but is not the same, since it handles dynamic-wind - while the primitive does not; it assumes that the microcode - sets and clears the appropriate danger bits for copying. -*/ - -Built_In_Primitive(Prim_Catch, 1, "CALL-WITH-CURRENT-CONTINUATION", 0x3) -{ - fast Pointer Control_Point; - - CWCC(RC_RESTORE_HISTORY); - Clear_Danger_Bit((Get_Pointer(Control_Point))[STACKLET_UNUSED_LENGTH]); - longjmp(*Back_To_Eval, PRIM_APPLY); - /*NOTREACHED*/ -} - -Built_In_Primitive(Prim_Non_Reentrant_Catch, 1, - "NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION", 0x9) -{ - Pointer Control_Point; - -#ifdef USE_STACKLETS - - CWCC(RC_RESTORE_DONT_COPY_HISTORY); - -#else - /* When there are no stacklets, it is identical to the reentrant version. */ - - CWCC(RC_RESTORE_HISTORY); - Clear_Danger_Bit((Get_Pointer(Control_Point))[STACKLET_UNUSED_LENGTH]); - -#endif - - longjmp(*Back_To_Eval, PRIM_APPLY); - /*NOTREACHED*/ -} - -/* (ENABLE-INTERRUPTS! INTERRUPTS) - Changes the enabled interrupt bits to bitwise-or of INTERRUPTS - and previous value of interrupts. Returns the previous value. - See MASK_INTERRUPT_ENABLES for more information on interrupts. -*/ -Built_In_Primitive(Prim_Enable_Interrupts, 1, "ENABLE-INTERRUPTS!", 0x1E) -{ - Pointer Result; - Primitive_1_Arg(); - - Arg_1_Type(TC_FIXNUM); - Result = Make_Non_Pointer(TC_FIXNUM, IntEnb); - IntEnb = Get_Integer(Arg1) | INT_Mask; - New_Compiler_MemTop(); - return Result; -} - -/* (ERROR-PROCEDURE arg1 arg2 arg3) - Passes its arguments along to the appropriate Scheme error handler - after turning off history, etc. -*/ -Built_In_Primitive(Prim_Error_Procedure, 3, "ERROR-PROCEDURE", 0x18E) -{ - Primitive_3_Args(); - - Will_Push(CONTINUATION_SIZE+HISTORY_SIZE+STACK_ENV_EXTRA_SLOTS+4); - Back_Out_Of_Primitive(); - Save_Cont(); - Stop_History(); - /* Stepping should be cleared here! */ - Push(Arg3); - Push(Arg2); - Push(Arg1); - Push(Get_Fixed_Obj_Slot(Error_Procedure)); - Push(STACK_FRAME_HEADER+3); - Pushed(); - longjmp(*Back_To_Eval, PRIM_APPLY); - /*NOTREACHED*/ -} - -/* (GET-FIXED-OBJECTS-VECTOR) - Returns the current fixed objects vector. This vector is used - for communication between the interpreter and the runtime - system. See the file UTABCSCM.SCM in the runtime system for the - names of the slots in the vector. -*/ -Built_In_Primitive(Prim_Get_Fixed_Objects_Vector, 0, - "GET-FIXED-OBJECTS-VECTOR", 0x7A) -{ - Primitive_0_Args(); - - if (Valid_Fixed_Obj_Vector()) - return Get_Fixed_Obj_Slot(Me_Myself); - else return NIL; -} - -/* (FORCE DELAYED-OBJECT) - Returns the memoized value of the DELAYED-OBJECT (created by a - DELAY special form) if it has already been calculated. - Otherwise, it calculates the value and memoizes it for future - use. -*/ -Built_In_Primitive(Prim_Force, 1, "FORCE", 0xAF) -{ - Primitive_1_Arg(); - - Arg_1_Type(TC_DELAYED); - if (Vector_Ref(Arg1, THUNK_SNAPPED) == TRUTH) - return Vector_Ref(Arg1, THUNK_VALUE); - Pop_Primitive_Frame(1); - Will_Push(CONTINUATION_SIZE); - Store_Return(RC_SNAP_NEED_THUNK); - Store_Expression(Arg1); - Save_Cont(); - Pushed(); - Store_Env(Fast_Vector_Ref(Arg1, THUNK_ENVIRONMENT)); - Store_Expression(Fast_Vector_Ref(Arg1, THUNK_PROCEDURE)); - longjmp(*Back_To_Eval, PRIM_DO_EXPRESSION); - /*NOTREACHED*/ -} - -/* (EXECUTE-AT-NEW-POINT SPACE BEFORE DURING AFTER) - Create a new state point in the specified state SPACE. To enter - the new point you must execute the BEFORE thunk. On the way out, - the AFTER thunk is executed. If SPACE is NIL, then the microcode - variable Current_State_Point is used to find the current state - point and no state space is side-effected as the code runs. -*/ -Built_In_Primitive(Prim_Execute_At_New_Point, 4, "EXECUTE-AT-NEW-POINT", 0xE2) -{ - Pointer New_Point, Old_Point; - Primitive_4_Args(); - - guarantee_state_point(); - if (Arg1 == NIL) Old_Point = Current_State_Point; - else - { Arg_1_Type(TC_VECTOR); - if (Vector_Ref(Arg1, STATE_SPACE_TAG) != - Get_Fixed_Obj_Slot(State_Space_Tag)) - Primitive_Error(ERR_ARG_1_WRONG_TYPE); - Old_Point = Fast_Vector_Ref(Arg1, STATE_SPACE_NEAREST_POINT); - } - Primitive_GC_If_Needed(STATE_POINT_SIZE); - Pop_Primitive_Frame(4); - New_Point = Make_Pointer(TC_VECTOR, Free); - Free[STATE_POINT_HEADER] = - Make_Non_Pointer(TC_MANIFEST_VECTOR, STATE_POINT_SIZE-1); - Free[STATE_POINT_TAG] = Get_Fixed_Obj_Slot(State_Point_Tag); - Free[STATE_POINT_BEFORE_THUNK] = Arg2; - Free[STATE_POINT_AFTER_THUNK] = Arg4; - Free[STATE_POINT_NEARER_POINT] = Old_Point; - Free[STATE_POINT_DISTANCE_TO_ROOT] = - 1 + Fast_Vector_Ref(Old_Point, STATE_POINT_DISTANCE_TO_ROOT); - Free += STATE_POINT_SIZE; - Will_Push(2*CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+1)); - /* Push a continuation to go back to the current state after the - body is evaluated */ - Store_Expression(Old_Point); - Store_Return(RC_RESTORE_TO_STATE_POINT); - Save_Cont(); - /* Push a stack frame which will call the body after we have moved - into the new state point */ - Push(Arg3); - Push(STACK_FRAME_HEADER); - /* Push the continuation to go with the stack frame */ - Store_Expression(NIL); - Store_Return(RC_INTERNAL_APPLY); - Save_Cont(); - Pushed(); - Translate_To_Point(New_Point); -} - -/* (MAKE-STATE-SPACE MUTABLE?) - Creates a new state space for the dynamic winder. Used only - internally to the dynamic wind operations. If the arugment - is #!TRUE, then a real, mutable state space is created. - Otherwise a (actually, THE) immutable space is created and - the microcode will track motions in this space. -*/ -Built_In_Primitive(Prim_Make_State_Space, 1, "MAKE-STATE-SPACE", 0xE1) -{ - Pointer New_Point; - Primitive_1_Arg(); - - Primitive_GC_If_Needed(STATE_POINT_SIZE+STATE_SPACE_SIZE); - New_Point = Make_Pointer(TC_VECTOR, Free); - Free[STATE_POINT_HEADER] = - Make_Non_Pointer(TC_MANIFEST_VECTOR, STATE_POINT_SIZE-1); - Free[STATE_POINT_TAG] = Get_Fixed_Obj_Slot(State_Point_Tag); - Free[STATE_POINT_BEFORE_THUNK] = NIL; - Free[STATE_POINT_AFTER_THUNK] = NIL; - Free[STATE_POINT_NEARER_POINT] = NIL; - Free[STATE_POINT_DISTANCE_TO_ROOT] = Make_Unsigned_Fixnum(0); - Free += STATE_POINT_SIZE; - if (Arg1 == NIL) - { Current_State_Point = New_Point; - return NIL; - } - else - { Pointer New_Space = Make_Pointer(TC_VECTOR, Free); - Free[STATE_SPACE_HEADER] = - Make_Non_Pointer(TC_MANIFEST_VECTOR, STATE_SPACE_SIZE-1); - Free[STATE_SPACE_TAG] = Get_Fixed_Obj_Slot(State_Space_Tag); - Free[STATE_SPACE_NEAREST_POINT] = New_Point; - Free += STATE_SPACE_SIZE; - Fast_Vector_Set(New_Point, STATE_POINT_NEARER_POINT, New_Space); - return New_Space; - } -} - -Built_In_Primitive(Prim_Current_Dynamic_State, 1, "CURRENT-DYNAMIC-STATE", 0xA) -{ - Primitive_1_Arg(); - - guarantee_state_point(); - if (Arg1 == NIL) return Current_State_Point; - Arg_1_Type(TC_VECTOR); - if (Fast_Vector_Ref(Arg1, STATE_SPACE_TAG) != - Get_Fixed_Obj_Slot(State_Space_Tag)) - Primitive_Error(ERR_ARG_1_WRONG_TYPE); - return Vector_Ref(Arg1, STATE_SPACE_NEAREST_POINT); -} - -Built_In_Primitive(Prim_Set_Dynamic_State, 1, "SET-CURRENT-DYNAMIC-STATE!", 0xB) -{ - Pointer State_Space, Result; - Primitive_1_Arg(); - - Arg_1_Type(TC_VECTOR); - if (Fast_Vector_Ref(Arg1, STATE_POINT_TAG) != - Get_Fixed_Obj_Slot(State_Point_Tag)) - Primitive_Error(ERR_ARG_1_WRONG_TYPE); - State_Space = Find_State_Space(Arg1); - if (State_Space==NIL) - { - guarantee_state_point(); - Result = Current_State_Point; - Current_State_Point = Arg1; - } - else - { - Result = Vector_Ref(State_Space, STATE_SPACE_NEAREST_POINT); - Vector_Set(State_Space, STATE_SPACE_NEAREST_POINT, Arg1); - } - return Result; -} - -/* (SCODE-EVAL SCODE-EXPRESSION ENVIRONMENT) - Evaluate the piece of SCode (SCODE-EXPRESSION) in the - ENVIRONMENT. This is like Eval, except that it expects its input - to be syntaxed into SCode rather than just a list. -*/ -Built_In_Primitive(Prim_Scode_Eval, 2, "SCODE-EVAL", 0x4) -{ - Primitive_2_Args(); - - if (Type_Code(Arg2) != GLOBAL_ENV) - Arg_2_Type(TC_ENVIRONMENT); - Pop_Primitive_Frame(2); - Store_Env(Arg2); - Store_Expression(Arg1); - longjmp(*Back_To_Eval, PRIM_DO_EXPRESSION); - /*NOTREACHED*/ -} - -/* (SET-INTERRUPT-ENABLES! NEW-INT-ENABLES) - Changes the enabled interrupt bits to NEW-INT-ENABLES and - returns the previous value. See MASK_INTERRUPT_ENABLES for more - information on interrupts. -*/ -Built_In_Primitive(Prim_Set_Interrupt_Enables, 1, "SET-INTERRUPT-ENABLES!", 0x6) -{ - Pointer Result; - Primitive_1_Arg(); - - Arg_1_Type(TC_FIXNUM); - Result = Make_Unsigned_Fixnum(IntEnb); - IntEnb = Get_Integer(Arg1) & INT_Mask; - New_Compiler_MemTop(); - return Result; -} - -/* (SET-CURRENT-HISTORY! TRIPLE) - Begins recording history into TRIPLE. The history structure is - somewhat complex and should be understood before trying to use - this primitive. It is used in the Read-Eval-Print loop in the - Scheme runtime system. - - This primitive pops its own frame and escapes back to the interpreter - because it modifies one of the registers that the interpreter caches - (History). - - The longjmp forces the interpreter to recache. -*/ -Built_In_Primitive(Prim_Set_Current_History, 1, "SET-CURRENT-HISTORY!", 0x2F) -{ - Primitive_1_Arg(); - - /* History is one of the few places where we still used danger bits. - Check explicitely. - */ - - if ((safe_pointer_type (Arg1)) != TC_HUNK3) - error_wrong_type_arg_1 (); - - Val = *History; -#ifdef COMPILE_HISTORY - History = Get_Pointer(Arg1); -#else - History = Get_Pointer(Get_Fixed_Obj_Slot(Dummy_History)); -#endif - Pop_Primitive_Frame( 1); - longjmp( *Back_To_Eval, PRIM_POP_RETURN); - /*NOTREACHED*/ -} - -/* (SET-FIXED-OBJECTS-VECTOR! VECTOR) - Replace the current fixed objects vector with VECTOR. The fixed - objects vector is used for communication between the Scheme - runtime system and the interpreter. The file UTABCSCM.SCM - contains the names of the slots in the vector. Returns (bad - style to depend on this) the previous fixed objects vector. -*/ -Built_In_Primitive(Prim_Set_Fixed_Objects_Vector, 1, - "SET-FIXED-OBJECTS-VECTOR!", 0x7B) -{ - Pointer Result; - Primitive_1_Arg(); - - Arg_1_Type(TC_VECTOR); - if (Valid_Fixed_Obj_Vector()) - Result = Get_Fixed_Obj_Slot(Me_Myself); - else Result = NIL; - Set_Fixed_Obj_Hook(Arg1); - Set_Fixed_Obj_Slot(Me_Myself, Arg1); - return Result; -} - -/* (TRANSLATE-TO-STATE-POINT STATE_POINT) - Move to a new dynamic wind environment by performing all of the - necessary enter and exit forms to get from the current state to - the new state as specified by STATE_POINT. -*/ -Built_In_Primitive(Prim_Translate_To_Point, 1, - "TRANSLATE-TO-STATE-POINT", 0xE3) -{ - Primitive_1_Arg(); - - Arg_1_Type(TC_VECTOR); - if (Vector_Ref(Arg1, STATE_POINT_TAG) != Get_Fixed_Obj_Slot(State_Point_Tag)) - Primitive_Error(ERR_ARG_1_WRONG_TYPE); - Pop_Primitive_Frame(1); - Translate_To_Point(Arg1); - /* This ends by longjmp-ing back to the interpreter */ - /*NOTREACHED*/ -} - -/* (WITH-HISTORY-DISABLED THUNK) - THUNK must be a procedure or primitive procedure which takes no - arguments. Turns off the history collection mechanism. Removes - the most recent reduction (the expression which called the - primitive) from the current history and saves the history. Then - it calls the THUNK. When (if) the THUNK returns, the history is - restored back and collection resumes. The net result is that the - THUNK is called with history collection turned off. -*/ -Built_In_Primitive(Prim_With_History_Disabled, 1, - "WITH-HISTORY-DISABLED", 0x9C) -{ - Pointer *First_Rib, *Rib, *Second_Rib; - Primitive_1_Arg(); - - /* Remove one reduction from the history before saving it */ - First_Rib = Get_Pointer(History[HIST_RIB]); - Second_Rib = Get_Pointer(First_Rib[RIB_NEXT_REDUCTION]); - if (!((Dangerous(First_Rib[RIB_MARK])) || - (First_Rib == Second_Rib))) - { Set_Danger_Bit(Second_Rib[RIB_MARK]); - for (Rib = First_Rib; - Get_Pointer(Rib[RIB_NEXT_REDUCTION]) != First_Rib; - Rib = Get_Pointer(Rib[RIB_NEXT_REDUCTION])) - { /* Look for one that points to the first rib */ } - History[HIST_RIB] = Make_Pointer(Type_Code(History[HIST_RIB]), Rib); - } - Pop_Primitive_Frame(1); - Stop_History(); - Will_Push(STACK_ENV_EXTRA_SLOTS+1); - Push(Arg1); - Push(STACK_FRAME_HEADER); - Pushed(); - longjmp(*Back_To_Eval, PRIM_APPLY); - /*NOTREACHED*/ -} - -/* Called with a mask and a thunk */ - -Built_In_Primitive(Prim_With_Interrupt_Mask, 2, - "WITH-INTERRUPT-MASK", 0x137) -{ - Primitive_2_Args(); - - Arg_1_Type(TC_FIXNUM); - Pop_Primitive_Frame(2); - Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); - Store_Return(RC_RESTORE_INT_MASK); - Store_Expression(Make_Unsigned_Fixnum(IntEnb)); - Save_Cont(); - Push(Make_Unsigned_Fixnum(IntEnb)); /* Current interrupt mask */ - Push(Arg2); /* Function to call */ - Push(STACK_FRAME_HEADER+1); - Pushed(); - IntEnb = INT_Mask & Get_Integer(Arg1); - longjmp(*Back_To_Eval, PRIM_APPLY); - /*NOTREACHED*/ -} - -/* Called with a mask and a thunk */ - -Built_In_Primitive(Prim_With_Interrupts_Reduced, 2, - "WITH-INTERRUPTS-REDUCED", 0xC9) -{ - long new_interrupt_mask; - Primitive_2_Args(); - Arg_1_Type(TC_FIXNUM); - Pop_Primitive_Frame(2); - Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); - Store_Return(RC_RESTORE_INT_MASK); - Store_Expression(Make_Unsigned_Fixnum(IntEnb)); - Save_Cont(); - Push(Make_Unsigned_Fixnum(IntEnb)); /* Current interrupt mask */ - Push(Arg2); /* Function to call */ - Push(STACK_FRAME_HEADER+1); - Pushed(); - new_interrupt_mask = (INT_Mask & Get_Integer( Arg1)); - if (new_interrupt_mask > IntEnb) - IntEnb = new_interrupt_mask; - else - IntEnb = (new_interrupt_mask & IntEnb); - longjmp(*Back_To_Eval, PRIM_APPLY); - /*NOTREACHED*/ -} - -/* (WITHIN-CONTROL-POINT CONTROL-POINT THUNK) - THUNK must be a procedure or primitive procedure which takes no - arguments. Restores the state of the machine from the control - point, and then calls the THUNK in this new state. -*/ -Built_In_Primitive(Prim_Within_Control_Point, 2, - "WITHIN-CONTROL-POINT", 0xBF) -{ - Primitive_2_Args(); - - Arg_1_Type(TC_CONTROL_POINT); - Our_Throw(false, Arg1); - Within_Stacklet_Backout(); - Our_Throw_Part_2(); - Will_Push(STACK_ENV_EXTRA_SLOTS+1); - Push(Arg2); - Push(STACK_FRAME_HEADER); - Pushed(); - longjmp(*Back_To_Eval, PRIM_APPLY); - /*NOTREACHED*/ -} - -/* (WITH-THREADED-CONTINUATION PROCEDURE THUNK) - THUNK must be a procedure or primitive procedure which takes no - arguments. PROCEDURE must expect one argument. Basically this - primitive does (PROCEDURE (THUNK)) ... it calls the THUNK and - passes the result on as an argument to PROCEDURE. However, it - leaves a "well-known continuation code" on the stack for use by - the continuation parser in the Scheme runtime system. -*/ -Built_In_Primitive(Prim_With_Threaded_Stack, 2, - "WITH-THREADED-CONTINUATION", 0xBE) -{ - Primitive_2_Args(); - - Pop_Primitive_Frame(2); - Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+1)); - Store_Expression(Arg1); /* Save procedure to call later */ - Store_Return(RC_INVOKE_STACK_THREAD); - Save_Cont(); - Push(Arg2); /* Function to call now */ - Push(STACK_FRAME_HEADER); - Pushed(); - longjmp(*Back_To_Eval, PRIM_APPLY); - /*NOTREACHED*/ -} - diff --git a/v7/src/microcode/hunk.c b/v7/src/microcode/hunk.c deleted file mode 100644 index 9e36ceeee..000000000 --- a/v7/src/microcode/hunk.c +++ /dev/null @@ -1,168 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hunk.c,v 9.22 1987/04/16 02:24:07 jinx Rel $ - * - * Support for Hunk3s (triples) - */ - -#include "scheme.h" -#include "primitive.h" - -/* (HUNK3-CONS FIRST SECOND THIRD) - Returns a triple consisting of the specified values. -*/ -Built_In_Primitive(Prim_Hunk3_Cons, 3, "HUNK3-CONS", 0x28) -{ - Primitive_3_Args(); - - Primitive_GC_If_Needed(3); - *Free++ = Arg1; - *Free++ = Arg2; - *Free++ = Arg3; - return Make_Pointer(TC_HUNK3, Free-3); -} - -/* (HUNK3-CXR TRIPLE N) - Returns the Nth item from the TRIPLE. N must be 0, 1, or 2. -*/ -Built_In_Primitive(Prim_Hunk3_Cxr, 2, "HUNK3-CXR", 0x29) -{ - long Offset; - Primitive_2_Args(); - - Arg_1_Type(TC_HUNK3); - Arg_2_Type(TC_FIXNUM); - Range_Check(Offset, Arg2, 0, 2, ERR_ARG_2_BAD_RANGE); - return Vector_Ref(Arg1, Offset); -} - -/* (HUNK3-SET-CXR! TRIPLE N VALUE) - Stores VALUE in the Nth item of TRIPLE. N must be 0, 1, or 2. - Returns (not good style to count on this) the previous contents. -*/ -Built_In_Primitive(Prim_Hunk3_Set_Cxr, 3, "HUNK3-SET-CXR!", 0x2A) -{ - long Offset; - Primitive_3_Args(); - - Arg_1_Type(TC_HUNK3); - Arg_2_Type(TC_FIXNUM); - Range_Check(Offset, Arg2, 0, 2, ERR_ARG_2_BAD_RANGE); - Side_Effect_Impurify(Arg1, Arg3); - return Swap_Pointers(Nth_Vector_Loc(Arg1, Offset), Arg3); -} - -/* (SYSTEM-HUNK3-CXR0 GC-TRIPLE) - Returns item 0 (the first item) from any object with a GC type - of triple. For example, this would access the operator slot of - a COMBINATION_2_OPERAND SCode item. -*/ -Built_In_Primitive(Prim_Sys_H3_0, 1, "SYSTEM-HUNK3-CXR0", 0x8E) -{ - Primitive_1_Arg(); - - Arg_1_GC_Type(GC_Triple); - return Vector_Ref(Arg1, 0); -} - -/* (SYSTEM-HUNK3-CXR1 GC-TRIPLE) - Returns item 1 (the second item) from any object with a GC type - of triple. For example, this would access the first operand - slot of a COMBINATION_2_OPERAND SCode item. -*/ -Built_In_Primitive(Prim_Sys_H3_1, 1, "SYSTEM-HUNK3-CXR1", 0x91) -{ - Primitive_1_Arg(); - - Arg_1_GC_Type(GC_Triple); - return Vector_Ref(Arg1, 1); -} - -/* (SYSTEM-HUNK3-CXR2 GC-TRIPLE) - Returns item 2 (the third item) from any object with a GC type - of triple. For example, this would access the second operand - slot of a COMBINATION_2_OPERAND SCode item. -*/ -Built_In_Primitive(Prim_Sys_H3_2, 1, "SYSTEM-HUNK3-CXR2", 0x94) -{ - Primitive_1_Arg(); - - Arg_1_GC_Type(GC_Triple); - return Vector_Ref(Arg1, 2); -} - -/* (SYSTEM-HUNK3-SET-CXR0! GC-TRIPLE NEW-CONTENTS) - Replaces item 0 (the first item) in any object with a GC type of - triple with NEW-CONTENTS. For example, this would modify the - operator slot of a COMBINATION_2_OPERAND SCode item. Returns - (bad style to rely on this) the previous contents. -*/ -Built_In_Primitive(Prim_SH3_Set_0, 2, "SYSTEM-HUNK3-SET-CXR0!", 0x8F) -{ - Primitive_2_Args(); - Arg_1_GC_Type(GC_Triple); - - Side_Effect_Impurify(Arg1, Arg2); - return Swap_Pointers(Nth_Vector_Loc(Arg1, 0), Arg2); -} - -/* (SYSTEM-HUNK3-SET-CXR1! GC-TRIPLE NEW-CONTENTS) - Replaces item 1 (the second item) in any object with a GC type - of triple with NEW-CONTENTS. For example, this would modify the - first operand slot of a COMBINATION_2_OPERAND SCode item. - Returns (bad style to rely on this) the previous contents. -*/ -Built_In_Primitive(Prim_SH3_Set_1, 2, "SYSTEM-HUNK3-SET-CXR1!", 0x92) -{ - Primitive_2_Args(); - Arg_1_GC_Type(GC_Triple); - - Side_Effect_Impurify(Arg1, Arg2); - return Swap_Pointers(Nth_Vector_Loc(Arg1, 1), Arg2); -} - -/* (SYSTEM-HUNK3-SET-CXR2! GC-TRIPLE NEW-CONTENTS) - Replaces item 2 (the third item) in any object with a GC type of - triple with NEW-CONTENTS. For example, this would modify the - second operand slot of a COMBINATION_2_OPERAND SCode item. - Returns (bad style to rely on this) the previous contents. -*/ -Built_In_Primitive(Prim_SH3_Set_2, 2, "SYSTEM-HUNK3-SET-CXR2!", 0x95) -{ - Primitive_2_Args(); - Arg_1_GC_Type(GC_Triple); - - Side_Effect_Impurify(Arg1, Arg2); - return Swap_Pointers(Nth_Vector_Loc(Arg1, 2), Arg2); -} - diff --git a/v7/src/microcode/image.c b/v7/src/microcode/image.c deleted file mode 100644 index a68ca806c..000000000 --- a/v7/src/microcode/image.c +++ /dev/null @@ -1,1197 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/image.c,v 9.21 1987/01/22 14:27:21 jinx Rel $ */ - -#include "scheme.h" -#include "primitive.h" -#include "flonum.h" -#include "array.h" -#include - -/* IMAGE PROCESSING... */ -/* (much comes from array.c) */ - -Define_Primitive(Prim_Read_Image_From_Ascii_File, 1, "READ-IMAGE-FROM-ASCII-FILE") -{ long Length, int_pixel_value1, int_pixel_value2, i, j; - long nrows, ncols, array_index; - FILE *fopen(), *fp; - char *file_string; - REAL *To_Here; - REAL *From_Here_1, *From_Here_2; - Pointer Result, Array_Data_Result, *Orig_Free; - int Error_Number; - long allocated_cells; - Boolean Open_File(); - - Primitive_1_Args(); - Arg_1_Type(TC_CHARACTER_STRING); - - if (!(Open_File(Arg1, "r", &fp))) Primitive_Error(ERR_ARG_1_BAD_RANGE); - fscanf(fp, "%d %d \n", &nrows, &ncols); - if ((ncols > 512) || (nrows>512)) { - printf("read-image-ascii-file: ncols, nrows must be <= 512\n"); - return(NIL); - } - Length = nrows * ncols; - printf("nrows is %d \n", nrows); - printf("ncols is %d \n", ncols); - printf("Reading data file ...\n"); - - /* ALLOCATE SPACE */ - Primitive_GC_If_Needed(6); - Orig_Free = Free; - Free += 6; - Result = Make_Pointer(TC_LIST, Orig_Free); - *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nrows); - *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1); - Orig_Free++; - *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, ncols); - *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1); - Orig_Free++; - - /* Allocate_Array(Array_Data_Result, Length, allocated_cells); */ - allocated_cells = (Length*REAL_SIZE) + ARRAY_HEADER_SIZE; - Primitive_GC_If_Needed(allocated_cells); - Array_Data_Result = Make_Pointer(TC_ARRAY, Free); - Free[ARRAY_HEADER] = Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1); - Free[ARRAY_LENGTH] = Length; - Free = Free+allocated_cells; - - *Orig_Free++ = Array_Data_Result; - *Orig_Free = NIL; - /* END ALLOCATION */ - - To_Here = Scheme_Array_To_C_Array(Array_Data_Result); - - for (i=0; iArray[i*ncols+j] */ - }} - - return Result; -} - -Define_Primitive(Prim_Image_Double_To_Float, 1, "IMAGE-DOUBLE-TO-FLOAT!") -{ long Length; - long i,j; - long nrows, ncols; - long allocated_cells; - double *Array, *From_Here; - register double temp_value_cell; - float *To_Here; - int Error_Number; - Pointer Pnrows,Pncols,Parray,Prest; - - Primitive_1_Args(); - Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */ - Pnrows = Vector_Ref(Arg1, CONS_CAR); - Prest = Vector_Ref(Arg1, CONS_CDR); - Pncols = Vector_Ref(Prest, CONS_CAR); - Prest = Vector_Ref(Prest, CONS_CDR); - Parray = Vector_Ref(Prest, CONS_CAR); - if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE); - if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE); - - Range_Check(nrows, Pnrows, 0, 2048, ERR_ARG_1_BAD_RANGE); - Range_Check(ncols, Pncols, 0, 2048, ERR_ARG_1_BAD_RANGE); - - Array = ((double *) (Nth_Vector_Loc(Parray, ARRAY_DATA))); - From_Here = Array; - To_Here = ((float *) (Array)); - Length = nrows * ncols; - - for (i=0;incols) Primitive_Error(ERR_ARG_3_BAD_RANGE); - - Array = Scheme_Array_To_C_Array(Parray); - C_Image_Set_Row(Array, row_to_set, Row_Array, nrows, ncols); - return Arg1; -} - -Define_Primitive(Prim_Image_Set_Column, 3, "IMAGE-SET-COLUMN!") -{ long Length, i,j; - Pointer Pnrows, Pncols, Prest, Parray; - long nrows, ncols, col_to_set; - REAL *Array, *Col_Array; - - Primitive_3_Args(); - Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */ - Pnrows = Vector_Ref(Arg1, CONS_CAR); - Prest = Vector_Ref(Arg1, CONS_CDR); - Pncols = Vector_Ref(Prest, CONS_CAR); - Prest = Vector_Ref(Prest, CONS_CDR); - Parray = Vector_Ref(Prest, CONS_CAR); - if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE); - if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE); - - Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE); - Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE); - - Arg_2_Type(TC_FIXNUM); - Range_Check(col_to_set, Arg2, 0, (nrows-1), ERR_ARG_2_BAD_RANGE); - Arg_3_Type(TC_ARRAY); - Col_Array = Scheme_Array_To_C_Array(Arg3); - if (Array_Length(Arg3)>ncols) Primitive_Error(ERR_ARG_3_BAD_RANGE); - - Array = Scheme_Array_To_C_Array(Parray); - C_Image_Set_Col(Array, col_to_set, Col_Array, nrows, ncols); - return Arg1; -} - -C_Image_Set_Row(Image_Array, row_to_set, Row_Array, nrows, ncols) REAL *Image_Array, *Row_Array; -long nrows, ncols, row_to_set; -{ long j; - REAL *From_Here, *To_Here; - - To_Here = &Image_Array[row_to_set*ncols]; - From_Here = Row_Array; - for (j=0;jSquare_HC)) - Ring_Array[i*ncols+j] = 0; - else Ring_Array[i*ncols+j] = 1; - }} -} - - -/* DONE WITHOUT SIDE-EFFECTS FOR SIMPLICITY */ -Define_Primitive(Prim_Image_Periodic_Shift, 3, "IMAGE-PERIODIC-SHIFT") -{ long Length, i,j; - Pointer Pnrows, Pncols, Prest, Parray; - long nrows, ncols; - long hor_shift, ver_shift; - REAL *Array, *New_Array; - Pointer Result, Array_Data_Result, *Orig_Free; - long allocated_cells; - - Primitive_3_Args(); - Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */ - Pnrows = Vector_Ref(Arg1, CONS_CAR); - Prest = Vector_Ref(Arg1, CONS_CDR); - Pncols = Vector_Ref(Prest, CONS_CAR); - Prest = Vector_Ref(Prest, CONS_CDR); - Parray = Vector_Ref(Prest, CONS_CAR); - if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE); - if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE); - - Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE); - Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE); - Length = nrows*ncols; - - Arg_2_Type(TC_FIXNUM); - Sign_Extend(Arg2, ver_shift); - ver_shift = ver_shift % nrows; - Arg_3_Type(TC_FIXNUM); - Sign_Extend(Arg3, hor_shift); - hor_shift = hor_shift % ncols; - - /* ALLOCATE SPACE */ - Primitive_GC_If_Needed(6); - Orig_Free = Free; - Free += 6; - Result = Make_Pointer(TC_LIST, Orig_Free); - *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nrows); - *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1); - Orig_Free++; - *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, ncols); - *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1); - Orig_Free++; - Allocate_Array(Array_Data_Result, Length, allocated_cells); - *Orig_Free++ = Array_Data_Result; - *Orig_Free = NIL; - /* END ALLOCATION */ - - Array = Scheme_Array_To_C_Array(Parray); - New_Array = Scheme_Array_To_C_Array(Array_Data_Result); - C_Image_Periodic_Shift(Array, New_Array, nrows, ncols, ver_shift, hor_shift); - return Result; -} - -/* ASSUMES hor_shift A(j,i) . - UNWRAP: A(i,j) ----> Array[i*ncols + j] convention:= fix row & go by columns . - UNWRAP is a bijection from the compact plane to the compact interval. - */ -Image_Fast_Transpose(Array, nrows) /* for square images */ - REAL *Array; long nrows; -{ long i, j; - long from, to; - REAL temp; - for (i=0;i B(j,i) . - UNWRAP: A(i,j) ----> Array[i*ncols + j] convention:= fix row & go by columns . - UNWRAP is a bijection from the compact plane to the compact interval. - */ -Image_Transpose(Array, New_Array, nrows, ncols) - REAL *Array, *New_Array; long nrows, ncols; -{ long i, j; - for (i=0;i A(j, (nrows-1)-i) . - UNWRAP: A(i,j) ----> Array[i*ncols + j] convention:= fix row & go by columns - UNWRAP is a bijection from the compact plane to the compact interval. - */ -Image_Rotate_90clw(Array, Rotated_Array, nrows, ncols) - REAL *Array, *Rotated_Array; long nrows, ncols; -{ long i, j; - - for (i=0;i A((nrows-1)-j, i) . (minus 1 because we start from 0). - UNWRAP: A(i,j) ----> Array[i*ncols + j] because of convention:= fix row & go by columns - UNWRAP is a bijection from the compact plane to the compact interval. - */ -Image_Rotate_90cclw(Array, Rotated_Array, nrows, ncols) - REAL *Array, *Rotated_Array; long nrows, ncols; -{ long i, j; - register long from_index, to_index; - long Length=nrows*ncols; - for (i=0;i A(i, (ncols-1)-j) [ The -1 is there because we count from 0] . - A(i,j) -------> Array[i*ncols + j] fix row, read column convention. - */ -C_Mirror_Image(Array, nrows, ncols) REAL *Array; long nrows, ncols; -{ long i, j; - long ncols2=ncols/2, Length=nrows*ncols; - REAL temp; - long from, to; - - for (i=0; i A(j, i) this should be identical to image_transpose (see above). - UNWRAP: A(i,j) ----> Array[i*ncols + j] because of convention:= fix row & go by columns - UNWRAP is a bijection from the compact plane to the compact interval. - */ -C_Rotate_90clw_Mirror_Image(Array, Rotated_Array, nrows, ncols) - REAL *Array, *Rotated_Array; long nrows, ncols; -{ long i, j; - long from, to, Length=nrows*ncols; - - for (i=0;i0.0)) return(.08 + .46 * (1 - t_bar)); - else return (0); -} - -REAL hanning(t, length) REAL t, length; -{ REAL twopi = 6.28318530717958; - REAL pi = twopi/2.; - REAL t_bar = cos(twopi * (t / length)); - if ((t0.0)) - return(.5 * (1 - t_bar)); - else return (0); -} - -REAL unit_square_wave(t) REAL t; -{ REAL twopi = 6.28318530717958; - REAL fmod(), fabs(); - REAL pi = twopi/2.; - REAL t_bar = fabs(fmod(t, twopi)); - if (t_bar < pi) return(1); - else return(0); -} - -REAL unit_triangle_wave(t) REAL t; -{ REAL twopi = 6.28318530717958; - REAL pi = twopi/2.; - REAL t_bar = fabs(fmod(t, twopi)); - if (t_bar < pi) return( t_bar / pi ); - else return( (twopi - t_bar) / pi ); -} - -Define_Primitive(Prim_Sample_Aperiodic_Function, 3, "SAMPLE-APERIODIC-FUNCTION") -{ long N, i, allocated_cells, Function_Number; - REAL Sampling_Frequency, DT, DTi; - REAL twopi = 6.28318530717958; - Pointer Result; - int Error_Number; - REAL *To_Here, twopi_dt; - - Primitive_3_Args(); - Arg_1_Type(TC_FIXNUM); - Arg_3_Type(TC_FIXNUM); - Range_Check(Function_Number, Arg1, 0, 6, ERR_ARG_1_BAD_RANGE); - - Error_Number = Scheme_Number_To_REAL(Arg2, &Sampling_Frequency); - if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE); - if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE); - if (Sampling_Frequency == 0) Primitive_Error(ERR_ARG_2_BAD_RANGE); - DT = (1 / Sampling_Frequency); - twopi_dt = twopi * DT; - - Range_Check(N, Arg3, 0, ARRAY_MAX_LENGTH, ERR_ARG_3_BAD_RANGE); - - allocated_cells = (N*REAL_SIZE) + ARRAY_HEADER_SIZE; - Primitive_GC_If_Needed(allocated_cells); - - Result = Make_Pointer(TC_ARRAY, Free); - Free[ARRAY_HEADER] = Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1); - Free[ARRAY_LENGTH] = N; - To_Here = Scheme_Array_To_C_Array(Result); - Free = Free+allocated_cells; - - DT = twopi_dt; - if (Function_Number == 0) - for (i=0, DTi=0.0; i < N; i++, DTi += DT) - *To_Here++ = rand(); - else if (Function_Number == 1) - { REAL length=DT*N; - for (i=0, DTi=0.0; i < N; i++, DTi += DT) - *To_Here++ = hanning(DTi, length); - } - else if (Function_Number == 2) - { REAL length=DT*N; - for (i=0, DTi=0.0; i < N; i++, DTi += DT) - *To_Here++ = hamming(DTi, length); - } - else if (Function_Number == 3) - for (i=0, DTi=0.0; i < N; i++, DTi += DT) - *To_Here++ = sqrt(DTi); - else if (Function_Number == 4) - for (i=0, DTi=0.0; i < N; i++, DTi += DT) - *To_Here++ = log(DTi); - else if (Function_Number == 5) - for (i=0, DTi=0.0; i < N; i++, DTi += DT) - *To_Here++ = exp(DTi); - else - Primitive_Error(ERR_ARG_1_BAD_RANGE); - - return Result; -} - -Define_Primitive(Prim_Array_Periodic_Downsample, 2, "ARRAY-PERIODIC-DOWNSAMPLE") -{ long Length, Pseudo_Length, Sampling_Ratio; - REAL *Array, *To_Here; - Pointer Result; - long allocated_cells, i, array_index; - - Primitive_2_Args(); - Arg_1_Type(TC_ARRAY); - Arg_2_Type(TC_FIXNUM); - Length = Array_Length(Arg1); - - Sign_Extend(Arg2, Sampling_Ratio); / * Sampling_Ratio = integer ratio of sampling_frequencies * / - Sampling_Ratio = Sampling_Ratio % Length; / * periodicity * / - if (Sampling_Ratio < 1) Primitive_Error(ERR_ARG_2_BAD_RANGE); - - Array = Scheme_Array_To_C_Array(Arg1); - Allocate_Array(Result, Length, allocated_cells); - To_Here = Scheme_Array_To_C_Array(Result); - - Pseudo_Length = Length * Sampling_Ratio; - for (i=0; i= MemTop) return TRUTH; - else return NIL; -} - -Define_Primitive(Prim_Slave_Before, 0, "SLAVE-GC-BEFORE-SYNC") -{ - Primitive_0_Args(); - - return TRUTH; -} - -Define_Primitive(Prim_Slave_After, 0, "SLAVE-GC-AFTER-SYNC") -{ - Primitive_0_Args(); - - return TRUTH; -} - -Define_Primitive(Prim_Master_Before, 0, "MASTER-GC-BEFORE-SYNC") -{ - Primitive_0_Args(); - - return TRUTH; -} - -/* This primitive caches the Scheme object for the garbage collector - primitive so that it does not have to perform an expensive search - each time. -*/ - -Define_Primitive(Prim_Master_GC, 1, "MASTER-GC-LOOP") -{ - static Pointer gc_prim = NIL; - extern Pointer make_primitive(); - Primitive_1_Arg(); - - if (gc_prim == NIL) - { - gc_prim = make_primitive("GARBAGE-COLLECT"); - } - Pop_Primitive_Frame(1); - Will_Push(STACK_ENV_EXTRA_SLOTS + 2); - Push(Arg1); - Push(gc_prim); - Push(STACK_FRAME_HEADER + 1); - Pushed(); - longjmp(*Back_To_Eval, PRIM_APPLY); -} diff --git a/v7/src/microcode/intern.c b/v7/src/microcode/intern.c deleted file mode 100644 index 331bd642a..000000000 --- a/v7/src/microcode/intern.c +++ /dev/null @@ -1,283 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/intern.c,v 9.39 1987/04/16 02:01:51 jinx Exp $ - - Utilities for manipulating symbols. - */ - -#include "scheme.h" -#include "primitive.h" -#include "trap.h" - -/* Hashing strings and character lists. */ - -long -Do_Hash(String_Ptr, String_Length) - char *String_Ptr; - long String_Length; -{ - long i, Value, End_Count; - - Value = (LENGTH_MULTIPLIER * String_Length); - End_Count = ((String_Length > MAX_HASH_CHARS) ? - MAX_HASH_CHARS : - String_Length); - for (i = 0; i < End_Count; i++) - Value = ((Value << SHIFT_AMOUNT) + (MAX_CHAR & String_Ptr[i])); - return Value; -} - -Pointer Hash(Ptr) - Pointer Ptr; -{ - long String_Length; - - String_Length = Get_Integer(Fast_Vector_Ref(Ptr, STRING_LENGTH)); - return Make_Non_Pointer(TC_FIXNUM, - Do_Hash(Scheme_String_To_C_String(Ptr), - String_Length)); -} - -Boolean -string_equal(String1, String2) - Pointer String1, String2; -{ - fast char *S1, *S2; - fast long i, Length1, Length2; - - if (Address(String1) == Address(String2)) - return true; - Length1 = Get_Integer(Fast_Vector_Ref(String1, STRING_LENGTH)); - Length2 = Get_Integer(Fast_Vector_Ref(String2, STRING_LENGTH)); - if (Length1 != Length2) - return false; - - S1 = ((char *) Nth_Vector_Loc(String1, STRING_CHARS)); - S2 = ((char *) Nth_Vector_Loc(String2, STRING_CHARS)); - for (i = 0; i < Length1; i++) - if (*S1++ != *S2++) - return false; - return true; -} - -/* Interning involves hashing the input string and either returning - an existing symbol with that name from the ObArray or creating a - new symbol and installing it in the ObArray. The resulting interned - symbol is stored in *Un_Interned. -*/ - -extern void Intern(); - -void -Intern(Un_Interned) - Pointer *Un_Interned; -{ - long Hashed_Value; - Pointer Ob_Array, *Bucket, String, Temp; - - String = Fast_Vector_Ref(*Un_Interned, SYMBOL_NAME); - Temp = Hash(String); - Hashed_Value = Get_Integer(Temp); - Ob_Array = Get_Fixed_Obj_Slot(OBArray); - Hashed_Value %= Vector_Length(Ob_Array); - Bucket = Nth_Vector_Loc(Ob_Array, Hashed_Value + 1); - - while (*Bucket != NIL) - { - if (string_equal(String, - Fast_Vector_Ref( - Vector_Ref(*Bucket, CONS_CAR), - SYMBOL_NAME))) - { - *Un_Interned = Vector_Ref(*Bucket, CONS_CAR); - return; - } - Bucket = Nth_Vector_Loc(*Bucket, CONS_CDR); - } - -/* Symbol does not exist yet in obarray. Bucket points to the - cell containing the final #!NULL in the list. Replace this - with the CONS of the new symbol and #!NULL (i.e. extend the - list in the bucket by 1 new element). -*/ - - Store_Type_Code(*Un_Interned, TC_INTERNED_SYMBOL); - *Bucket = Make_Pointer(TC_LIST, Free); - Free[CONS_CAR] = *Un_Interned; - Free[CONS_CDR] = NIL; - Free += 2; - return; -} - -Pointer -string_to_symbol(String) - Pointer String; -{ - Pointer New_Symbol, Interned_Symbol, *Orig_Free; - - Orig_Free = Free; - New_Symbol = Make_Pointer(TC_UNINTERNED_SYMBOL, Free); - Free[SYMBOL_NAME] = String; - Free[SYMBOL_GLOBAL_VALUE] = UNBOUND_OBJECT; - Free += 2; - Interned_Symbol = New_Symbol; - - /* The work is done by Intern which returns in Interned_Symbol - either the same symbol we gave it (in which case we need to check - for GC) or an existing symbol (in which case we have to release - the heap space acquired to hold New_Symbol). - */ - - Intern(&Interned_Symbol); - if (Address(Interned_Symbol) == Address(New_Symbol)) - { - Primitive_GC_If_Needed(0); - } - else - Free = Orig_Free; - return Interned_Symbol; -} - -/* For debugging, given a String, return either a "not interned" - * message or the address of the symbol and its global value. - */ - -void -Find_Symbol(Scheme_String) - Pointer Scheme_String; -{ - Pointer Ob_Array, The_Symbol, *Bucket; - char *String, *Temp_String; - long i, Hashed_Value; - - String = Scheme_String_To_C_String(Scheme_String); - for (Temp_String = String, i = 0; *Temp_String == '\0'; i++) - Temp_String++; - Hashed_Value = Do_Hash(String, i); - Ob_Array = Get_Fixed_Obj_Slot(OBArray); - Hashed_Value %= Vector_Length(Ob_Array); - Bucket = Nth_Vector_Loc(Ob_Array, Hashed_Value); - while (*Bucket != NIL) - { - if (string_equal(Scheme_String, - Vector_Ref(Vector_Ref(*Bucket, CONS_CAR), - SYMBOL_NAME))) - { - The_Symbol = Vector_Ref(*Bucket, CONS_CAR); - printf("\nInterned Symbol: 0x%x", The_Symbol); - Print_Expression(Vector_Ref(The_Symbol, SYMBOL_GLOBAL_VALUE), - "Value"); - printf("\n"); - return; - } - Bucket = Nth_Vector_Loc(*Bucket, CONS_CDR); - } - printf("\nNot interned.\n"); -} - -/* (STRING->SYMBOL STRING) - Similar to INTERN-CHARACTER-LIST, except this one takes a string - instead of a list of ascii values as argument. - */ -Built_In_Primitive(Prim_String_To_Symbol, 1, "STRING->SYMBOL", 0x7) -{ - Primitive_1_Arg(); - - Arg_1_Type(TC_CHARACTER_STRING); - return string_to_symbol(Arg1); -} - -/* (INTERN-CHARACTER-LIST LIST) - LIST should consist of the ASCII codes for characters. Returns - a new (interned) symbol made out of these characters. Notice - that this is a fairly low-level primitive, and no checking is - done on the characters except that they are in the range 0 to - 255. Thus non-printing, lower-case, and special characters can - be put into symbols this way. -*/ - -Built_In_Primitive(Prim_Intern_Character_List, 1, - "INTERN-CHARACTER-LIST", 0xAB) -{ - extern Pointer list_to_string(); - Primitive_1_Arg(); - - return string_to_symbol(list_to_string(Arg1)); -} - -/* (STRING-HASH STRING) - Return a hash value for a string. This uses the hashing - algorithm used for interning symbols. It is intended for use by - the reader in creating interned symbols. -*/ -Built_In_Primitive(Prim_String_Hash, 1, "STRING-HASH", 0x83) -{ - Primitive_1_Arg(); - - Arg_1_Type(TC_CHARACTER_STRING); - return Hash(Arg1); -} - -/* (CHARACTER-LIST-HASH LIST) - Takes a list of ASCII codes for characters and returns a hash - code for them. This uses the hashing function used to intern - symbols in Fasload, and is really intended only for that - purpose. -*/ -Built_In_Primitive(Prim_Character_List_Hash, 1, - "CHARACTER-LIST-HASH", 0x65) -{ - long Length; - Pointer This_Char; - char String[MAX_HASH_CHARS]; - Primitive_1_Arg(); - - Touch_In_Primitive(Arg1, Arg1); - for (Length = 0; Type_Code(Arg1) == TC_LIST; Length++) - { - if (Length < MAX_HASH_CHARS) - { - Touch_In_Primitive(Vector_Ref(Arg1, CONS_CAR), This_Char); - if (Type_Code(This_Char) != TC_CHARACTER) - Primitive_Error(ERR_ARG_1_WRONG_TYPE); - Range_Check(String[Length], This_Char, - '\0', ((char) MAX_CHAR), - ERR_ARG_1_WRONG_TYPE); - Touch_In_Primitive(Vector_Ref(Arg1, CONS_CDR), Arg1); - } - } - if (Arg1 != NIL) - Primitive_Error(ERR_ARG_1_WRONG_TYPE); - return - Make_Non_Pointer(TC_FIXNUM, Do_Hash(String, Length)); -} diff --git a/v7/src/microcode/interp.c b/v7/src/microcode/interp.c deleted file mode 100644 index ec85344d7..000000000 --- a/v7/src/microcode/interp.c +++ /dev/null @@ -1,1780 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.23 1987/04/16 02:24:28 jinx Exp $ - * - * This file contains the heart of the Scheme Scode - * interpreter - * - */ - -#define In_Main_Interpreter true -#include "scheme.h" -#include "locks.h" -#include "trap.h" -#include "lookup.h" -#include "zones.h" - -/* In order to make the interpreter tail recursive (i.e. - * to avoid calling procedures and thus saving unnecessary - * state information), the main body of the interpreter - * is coded in a continuation passing style. - * - * Basically, this is done by dispatching on the type code - * for an Scode item. At each dispatch, some processing - * is done which may include setting the return address - * register, saving the current continuation (return address - * and current expression) and jumping to the start of - * the interpreter. - * - * It may be helpful to think of this program as being what - * you would get if you wrote the straightforward Scheme - * interpreter and then converted it into continuation - * passing style as follows. At every point where you would - * call EVAL to handle a sub-form, you put a jump back to - * Do_Expression. Now, if there was code after the call to - * EVAL you first push a "return code" (using Save_Cont) on - * the stack and move the code that used to be after the - * call down into the part of this file after the tag - * Pop_Return. - * - * Notice that because of the caller saves convention used - * here, all of the registers which are of interest have - * been SAVEd on the racks by the time interpretation arrives - * at Do_Expression (the top of EVAL). - * - * For notes on error handling and interrupts, see the file - * utils.c. - * - * This file is divided into two parts. The first - * corresponds is called the EVAL dispatch, and is ordered - * alphabetically by the SCode item handled. The second, - * called the return dispatch, begins at Pop_Return and is - * ordered alphabetically by return code name. - */ - -#define Interrupt(Masked_Code) \ -{ \ - Export_Registers(); \ - Setup_Interrupt(Masked_Code); \ - Import_Registers(); \ - goto Perform_Application; \ -} - -#define Immediate_GC(N) \ -{ \ - Request_GC(N); \ - Interrupt(IntCode & IntEnb); \ -} - -#define Prepare_Eval_Repeat() \ -{ \ - Will_Push(CONTINUATION_SIZE+1); \ - Push(Fetch_Env()); \ - Store_Return(RC_EVAL_ERROR); \ - Save_Cont(); \ - Pushed(); \ -} - -#define Eval_GC_Check(Amount) \ -if (GC_Check(Amount)) \ -{ \ - Prepare_Eval_Repeat(); \ - Immediate_GC(Amount); \ -} - -#define Eval_Error(Err) \ -{ \ - Export_Registers(); \ - Do_Micro_Error(Err, false); \ - Import_Registers(); \ - goto Internal_Apply; \ -} - -#define Pop_Return_Error(Err) \ -{ \ - Export_Registers(); \ - Do_Micro_Error(Err, true); \ - Import_Registers(); \ - goto Internal_Apply; \ -} - -#define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val) \ -{ \ - Store_Return(Return_Code); \ - Save_Cont(); \ - Store_Return(RC_RESTORE_VALUE); \ - Store_Expression(Contents_of_Val); \ - Save_Cont(); \ -} - -#define Reduces_To(Expr) \ - { Store_Expression(Expr); \ - New_Reduction(Fetch_Expression(), Fetch_Env()); \ - goto Do_Expression; \ - } - -#define Reduces_To_Nth(N) \ - Reduces_To(Fast_Vector_Ref(Fetch_Expression(), (N))) - -#define Do_Nth_Then(Return_Code, N, Extra) \ - { Store_Return(Return_Code); \ - Save_Cont(); \ - Store_Expression(Fast_Vector_Ref(Fetch_Expression(), (N))); \ - New_Subproblem(Fetch_Expression(), Fetch_Env()); \ - Extra; \ - goto Do_Expression; \ - } - -#define Do_Another_Then(Return_Code, N) \ - { Store_Return(Return_Code); \ - Save_Cont(); \ - Store_Expression(Fast_Vector_Ref(Fetch_Expression(), (N))); \ - Reuse_Subproblem(Fetch_Expression(), Fetch_Env()); \ - goto Do_Expression; \ - } - -#define Environment_P(Obj) (Obj == NIL || (Type_Code(Obj) == TC_ENVIRONMENT)) - -#define MAGIC_RESERVE_SIZE 6 /* See SPMD.SCM */ -#define Reserve_Stack_Space() Will_Eventually_Push(MAGIC_RESERVE_SIZE) - - /***********************/ - /* Macros for Stepping */ - /***********************/ - -#define Fetch_Trapper(field) \ - Vector_Ref(Get_Fixed_Obj_Slot(Stepper_State), (field)) - -#define Fetch_Eval_Trapper() Fetch_Trapper(HUNK_CXR0) -#define Fetch_Apply_Trapper() Fetch_Trapper(HUNK_CXR1) -#define Fetch_Return_Trapper() Fetch_Trapper(HUNK_CXR2) - -/* Macros for handling FUTUREs */ - -#ifdef COMPILE_FUTURES - -/* Arg_Type_Error handles the error returns from primitives which type check - their arguments and restarts them or suspends if the argument is a future. */ - -#define Arg_Type_Error(Arg_No, Err_No) \ -{ \ - fast Pointer *Arg, Orig_Arg; \ - \ - Arg = &(Stack_Ref(Arg_No-1)); \ - Orig_Arg = *Arg; \ - \ - if (Type_Code(*Arg) != TC_FUTURE) \ - Pop_Return_Error(Err_No); \ - \ - while ((Type_Code(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \ - { \ - if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \ - *Arg = Future_Value(*Arg); \ - } \ - if (Type_Code(*Arg) != TC_FUTURE) \ - goto Prim_No_Trap_Apply; \ - \ - Save_Cont(); \ - Will_Push(STACK_ENV_EXTRA_SLOTS+2); \ - Push(*Arg); /* Arg 1: The future itself */ \ - Push(Get_Fixed_Obj_Slot(System_Scheduler)); \ - Push(STACK_FRAME_HEADER+1); \ - Pushed(); \ - *Arg = Orig_Arg; \ - goto Apply_Non_Trapping; \ -} - -/* Apply_Future_Check is called at apply time to guarantee that certain - objects (the procedure itself, and its LAMBDA components for user defined - procedures) are not futures -*/ - -#define Apply_Future_Check(Name, Object) \ -{ \ - fast Pointer *Arg, Orig_Answer; \ - \ - Arg = &(Object); \ - Orig_Answer = *Arg; \ - \ - while (Type_Code(*Arg) == TC_FUTURE) \ - { \ - if (Future_Has_Value(*Arg)) \ - { \ - if (Future_Is_Keep_Slot(*Arg)) \ - Log_Touch_Of_Future(*Arg); \ - *Arg = Future_Value(*Arg); \ - } \ - else \ - { \ - Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \ - Store_Return(RC_INTERNAL_APPLY); \ - Val = NIL; \ - Save_Cont(); \ - Push(*Arg); \ - Push(Get_Fixed_Obj_Slot(System_Scheduler)); \ - Push(STACK_FRAME_HEADER+1); \ - Pushed(); \ - *Arg = Orig_Answer; \ - goto Internal_Apply; \ - } \ - } \ - Name = *Arg; \ -} - -/* Future handling macros continue on the next page */ - -/* Future handling macros, continued */ - -/* Pop_Return_Val_Check suspends the process if the value calculated by - a recursive call to EVAL is an undetermined future */ - -#define Pop_Return_Val_Check() \ -{ \ - fast Pointer Orig_Val = Val; \ - \ - while (Type_Code(Val) == TC_FUTURE) \ - { \ - if (Future_Has_Value(Val)) \ - { \ - if (Future_Is_Keep_Slot(Val)) \ - Log_Touch_Of_Future(Val); \ - Val = Future_Value(Val); \ - } \ - else \ - { \ - Save_Cont(); \ - Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \ - Store_Return(RC_RESTORE_VALUE); \ - Store_Expression(Orig_Val); \ - Save_Cont(); \ - Push(Val); \ - Push(Get_Fixed_Obj_Slot(System_Scheduler)); \ - Push(STACK_FRAME_HEADER+1); \ - Pushed(); \ - goto Internal_Apply; \ - } \ - } \ -} - -#else /* Not compiling FUTURES code */ - -#define Pop_Return_Val_Check() -#define Apply_Future_Check(Name, Object) Name = (Object) -#define Arg_Type_Error(Arg_No, Err_No) Pop_Return_Error(Err_No) - -#endif - -/* The EVAL/APPLY ying/yang */ - -void -Interpret(dumped_p) - Boolean dumped_p; -{ - long Which_Way; - fast Pointer *Reg_Block, *Reg_Stack_Pointer, *Reg_History; - - extern long enter_compiled_expression(); - extern long apply_compiled_procedure(); - extern long return_to_compiled_code(); - - Reg_Block = &Registers[0]; - - /* Primitives jump back here for errors, requests to - * evaluate an expression, apply a function, or handle an - * interrupt request. On errors or interrupts they leave - * their arguments on the stack, the primitive itself in - * Expression, and a RESTART_PRIMITIVE continuation in the - * return register. In the other cases, they have removed - * their stack frames entirely. - */ - - Which_Way = setjmp(*Back_To_Eval); - Set_Time_Zone(Zone_Working); - Import_Registers(); - if (Must_Report_References()) - { Save_Cont(); - Will_Push(CONTINUATION_SIZE + 2); - Push(Val); - Save_Env(); - Store_Return(RC_REPEAT_DISPATCH); - Store_Expression(Make_Non_Pointer(TC_FIXNUM, Which_Way)); - Save_Cont(); - Pushed(); - Call_Future_Logging(); - } - -Repeat_Dispatch: - switch (Which_Way) - { case PRIM_APPLY: goto Internal_Apply; - case PRIM_NO_TRAP_APPLY: goto Apply_Non_Trapping; - case PRIM_DO_EXPRESSION: Reduces_To(Fetch_Expression()); - case PRIM_NO_TRAP_EVAL: New_Reduction(Fetch_Expression(),Fetch_Env()); - goto Eval_Non_Trapping; - case 0: if (!dumped_p) break; /* Else fall through */ - case PRIM_POP_RETURN: goto Pop_Return; - default: Pop_Return_Error(Which_Way); - case PRIM_INTERRUPT: - { Save_Cont(); - Interrupt(IntCode & IntEnb); - } - case ERR_ARG_1_WRONG_TYPE: Arg_Type_Error(1, ERR_ARG_1_WRONG_TYPE); - case ERR_ARG_2_WRONG_TYPE: Arg_Type_Error(2, ERR_ARG_2_WRONG_TYPE); - case ERR_ARG_3_WRONG_TYPE: Arg_Type_Error(3, ERR_ARG_3_WRONG_TYPE); - } - -Do_Expression: - - if (Eval_Debug) - { Print_Expression(Fetch_Expression(), "Eval, expression"); - CRLF(); - } - -/* The expression register has an Scode item in it which - * should be evaluated and the result left in Val. - * - * A "break" after the code for any operation indicates that - * all processing for this operation has been completed, and - * the next step will be to pop a return code off the stack - * and proceed at Pop_Return. This is sometimes called - * "executing the continuation" since the return code can be - * considered the continuation to be performed after the - * operation. - * - * An operation can terminate with a Reduces_To or - * Reduces_To_Nth macro. This indicates that the value of - * the current Scode item is the value returned when the - * new expression is evaluated. Therefore no new - * continuation is created and processing continues at - * Do_Expression with the new expression in the expression - * register. - * - * Finally, an operation can terminate with a Do_Nth_Then - * macro. This indicates that another expression must be - * evaluated and them some additional processing will be - * performed before the value of this S-Code item available. - * Thus a new continuation is created and placed on the - * stack (using Save_Cont), the new expression is placed in - * the Expression register, and processing continues at - * Do_Expression. - */ - -/* Handling of Eval Trapping. - - If we are handling traps and there is an Eval Trap set, - turn off all trapping and then go to Internal_Apply to call the - user supplied eval hook with the expression to be evaluated and the - environment. - -*/ - - if (Microcode_Does_Stepping && Trapping && (Fetch_Eval_Trapper() != NIL)) - { Stop_Trapping(); - Will_Push(4); - Push(Fetch_Env()); - Push(Fetch_Expression()); - Push(Fetch_Eval_Trapper()); - Push(STACK_FRAME_HEADER+2); - Pushed(); - goto Apply_Non_Trapping; - } - -Eval_Non_Trapping: - Eval_Ucode_Hook(); - switch (Type_Code(Fetch_Expression())) - { case TC_BIG_FIXNUM: /* The self evaluating items */ - case TC_BIG_FLONUM: - case TC_CHARACTER_STRING: - case TC_CHARACTER: - case TC_COMPILED_PROCEDURE: - case TC_COMPLEX: - case TC_CONTROL_POINT: - case TC_DELAYED: - case TC_ENVIRONMENT: - case TC_EXTENDED_PROCEDURE: - case TC_FIXNUM: - case TC_HUNK3: - case TC_INTERNED_SYMBOL: - case TC_LIST: - case TC_NON_MARKED_VECTOR: - case TC_NULL: - case TC_PRIMITIVE: - case TC_PRIMITIVE_EXTERNAL: - case TC_PROCEDURE: - case TC_QUAD: - case TC_UNINTERNED_SYMBOL: - case TC_TRUE: - case TC_VECTOR: - case TC_VECTOR_16B: - case TC_VECTOR_1B: - case TC_REFERENCE_TRAP: - Val = Fetch_Expression(); break; - - case TC_ACCESS: - Will_Push(CONTINUATION_SIZE); - Do_Nth_Then(RC_EXECUTE_ACCESS_FINISH, ACCESS_ENVIRONMENT, Pushed()); - - case TC_ASSIGNMENT: - Will_Push(CONTINUATION_SIZE + 1); - Save_Env(); - Do_Nth_Then(RC_EXECUTE_ASSIGNMENT_FINISH, ASSIGN_VALUE, Pushed()); - - case TC_BROKEN_HEART: - Export_Registers(); - Microcode_Termination(TERM_BROKEN_HEART); - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_COMBINATION: - { long Array_Length = Vector_Length(Fetch_Expression())-1; - Eval_GC_Check(New_Stacklet_Size(Array_Length+1+1+CONTINUATION_SIZE)); - Will_Push(Array_Length + 1+1+CONTINUATION_SIZE); /* Save_Env, Finger */ - Stack_Pointer = Simulate_Pushing(Array_Length); - Push(Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Array_Length)); - /* The finger: last argument number */ - Pushed(); - if (Array_Length == 0) - { Push(STACK_FRAME_HEADER); /* Frame size */ - Do_Nth_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT, {}); - } - Save_Env(); - Do_Nth_Then(RC_COMB_SAVE_VALUE, Array_Length+1, {}); - } - - case TC_COMBINATION_1: - Reserve_Stack_Space(); /* STACK_ENV_EXTRA_SLOTS+2+CONTINUATION_SIZE */ - Save_Env(); - Do_Nth_Then(RC_COMB_1_PROCEDURE, COMB_1_ARG_1, {}); - - case TC_COMBINATION_2: - Reserve_Stack_Space(); /* STACK_ENV_EXTRA_SLOTS+3+CONTINUATION_SIZE */ - Save_Env(); - Do_Nth_Then(RC_COMB_2_FIRST_OPERAND, COMB_2_ARG_2, {}); - - case TC_COMMENT: - Reduces_To_Nth(COMMENT_EXPRESSION); - - case TC_CONDITIONAL: - Will_Push(CONTINUATION_SIZE + 1); - Save_Env(); - Do_Nth_Then(RC_CONDITIONAL_DECIDE, COND_PREDICATE, Pushed()); - - case TC_COMPILED_EXPRESSION: - execute_compiled_setup(); - Store_Expression( (Pointer) Get_Pointer( Fetch_Expression())); - Export_Registers(); - Which_Way = enter_compiled_expression(); - goto return_from_compiled_code; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_DEFINITION: - Will_Push(CONTINUATION_SIZE + 1); - Save_Env(); - Do_Nth_Then(RC_EXECUTE_DEFINITION_FINISH, DEFINE_VALUE, Pushed()); - - case TC_DELAY: - /* Deliberately omitted: Eval_GC_Check(2); */ - Val = Make_Pointer(TC_DELAYED, Free); - Free[THUNK_ENVIRONMENT] = Fetch_Env(); - Free[THUNK_PROCEDURE] = - Fast_Vector_Ref(Fetch_Expression(), DELAY_OBJECT); - Free += 2; - break; - - case TC_DISJUNCTION: - Will_Push(CONTINUATION_SIZE + 1); - Save_Env(); - Do_Nth_Then(RC_DISJUNCTION_DECIDE, OR_PREDICATE, Pushed()); - - case TC_EXTENDED_LAMBDA: /* Close the procedure */ - /* Deliberately omitted: Eval_GC_Check(2); */ - Val = Make_Pointer(TC_EXTENDED_PROCEDURE, Free); - Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression(); - Free[PROCEDURE_ENVIRONMENT] = Fetch_Env(); - Free += 2; - break; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - -#ifdef COMPILE_FUTURES - case TC_FUTURE: - if (Future_Has_Value(Fetch_Expression())) - { Pointer Future = Fetch_Expression(); - if (Future_Is_Keep_Slot(Future)) Log_Touch_Of_Future(Future); - Reduces_To_Nth(FUTURE_VALUE); - } - Prepare_Eval_Repeat(); - Will_Push(STACK_ENV_EXTRA_SLOTS+2); - Push(Fetch_Expression()); /* Arg: FUTURE object */ - Push(Get_Fixed_Obj_Slot(System_Scheduler)); - Push(STACK_FRAME_HEADER+1); - Pushed(); - goto Internal_Apply; -#endif - - case TC_IN_PACKAGE: - Will_Push(CONTINUATION_SIZE); - Do_Nth_Then(RC_EXECUTE_IN_PACKAGE_CONTINUE, - IN_PACKAGE_ENVIRONMENT, Pushed()); - - case TC_LAMBDA: /* Close the procedure */ - case TC_LEXPR: - /* Deliberately omitted: Eval_GC_Check(2); */ - Val = Make_Pointer(TC_PROCEDURE, Free); - Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression(); - Free[PROCEDURE_ENVIRONMENT] = Fetch_Env(); - Free += 2; - break; - - case TC_MANIFEST_NM_VECTOR: - case TC_MANIFEST_SPECIAL_NM_VECTOR: - Eval_Error(ERR_EXECUTE_MANIFEST_VECTOR); - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_PCOMB0: - /* In case we back out */ - Reserve_Stack_Space(); /* CONTINUATION_SIZE */ - Finished_Eventual_Pushing(); /* of this primitive */ - -Primitive_Internal_Apply: - if (Microcode_Does_Stepping && Trapping && - (Fetch_Apply_Trapper() != NIL)) - {Will_Push(3); - Push(Fetch_Expression()); - Push(Fetch_Apply_Trapper()); - Push(STACK_FRAME_HEADER + 1 + - N_Args_Primitive(Get_Integer(Fetch_Expression()))); - Pushed(); - Stop_Trapping(); - goto Apply_Non_Trapping; - } -Prim_No_Trap_Apply: - { - fast long primitive_code; - - primitive_code = Get_Integer(Fetch_Expression()); - - Export_Regs_Before_Primitive(); - Metering_Apply_Primitive(Val, primitive_code); - Import_Regs_After_Primitive(); - Pop_Primitive_Frame(N_Args_Primitive(primitive_code)); - if (Must_Report_References()) - { Store_Expression(Val); - Store_Return(RC_RESTORE_VALUE); - Save_Cont(); - Call_Future_Logging(); - } - break; - } - - case TC_PCOMB1: - Reserve_Stack_Space(); /* 1+CONTINUATION_SIZE */ - Do_Nth_Then(RC_PCOMB1_APPLY, PCOMB1_ARG_SLOT, {}); - - case TC_PCOMB2: - Reserve_Stack_Space(); /* 2+CONTINUATION_SIZE */ - Save_Env(); - Do_Nth_Then(RC_PCOMB2_DO_1, PCOMB2_ARG_2_SLOT, {}); - - case TC_PCOMB3: - Reserve_Stack_Space(); /* 3+CONTINUATION_SIZE */ - Save_Env(); - Do_Nth_Then(RC_PCOMB3_DO_2, PCOMB3_ARG_3_SLOT, {}); - - case TC_SCODE_QUOTE: - Val = Fast_Vector_Ref(Fetch_Expression(), SCODE_QUOTE_OBJECT); - break; - - case TC_SEQUENCE_2: - Will_Push(CONTINUATION_SIZE + 1); - Save_Env(); - Do_Nth_Then(RC_SEQ_2_DO_2, SEQUENCE_1, Pushed()); - - case TC_SEQUENCE_3: - Will_Push(CONTINUATION_SIZE + 1); - Save_Env(); - Do_Nth_Then(RC_SEQ_3_DO_2, SEQUENCE_1, Pushed()); - - case TC_THE_ENVIRONMENT: - Val = Fetch_Env(); break; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_VARIABLE: - { - long temp; - -#ifndef No_In_Line_Lookup - - fast Pointer *cell; - - Set_Time_Zone(Zone_Lookup); - cell = Get_Pointer(Fetch_Expression()); - lookup(cell, Fetch_Env(), cell, repeat_variable_lookup); - Val = *cell; - if (Type_Code(Val) != TC_REFERENCE_TRAP) - { - Set_Time_Zone(Zone_Working); - goto Pop_Return; - } - - get_trap_kind(temp, Val); - switch(temp) - { - case TRAP_DANGEROUS: - case TRAP_UNBOUND_DANGEROUS: - case TRAP_UNASSIGNED_DANGEROUS: - case TRAP_FLUID_DANGEROUS: - cell = Get_Pointer(Fetch_Expression()); - temp = - deep_lookup_end(deep_lookup(Fetch_Env(), cell[VARIABLE_SYMBOL], cell), - cell); - goto external_lookup_return; - - /* No need to recompile, pass the fake variable. */ - case TRAP_FLUID: - temp = deep_lookup_end(lookup_fluid(Val), fake_variable_object); - - external_lookup_return: - Import_Val(); - if (temp != PRIM_DONE) - break; - Set_Time_Zone(Zone_Working); - goto Pop_Return; - - case TRAP_UNBOUND: - temp = ERR_UNBOUND_VARIABLE; - break; - - case TRAP_UNASSIGNED: - temp = ERR_UNASSIGNED_VARIABLE; - break; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - default: - temp = ERR_BROKEN_COMPILED_VARIABLE; - break; - } - -#else No_In_Line_Lookup - - Set_Time_Zone(Zone_Lookup); - temp = Lex_Ref(Fetch_Env(), Fetch_Expression()); - Import_Val(); - if (temp == PRIM_DONE) - break; - -#endif No_In_Line_Lookup - - /* Back out of the evaluation. */ - - Set_Time_Zone(Zone_Working); - - if (temp == PRIM_INTERRUPT) - { - Prepare_Eval_Repeat(); - Interrupt(IntCode & IntEnb); - } - - Eval_Error(temp); - } - - case TC_RETURN_CODE: - default: Eval_Error(ERR_UNDEFINED_USER_TYPE); - }; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - -/* Now restore the continuation saved during an earlier part - * of the EVAL cycle and continue as directed. - */ - -Pop_Return: - Pop_Return_Ucode_Hook(); - Restore_Cont(); - if (Consistency_Check && - (Type_Code(Fetch_Return()) != TC_RETURN_CODE)) - { Push(Val); /* For possible stack trace */ - Save_Cont(); - Export_Registers(); - Microcode_Termination(TERM_BAD_STACK); - } - if (Eval_Debug) - { Print_Return("Pop_Return, return code"); - Print_Expression(Val, "Pop_Return, value"); - CRLF(); - }; - - /* Dispatch on the return code. A BREAK here will cause - * a "goto Pop_Return" to occur, since this is the most - * common occurrence. - */ - - switch (Get_Integer(Fetch_Return())) - { case RC_COMB_1_PROCEDURE: - Restore_Env(); - Push(Val); /* Arg. 1 */ - Push(NIL); /* Operator */ - Push(STACK_FRAME_HEADER+1); - Finished_Eventual_Pushing(); - Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_1_FN); - - case RC_COMB_2_FIRST_OPERAND: - Restore_Env(); - Push(Val); - Save_Env(); - Do_Another_Then(RC_COMB_2_PROCEDURE, COMB_2_ARG_1); - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_COMB_2_PROCEDURE: - Restore_Env(); - Push(Val); /* Arg 1, just calculated */ - Push(NIL); /* Function */ - Push(STACK_FRAME_HEADER+2); - Finished_Eventual_Pushing(); - Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_2_FN); - - case RC_COMB_APPLY_FUNCTION: - End_Subproblem(); - Stack_Ref(STACK_ENV_FUNCTION) = Val; - goto Internal_Apply; - - case RC_COMB_SAVE_VALUE: - { long Arg_Number; - - Restore_Env(); - Arg_Number = Get_Integer(Stack_Ref(STACK_COMB_FINGER))-1; - Stack_Ref(STACK_COMB_FIRST_ARG+Arg_Number) = Val; - Stack_Ref(STACK_COMB_FINGER) = - Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Arg_Number); - /* DO NOT count on the type code being NMVector here, since - the stack parser may create them with NIL here! */ - if (Arg_Number > 0) - { Save_Env(); - Do_Another_Then(RC_COMB_SAVE_VALUE, - (COMB_ARG_1_SLOT - 1) + Arg_Number); - } - Push(Fast_Vector_Ref(Fetch_Expression(), 0)); /* Frame Size */ - Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT); - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - -#define define_compiler_restart( return_code, entry) \ - case return_code: \ - { extern long entry(); \ - compiled_code_restart(); \ - Export_Registers(); \ - Which_Way = entry(); \ - goto return_from_compiled_code; \ - } - - define_compiler_restart( RC_COMP_INTERRUPT_RESTART, - comp_interrupt_restart) - - define_compiler_restart( RC_COMP_LEXPR_INTERRUPT_RESTART, - comp_lexpr_interrupt_restart) - - define_compiler_restart( RC_COMP_LOOKUP_APPLY_RESTART, - comp_lookup_apply_restart) - - define_compiler_restart( RC_COMP_REFERENCE_RESTART, - comp_reference_restart) - - define_compiler_restart( RC_COMP_ACCESS_RESTART, - comp_access_restart) - - define_compiler_restart( RC_COMP_UNASSIGNED_P_RESTART, - comp_unassigned_p_restart) - - define_compiler_restart( RC_COMP_UNBOUND_P_RESTART, - comp_unbound_p_restart) - - define_compiler_restart( RC_COMP_ASSIGNMENT_RESTART, - comp_assignment_restart) - - define_compiler_restart( RC_COMP_DEFINITION_RESTART, - comp_definition_restart) - - case RC_REENTER_COMPILED_CODE: - compiled_code_restart(); - Export_Registers(); - Which_Way = return_to_compiled_code(); - goto return_from_compiled_code; - - case RC_CONDITIONAL_DECIDE: - Pop_Return_Val_Check(); - End_Subproblem(); - Restore_Env(); - Reduces_To_Nth((Val==NIL)? COND_ALTERNATIVE : COND_CONSEQUENT); - - case RC_DISJUNCTION_DECIDE: - /* Return predicate if it isn't NIL; else do ALTERNATIVE */ - Pop_Return_Val_Check(); - End_Subproblem(); - Restore_Env(); - if (Val != NIL) goto Pop_Return; - Reduces_To_Nth(OR_ALTERNATIVE); - - case RC_END_OF_COMPUTATION: - /* Signals bottom of stack */ - Export_Registers(); - Microcode_Termination(TERM_END_OF_COMPUTATION); - - case RC_EVAL_ERROR: - /* Should be called RC_REDO_EVALUATION. */ - Store_Env(Pop()); - Reduces_To(Fetch_Expression()); - - case RC_EXECUTE_ACCESS_FINISH: - { - long Result; - Pointer value; - - Pop_Return_Val_Check(); - value = Val; - - if (Environment_P(Val)) - { Result = Symbol_Lex_Ref(value, - Fast_Vector_Ref(Fetch_Expression(), - ACCESS_NAME)); - Import_Val(); - if (Result == PRIM_DONE) - { - End_Subproblem(); - break; - } - if (Result != PRIM_INTERRUPT) - { - Val = value; - Pop_Return_Error(Result); - } - Prepare_Pop_Return_Interrupt(RC_EXECUTE_ACCESS_FINISH, value); - Interrupt(IntCode & IntEnb); - } - Val = value; - Pop_Return_Error(ERR_BAD_FRAME); - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_EXECUTE_ASSIGNMENT_FINISH: - { - long temp; - Pointer value; - Lock_Handle set_serializer; - -#ifndef No_In_Line_Lookup - - Pointer bogus_unassigned; - fast Pointer *cell; - - Set_Time_Zone(Zone_Lookup); - Restore_Env(); - cell = Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME)); - lookup(cell, Fetch_Env(), cell, repeat_assignment_lookup); - setup_lock(set_serializer, cell); - - value = Val; - bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object); - if (value == bogus_unassigned) - value = UNASSIGNED_OBJECT; - - if (Type_Code(*cell) != TC_REFERENCE_TRAP) - { - Val = *cell; - - normal_assignment_done: - *cell = value; - remove_lock(set_serializer); - Set_Time_Zone(Zone_Working); - End_Subproblem(); - goto Pop_Return; - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - get_trap_kind(temp, *cell); - switch(temp) - { - case TRAP_DANGEROUS: - case TRAP_UNBOUND_DANGEROUS: - case TRAP_UNASSIGNED_DANGEROUS: - case TRAP_FLUID_DANGEROUS: - remove_lock(set_serializer); - cell = Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME)); - temp = - deep_assignment_end(deep_lookup(Fetch_Env(), - cell[VARIABLE_SYMBOL], - cell), - cell, - value, - false); - goto external_assignment_return; - - case TRAP_UNASSIGNED: - Val = bogus_unassigned; - goto normal_assignment_done; - - case TRAP_FLUID: - /* No need to recompile, pass the fake variable. */ - remove_lock(set_serializer); - temp = deep_assignment_end(lookup_fluid(*cell), - fake_variable_object, - value, - false); - - external_assignment_return: - Import_Val(); - if (temp != PRIM_DONE) - break; - Set_Time_Zone(Zone_Working); - End_Subproblem(); - goto Pop_Return; - - case TRAP_UNBOUND: - remove_lock(set_serializer); - temp = ERR_UNBOUND_VARIABLE; - break; - - default: - remove_lock(set_serializer); - temp = ERR_BROKEN_COMPILED_VARIABLE; - break; - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - -#else - - Set_Time_Zone(Zone_Lookup); - Restore_Env(); - temp = Lex_Set(Fetch_Env(), - Vector_Ref(Fetch_Expression(), ASSIGN_NAME), - value); - Import_Val(); - if (temp == PRIM_DONE) - { End_Subproblem(); - Set_Time_Zone(Zone_Working); - break; - } - -#endif - - Set_Time_Zone(Zone_Working); - Save_Env(); - if (temp != PRIM_INTERRUPT) - { - Val = value; - Pop_Return_Error(temp); - } - - Prepare_Pop_Return_Interrupt(RC_EXECUTE_ASSIGNMENT_FINISH, - value); - Interrupt(IntCode & IntEnb); - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_EXECUTE_DEFINITION_FINISH: - { - Pointer value; - long result; - - value = Val; - Restore_Env(); - Export_Registers(); - result = Local_Set(Fetch_Env(), - Fast_Vector_Ref(Fetch_Expression(), DEFINE_NAME), - Val); - Import_Registers(); - if (result == PRIM_DONE) - { - End_Subproblem(); - break; - } - Save_Env(); - if (result == PRIM_INTERRUPT) - { - Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH, - value); - Interrupt(IntCode & IntEnb); - } - Val = value; - Pop_Return_Error(result); - } - - case RC_EXECUTE_IN_PACKAGE_CONTINUE: - Pop_Return_Val_Check(); - if (Environment_P(Val)) - { - End_Subproblem(); - Store_Env(Val); - Reduces_To_Nth(IN_PACKAGE_EXPRESSION); - } - Pop_Return_Error(ERR_BAD_FRAME); - -#ifdef COMPILE_FUTURES - case RC_FINISH_GLOBAL_INT: - Export_Registers(); - Val = Global_Int_Part_2(Fetch_Expression(), Val); - Import_Registers_Except_Val(); - break; -#endif - - case RC_GC_CHECK: - if (Get_Integer(Fetch_Expression()) > Space_Before_GC()) - { - Export_Registers(); - Microcode_Termination(TERM_GC_OUT_OF_SPACE); - } - break; - - case RC_HALT: - Export_Registers(); - Microcode_Termination(TERM_TERM_HANDLER); - - case RC_INTERNAL_APPLY: - -Internal_Apply: - -/* Branch here to perform a function application. - - At this point the top of the stack contains an application frame - which consists of the following elements (see sdata.h): - - A header specifying the frame length. - - A procedure. - - The actual (evaluated) arguments. - - No registers (except the stack pointer) are meaning full at this point. - Before interrupts or errors are processed, some registers are cleared - to avoid holding onto garbage if a garbage collection occurs. -*/ - -#define Prepare_Apply_Interrupt() \ -{ \ - Store_Return(RC_INTERNAL_APPLY); \ - Store_Expression(NIL); \ - Save_Cont(); \ -} - -#define Apply_Error(N) \ -{ \ - Store_Return(RC_INTERNAL_APPLY); \ - Store_Expression(NIL); \ - Val = NIL; \ - Pop_Return_Error(N); \ -} - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - if (Microcode_Does_Stepping && Trapping && - (Fetch_Apply_Trapper() != NIL)) - { - long Count; - - Count = Get_Integer(Stack_Ref(STACK_ENV_HEADER)); - Top_Of_Stack() = Fetch_Apply_Trapper(); - Push(STACK_FRAME_HEADER+Count); - Stop_Trapping(); - } - -Apply_Non_Trapping: - - if ((IntCode & IntEnb) != 0) - { - long Interrupts; - - Interrupts = (IntCode & IntEnb); - Store_Expression(NIL); - Val = NIL; - Prepare_Apply_Interrupt(); - Interrupt(Interrupts); - } - -Perform_Application: - - Apply_Ucode_Hook(); - - { - fast Pointer Function; - - Apply_Future_Check(Function, Stack_Ref(STACK_ENV_FUNCTION)); - - switch(Type_Code(Function)) - { - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_PROCEDURE: - { - fast long nargs; - - nargs = Get_Integer(Pop()); - Function = Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR); - - { - fast Pointer formals; - - Apply_Future_Check(formals, - Fast_Vector_Ref(Function, LAMBDA_FORMALS)); - - if ((nargs != Vector_Length(formals)) && - ((Type_Code(Function) != TC_LEXPR) || - (nargs < Vector_Length(formals)))) - { - Push(STACK_FRAME_HEADER + nargs - 1); - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } - } - - if (Eval_Debug) - { - Print_Expression(Make_Unsigned_Fixnum(nargs), - "APPLY: Number of arguments"); - } - - if (GC_Check(nargs + 1)) - { - Push(STACK_FRAME_HEADER + nargs - 1); - Prepare_Apply_Interrupt(); - Immediate_GC(nargs + 1); - } - - { - fast Pointer *scan; - - scan = Free; - Store_Env(Make_Pointer(TC_ENVIRONMENT, scan)); - *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, nargs); - while(--nargs >= 0) - *scan++ = Pop(); - Free = scan; - Reduces_To(Fast_Vector_Ref(Function, LAMBDA_SCODE)); - } - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_CONTROL_POINT: - { - if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) != - STACK_ENV_FIRST_ARG) - { - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } - Val = Stack_Ref(STACK_ENV_FIRST_ARG); - Our_Throw(false, Function); - Apply_Stacklet_Backout(); - Our_Throw_Part_2(); - goto Pop_Return; - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - /* - After checking the number of arguments, remove the - frame header since primitives do not expect it. - */ - - case TC_PRIMITIVE: - { - if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) != - STACK_ENV_FIRST_ARG + N_Args_Primitive(Get_Integer(Function)) - 1) - { - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } - Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG); - Store_Expression(Function); - goto Prim_No_Trap_Apply; - } - - case TC_PRIMITIVE_EXTERNAL: - { - fast long NArgs, Proc; - - Proc = Datum(Function); - if (Proc > MAX_EXTERNAL_PRIMITIVE) - { - Apply_Error(ERR_UNDEFINED_PRIMITIVE); - } - NArgs = N_Args_External(Proc); - if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) != - (NArgs + (STACK_ENV_FIRST_ARG - 1))) - { - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } - Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG); - Store_Expression(Function); - -Repeat_External_Primitive: - /* Reinitialize Proc in case we "goto Repeat_External..." */ - Proc = Get_Integer(Fetch_Expression()); - - Export_Regs_Before_Primitive(); - Val = Apply_External(Proc); - Set_Time_Zone(Zone_Working); - Import_Regs_After_Primitive(); - Pop_Primitive_Frame(N_Args_External(Proc)); - - goto Pop_Return; - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_EXTENDED_PROCEDURE: - { - Pointer lambda; - long nargs, nparams, formals, params, auxes, - rest_flag, size; - - fast long i; - fast Pointer *scan; - - nargs = Get_Integer(Pop()) - STACK_FRAME_HEADER; - - if (Eval_Debug) - { - Print_Expression(Make_Unsigned_Fixnum(nargs+STACK_FRAME_HEADER), - "APPLY: Number of arguments"); - } - - lambda = Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR); - Apply_Future_Check(Function, - Fast_Vector_Ref(lambda, ELAMBDA_NAMES)); - nparams = Vector_Length(Function) - 1; - - Apply_Future_Check(Function, Get_Count_Elambda(lambda)); - formals = Elambda_Formals_Count(Function); - params = Elambda_Opts_Count(Function) + formals; - rest_flag = Elambda_Rest_Flag(Function); - auxes = nparams - (params + rest_flag); - - if ((nargs < formals) || (!rest_flag && (nargs > params))) - { - Push(STACK_FRAME_HEADER + nargs); - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } - - /* size includes the procedure slot, but not the header. */ - size = params + rest_flag + auxes + 1; - if (GC_Check(size + 1 + ((nargs > params) ? - (2 * (nargs - params)) : - 0))) - { - Push(STACK_FRAME_HEADER + nargs); - Prepare_Apply_Interrupt(); - Immediate_GC(size + 1 + ((nargs > params) ? - (2 * (nargs - params)) : - 0)); - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - scan = Free; - Store_Env(Make_Pointer(TC_ENVIRONMENT, scan)); - *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, size); - - if (nargs <= params) - { - for (i = (nargs + 1); --i >= 0; ) - *scan++ = Pop(); - for (i = (params - nargs); --i >= 0; ) - *scan++ = UNASSIGNED_OBJECT; - if (rest_flag) - *scan++ = NIL; - for (i = auxes; --i >= 0; ) - *scan++ = UNASSIGNED_OBJECT; - } - else - { - /* rest_flag must be true. */ - Pointer list; - - list = Make_Pointer(TC_LIST, (scan + size)); - for (i = (params + 1); --i >= 0; ) - *scan++ = Pop(); - *scan++ = list; - for (i = auxes; --i >= 0; ) - *scan++ = UNASSIGNED_OBJECT; - /* Now scan == Get_Pointer(list) */ - for (i = (nargs - params); --i >= 0; ) - { - *scan++ = Pop(); - *scan = Make_Pointer(TC_LIST, (scan + 1)); - scan += 1; - } - scan[-1] = NIL; - } - - Free = scan; - Reduces_To(Get_Body_Elambda(lambda)); - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_COMPILED_PROCEDURE: - { - apply_compiled_setup(STACK_ENV_EXTRA_SLOTS + - Get_Integer( Stack_Ref( STACK_ENV_HEADER))); - Export_Registers(); - Which_Way = apply_compiled_procedure(); - -return_from_compiled_code: - Import_Registers(); - switch (Which_Way) - { - case PRIM_DONE: - { compiled_code_done(); - goto Pop_Return; - } - - case PRIM_APPLY: - { compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS + - Get_Integer( Stack_Ref( STACK_ENV_HEADER))); - goto Internal_Apply; - } - - case ERR_COMPILED_CODE_ERROR: - { /* The compiled code is signalling a microcode error. */ - compiled_error_backout(); - /* The Save_Cont is done by Pop_Return_Error. */ - Pop_Return_Error( compiled_code_error_code); - } - - case PRIM_INTERRUPT: - { compiled_error_backout(); - Save_Cont(); - Interrupt( (IntCode & IntEnb)); - } - - case ERR_WRONG_NUMBER_OF_ARGUMENTS: - { apply_compiled_backout(); - Apply_Error( Which_Way); - } - - case ERR_EXECUTE_MANIFEST_VECTOR: - { /* This error code means that enter_compiled_expression - was called in a system without compiler support. - */ - execute_compiled_backout(); - Val = Make_Non_Pointer( TC_COMPILED_EXPRESSION, - Fetch_Expression()); - Pop_Return_Error( Which_Way); - } - - case ERR_INAPPLICABLE_OBJECT: - { /* This error code means that apply_compiled_procedure - was called in a system without compiler support. - */ - apply_compiled_backout(); - Apply_Error( Which_Way); - } - - case ERR_INAPPLICABLE_CONTINUATION: - { /* This error code means that return_to_compiled_code - or some other compiler continuation was called in a - system without compiler support. - */ - Store_Expression(NIL); - Store_Return(RC_REENTER_COMPILED_CODE); - Pop_Return_Error(Which_Way); - } - - default: Microcode_Termination( TERM_COMPILER_DEATH); - } - } - - default: - Apply_Error(ERR_INAPPLICABLE_OBJECT); - } /* End of switch in RC_INTERNAL_APPLY */ - } /* End of RC_INTERNAL_APPLY case */ - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_MOVE_TO_ADJACENT_POINT: - /* Expression contains the space in which we are moving */ - { long From_Count = Get_Integer(Stack_Ref(TRANSLATE_FROM_DISTANCE)); - Pointer Thunk, New_Location; - if (From_Count != 0) - { Pointer Current = Stack_Ref(TRANSLATE_FROM_POINT); - Stack_Ref(TRANSLATE_FROM_DISTANCE) = Make_Unsigned_Fixnum((From_Count - 1)); - Thunk = Fast_Vector_Ref(Current, STATE_POINT_AFTER_THUNK); - New_Location = Fast_Vector_Ref(Current, STATE_POINT_NEARER_POINT); - Stack_Ref(TRANSLATE_FROM_POINT) = New_Location; - if ((From_Count == 1) && - (Stack_Ref(TRANSLATE_TO_DISTANCE) == Make_Unsigned_Fixnum(0))) - Stack_Pointer = Simulate_Popping(4); - else Save_Cont(); - } - else - { long To_Count = Get_Integer(Stack_Ref(TRANSLATE_TO_DISTANCE))-1; - fast Pointer To_Location = Stack_Ref(TRANSLATE_TO_POINT); - fast long i; - for (i=0; i < To_Count; i++) - To_Location = Fast_Vector_Ref(To_Location, STATE_POINT_NEARER_POINT); - Thunk = Fast_Vector_Ref(To_Location, STATE_POINT_BEFORE_THUNK); - New_Location = To_Location; - Stack_Ref(TRANSLATE_TO_DISTANCE) = Make_Unsigned_Fixnum(To_Count); - if (To_Count==0) - Stack_Pointer = Simulate_Popping(4); - else Save_Cont(); - } - if (Fetch_Expression() != NIL) - Vector_Set(Fetch_Expression(), STATE_SPACE_NEAREST_POINT, New_Location); - else Current_State_Point = New_Location; - Will_Push(2); - Push(Thunk); - Push(STACK_FRAME_HEADER); - Pushed(); - goto Internal_Apply; - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_INVOKE_STACK_THREAD: - /* Used for WITH_THREADED_STACK primitive */ - Will_Push(3); - Push(Val); /* Value calculated by thunk */ - Push(Fetch_Expression()); - Push(STACK_FRAME_HEADER+1); - Pushed(); - goto Internal_Apply; - - case RC_JOIN_STACKLETS: - Our_Throw(true, Fetch_Expression()); - Join_Stacklet_Backout(); - Our_Throw_Part_2(); - break; - - case RC_NORMAL_GC_DONE: - End_GC_Hook(); - if (GC_Check(GC_Space_Needed)) - { printf("\nGC just ended. The free pointer is at 0x%x, the top of this heap\n", - Free); - printf("is at 0x%x, and we are trying to cons 0x%x objects. Dead!\n", - MemTop, GC_Space_Needed); - Microcode_Termination(TERM_EXIT); - } - GC_Space_Needed = 0; - Val = Fetch_Expression(); - break; - - case RC_PCOMB1_APPLY: - End_Subproblem(); - Push(Val); /* Argument value */ - Finished_Eventual_Pushing(); - Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB1_FN_SLOT)); - goto Primitive_Internal_Apply; - - case RC_PCOMB2_APPLY: - End_Subproblem(); - Push(Val); /* Value of arg. 1 */ - Finished_Eventual_Pushing(); - Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB2_FN_SLOT)); - goto Primitive_Internal_Apply; - - case RC_PCOMB2_DO_1: - Restore_Env(); - Push(Val); /* Save value of arg. 2 */ - Do_Another_Then(RC_PCOMB2_APPLY, PCOMB2_ARG_1_SLOT); - - case RC_PCOMB3_APPLY: - End_Subproblem(); - Push(Val); /* Save value of arg. 1 */ - Finished_Eventual_Pushing(); - Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB3_FN_SLOT)); - goto Primitive_Internal_Apply; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_PCOMB3_DO_1: - { Pointer Temp; - Temp = Pop(); /* Value of arg. 3 */ - Restore_Env(); - Push(Temp); /* Save arg. 3 again */ - Push(Val); /* Save arg. 2 */ - Do_Another_Then(RC_PCOMB3_APPLY, PCOMB3_ARG_1_SLOT); - } - - case RC_PCOMB3_DO_2: - Restore_Then_Save_Env(); - Push(Val); /* Save value of arg. 3 */ - Do_Another_Then(RC_PCOMB3_DO_1, PCOMB3_ARG_2_SLOT); - - case RC_POP_RETURN_ERROR: - case RC_RESTORE_VALUE: - Val = Fetch_Expression(); - break; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_PURIFY_GC_1: - { Pointer GC_Daemon_Proc, Result; - Export_Registers(); - Result = Purify_Pass_2(Fetch_Expression()); - Import_Registers(); - if (Result == NIL) - { /* The object does not fit in Constant space. - There is no need to run the daemons, and we should let the runtime - system know what happened. - */ - Val = NIL; - break; - } - GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon); - if (GC_Daemon_Proc==NIL) - { Val = TRUTH; - break; - } - Store_Expression(NIL); - Store_Return(RC_PURIFY_GC_2); - Save_Cont(); - Will_Push(2); - Push(GC_Daemon_Proc); - Push(STACK_FRAME_HEADER); - Pushed(); - goto Internal_Apply; - } - - case RC_PURIFY_GC_2: - Val = TRUTH; - break; - - case RC_REPEAT_DISPATCH: - Sign_Extend(Fetch_Expression(), Which_Way); - Restore_Env(); - Val = Pop(); - Restore_Cont(); - goto Repeat_Dispatch; - - case RC_REPEAT_PRIMITIVE: - if (Type_Code(Fetch_Expression()) == TC_PRIMITIVE_EXTERNAL) - goto Repeat_External_Primitive; - else goto Primitive_Internal_Apply; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - -/* The following two return codes are both used to restore - a saved history object. The difference is that the first - does not copy the history object while the second does. - In both cases, the Expression register contains the history - object and the next item to be popped off the stack contains - the offset back to the previous restore history return code. - - ASSUMPTION: History objects are never created using futures. -*/ - - case RC_RESTORE_DONT_COPY_HISTORY: - { Pointer Stacklet; - Prev_Restore_History_Offset = Get_Integer(Pop()); - Stacklet = Pop(); - History = Get_Pointer(Fetch_Expression()); - if (Prev_Restore_History_Offset == 0) - Prev_Restore_History_Stacklet = NULL; - else if (Stacklet == NIL) - Prev_Restore_History_Stacklet = NULL; - else - Prev_Restore_History_Stacklet = Get_Pointer(Stacklet); - break; - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_RESTORE_HISTORY: - { Pointer Stacklet; - Export_Registers(); - if (! Restore_History(Fetch_Expression())) - { Import_Registers(); - Save_Cont(); - Will_Push(CONTINUATION_SIZE); - Store_Expression(Val); - Store_Return(RC_RESTORE_VALUE); - Save_Cont(); - Pushed(); - Immediate_GC((Free > MemTop) ? 0 : ((MemTop-Free)+1)); - } - Import_Registers(); - Prev_Restore_History_Offset = Get_Integer(Pop()); - Stacklet = Pop(); - if (Prev_Restore_History_Offset == 0) - Prev_Restore_History_Stacklet = NULL; - else - { if (Stacklet == NIL) - { Prev_Restore_History_Stacklet = NULL; - Get_End_Of_Stacklet()[-Prev_Restore_History_Offset] = - Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY); - } - else - { Prev_Restore_History_Stacklet = Get_Pointer(Stacklet); - Prev_Restore_History_Stacklet[-Prev_Restore_History_Offset] = - Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY); - } - } - break; - } - - case RC_RESTORE_FLUIDS: - Fluid_Bindings = Fetch_Expression(); - New_Compiler_MemTop(); - break; - - case RC_RESTORE_INT_MASK: - IntEnb = Get_Integer(Fetch_Expression()); - New_Compiler_MemTop(); - break; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_RESTORE_TO_STATE_POINT: - { Pointer Where_To_Go = Fetch_Expression(); - Will_Push(CONTINUATION_SIZE); - /* Restore the contents of Val after moving to point */ - Store_Expression(Val); - Store_Return(RC_RESTORE_VALUE); - Save_Cont(); - Pushed(); - Export_Registers(); - Translate_To_Point(Where_To_Go); - break; /* We never get here.... */ - } - - case RC_RETURN_TRAP_POINT: - Store_Return(Old_Return_Code); - Will_Push(CONTINUATION_SIZE+3); - Save_Cont(); - Return_Hook_Address = NULL; - Stop_Trapping(); - Push(Val); - Push(Fetch_Return_Trapper()); - Push(STACK_FRAME_HEADER+1); - Pushed(); - goto Apply_Non_Trapping; - - case RC_SEQ_2_DO_2: - End_Subproblem(); - Restore_Env(); - Reduces_To_Nth(SEQUENCE_2); - - case RC_SEQ_3_DO_2: - Restore_Then_Save_Env(); - Do_Another_Then(RC_SEQ_3_DO_3, SEQUENCE_2); - - case RC_SEQ_3_DO_3: - End_Subproblem(); - Restore_Env(); - Reduces_To_Nth(SEQUENCE_3); - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_SNAP_NEED_THUNK: - Vector_Set(Fetch_Expression(), THUNK_SNAPPED, TRUTH); - Vector_Set(Fetch_Expression(), THUNK_VALUE, Val); - break; - - case RC_AFTER_MEMORY_UPDATE: - case RC_BAD_INTERRUPT_CONTINUE: - case RC_COMPLETE_GC_DONE: - case RC_RESTARTABLE_EXIT: - case RC_RESTART_EXECUTION: - case RC_RESTORE_CONTINUATION: - case RC_RESTORE_STEPPER: - case RC_POP_FROM_COMPILED_CODE: - Export_Registers(); - Microcode_Termination(TERM_UNIMPLEMENTED_CONTINUATION); - - default: - Export_Registers(); - Microcode_Termination(TERM_NON_EXISTENT_CONTINUATION); - }; - goto Pop_Return; -} diff --git a/v7/src/microcode/interp.h b/v7/src/microcode/interp.h deleted file mode 100644 index e85624373..000000000 --- a/v7/src/microcode/interp.h +++ /dev/null @@ -1,407 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.23 1987/04/16 02:25:05 jinx Rel $ - * - * Macros used by the interpreter and some utilities. - * - */ - - /********************/ - /* OPEN CODED RACKS */ - /********************/ - -/* Move from register to static storage and back */ - -/* Note defined() cannot be used because VMS does not understand it. */ - -#ifdef In_Main_Interpreter -#ifndef ENABLE_DEBUGGING_TOOLS -#define Cache_Registers -#endif -#endif - -#ifdef Cache_Registers - -#define Regs Reg_Block -#define Stack_Pointer Reg_Stack_Pointer -#define History Reg_History - -#define Import_Registers() \ -{ \ - Reg_Stack_Pointer = Ext_Stack_Pointer; \ - Reg_History = Ext_History; \ -} - -#define Export_Registers() \ -{ \ - Ext_History = Reg_History; \ - Ext_Stack_Pointer = Reg_Stack_Pointer; \ -} - -#else - -#define Regs Registers -#define Stack_Pointer Ext_Stack_Pointer -#define History Ext_History - -#define Import_Registers() -#define Export_Registers() - -#endif - -#define Import_Val() -#define Import_Registers_Except_Val() Import_Registers() - -#define Import_Regs_After_Primitive() -#define Export_Regs_Before_Primitive() Export_Registers() - -#define Env Regs[REGBLOCK_ENV] -#define Val Regs[REGBLOCK_VAL] -#define Expression Regs[REGBLOCK_EXPR] -#define Return Regs[REGBLOCK_RETURN] - -/* Internal_Will_Push is in stack.h. */ - -#ifdef ENABLE_DEBUGGING_TOOLS -#define Will_Push(N) \ -{ Pointer *Will_Push_Limit; \ - Internal_Will_Push((N)); \ - Will_Push_Limit = Simulate_Pushing(N) - -#define Pushed() \ - if (Stack_Pointer < Will_Push_Limit) Stack_Death(); \ -} - -#else -#define Will_Push(N) Internal_Will_Push(N) -#define Pushed() /* No op */ -#endif - -#define Will_Eventually_Push(N) Internal_Will_Push(N) -#define Finished_Eventual_Pushing() /* No op */ - -/* Primitive stack operations: - * These operations hide the direction of stack growth. - * Throw in stack.h, Allocate_New_Stacklet in utils.c, apply, cwcc and - * friends in hooks.c, and possibly other stuff, depend on the direction in - * which the stack grows. - */ - -#define Push(P) *--Stack_Pointer = (P) -#define Pop() (*Stack_Pointer++) -#define Stack_Ref(N) (Stack_Pointer[(N)]) -#define Simulate_Pushing(N) (Stack_Pointer - (N)) -#define Simulate_Popping(N) (Stack_Pointer + (N)) - -#define Top_Of_Stack() Stack_Ref(0) -#define Stack_Distance(previous_top_of_stack) \ - ((previous_top_of_stack) - (&Top_Of_Stack())) - -/* These can be used when SP is a pointer into the stack, to make - * stack gap operations independent of the direction of stack growth. - * They must match Push and Pop above. - */ - -#define Push_From(SP) *--(SP) -#define Pop_Into(SP, What) (*(SP)++) = (What) - -/* Stack Gap Operations: */ - -/* With_Stack_Gap opens a gap Gap_Size wide Gap_Position cells above the - * top of the stack. Code must push Gap_Size objects. It executes Code - * with the stack pointer placed so that these objects will fill the gap. - */ - -#define With_Stack_Gap(Gap_Size, Gap_Position, Code) \ -{ Pointer *Saved_Destination; \ - fast Pointer *Destination; \ - fast long size_to_move = (Gap_Position); \ - Destination = Simulate_Pushing(Gap_Size); \ - Saved_Destination = Destination; \ - while (--size_to_move >= 0) \ - Pop_Into(Destination, Pop()); \ - Code; \ - Stack_Pointer = Saved_Destination; \ -} - -/* Close_Stack_Gap closes a gap Gap_Size wide Gap_Position cells above the - * top of the stack. The contents of the gap are lost. - */ - -#define Close_Stack_Gap(Gap_Size, Gap_Position, extra_code) \ -{ fast long size_to_move = (Gap_Position); \ - fast Pointer *Source = Simulate_Popping(size_to_move); \ - Stack_Pointer = Simulate_Popping((Gap_Size) + size_to_move); \ - extra_code; \ - while (--size_to_move >= 0) \ - Push(Push_From(Source)); \ -} - -/* Racks operations continue on the next page */ - -/* Rack operations, continued */ - -/* Fetch from register */ - -#define Fetch_Expression() Expression -#define Fetch_Env() Env -#define Fetch_Return() Return - -/* Store into register */ - -#define Store_Expression(P) Expression = (P) -#define Store_Env(P) Env = (P) -#define Store_Return(P) \ - Return = Make_Non_Pointer(TC_RETURN_CODE, (P)) - -#define Save_Env() Push(Env) -#define Restore_Env() Env = Pop() -#define Restore_Then_Save_Env() Env = Top_Of_Stack() - -/* Note: Save_Cont must match the definitions in sdata.h */ - -#define Save_Cont() { Push(Expression); \ - Push(Return); \ - Cont_Print(); \ - } - -#define Restore_Cont() { Return = Pop(); \ - Expression = Pop(); \ - if (Cont_Debug) \ - { Print_Return(RESTORE_CONT_RETURN_MESSAGE); \ - Print_Expression(Fetch_Expression(), \ - RESTORE_CONT_EXPR_MESSAGE);\ - CRLF(); \ - } \ - } - -#define Cont_Print() if (Cont_Debug) \ - { Print_Return(CONT_PRINT_RETURN_MESSAGE); \ - Print_Expression(Fetch_Expression(), \ - CONT_PRINT_EXPR_MESSAGE); \ - CRLF(); \ - } - -#define Stop_Trapping() \ -{ Trapping = false; \ - if (Return_Hook_Address != NULL) \ - *Return_Hook_Address = Old_Return_Code; \ - Return_Hook_Address = NULL; \ -} - -/* Primitive utility macros */ - -#define Internal_Apply_Primitive(primitive_code) \ - ((*(Primitive_Procedure_Table[primitive_code]))()) - -#define N_Args_Primitive(primitive_code) \ - (Primitive_Arity_Table[primitive_code]) - -#define Internal_Apply_External(external_code) \ - ((*(External_Procedure_Table[external_code]))()) - -#define N_Args_External(external_code) \ - (External_Arity_Table[external_code]) - -#define Apply_External(N) \ - Internal_Apply_External(N) - -#define Pop_Primitive_Frame(NArgs) \ - Stack_Pointer = Simulate_Popping(NArgs) - -/* Compiled code utility macros */ - -/* Going from interpreted code to compiled code */ - -/* Tail recursion is handled as follows: - if the return code is `reenter_compiled_code', it is discarded, - and the two contiguous interpreter segments on the stack are - merged. - */ - -/* Apply interface: - calling a compiled procedure with a frame nslots long. - */ - -#define apply_compiled_setup(nslots) \ -{ long frame_size = (nslots); \ - if (Stack_Ref(frame_size + CONTINUATION_RETURN_CODE) == \ - (Make_Non_Pointer(TC_RETURN_CODE, RC_REENTER_COMPILED_CODE))) \ - { /* Merge compiled code segments on the stack. */ \ - Close_Stack_Gap(CONTINUATION_SIZE, \ - frame_size, \ - { long segment_size = \ - Datum(Stack_Ref(CONTINUATION_EXPRESSION - \ - CONTINUATION_SIZE)); \ - last_return_code = Simulate_Popping(segment_size); \ - }); \ - /* Undo the subproblem rotation. */ \ - Compiler_End_Subproblem(); \ - } \ - else \ - { /* Make a new compiled code segment which includes this frame. */ \ - /* History need not be hacked here. */ \ - With_Stack_Gap(1, \ - frame_size, \ - { last_return_code = &Top_Of_Stack(); \ - Push(return_to_interpreter); \ - }); \ - } \ -} - -/* Eval interface: - executing a compiled expression. - */ - -#define execute_compiled_setup() \ -{ if (Stack_Ref(CONTINUATION_RETURN_CODE) == \ - (Make_Non_Pointer(TC_RETURN_CODE, RC_REENTER_COMPILED_CODE))) \ - { /* Merge compiled code segments on the stack. */ \ - long segment_size; \ - Restore_Cont(); \ - segment_size = Datum(Fetch_Expression()); \ - last_return_code = Simulate_Popping(segment_size); \ - /* Undo the subproblem rotation. */ \ - Compiler_End_Subproblem(); \ - } \ - else \ - { /* Make a new compiled code segment on the stack. */ \ - /* History need not be hacked here. */ \ - last_return_code = &Top_Of_Stack(); \ - Push(return_to_interpreter); \ - } \ -} - -/* Pop return interface: - Returning to compiled code from the interpreter. - */ - -#define compiled_code_restart() \ -{ long segment_size; \ - segment_size = Datum(Fetch_Expression()); \ - last_return_code = Simulate_Popping(segment_size); \ - /* Undo the subproblem rotation. */ \ - Compiler_End_Subproblem(); \ -} - -/* Going from compiled code to interpreted code */ - -/* Tail recursion is handled in the following way: - if the return address is `return_to_interpreter', it is discarded, - and the two contiguous interpreter segments on the stack are - merged. - */ - -/* Apply interface: - calling an interpreted procedure (or unsafe primitive) - with a frame nslots long. - */ - -#define compiler_apply_procedure(nslots) \ -{ long frame_size = (nslots); \ - if (Stack_Ref( frame_size) == return_to_interpreter) \ - { \ - Close_Stack_Gap(1, frame_size, {}); \ - /* Set up the current rib. */ \ - Compiler_New_Reduction(); \ - } \ - else \ - { /* Make a new interpreter segment which includes this frame. */ \ - With_Stack_Gap(CONTINUATION_SIZE, \ - frame_size, \ - { long segment_size = Stack_Distance(last_return_code); \ - Store_Expression(Make_Unsigned_Fixnum(segment_size)); \ - Store_Return(RC_REENTER_COMPILED_CODE); \ - Save_Cont(); \ - }); \ - /* Rotate history to a new subproblem. */ \ - Compiler_New_Subproblem(); \ - } \ -} - -/* Pop Return interface: - returning to the interpreter from compiled code. - Nothing needs to be done at this time. - */ - -#define compiled_code_done() - -/* Various handlers for backing out of compiled code. */ - -/* Backing out of apply. */ - -#define apply_compiled_backout() \ -{ compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS + \ - Get_Integer( Stack_Ref( STACK_ENV_HEADER))); \ -} - -/* Backing out of eval. */ - -#define execute_compiled_backout() \ -{ if (Top_Of_Stack() == return_to_interpreter) \ - { \ - Simulate_Popping(1); \ - /* Set up the current rib. */ \ - Compiler_New_Reduction(); \ - } \ - else \ - { long segment_size = Stack_Distance(last_return_code); \ - Store_Expression(Make_Unsigned_Fixnum(segment_size)); \ - Store_Return(RC_REENTER_COMPILED_CODE); \ - Save_Cont(); \ - /* Rotate history to a new subproblem. */ \ - Compiler_New_Subproblem(); \ - } \ -} - -/* Backing out because of special errors or interrupts. - The microcode has already setup a return code with a NIL. - No tail recursion in this case. - *** - Is the history manipulation correct? - Does Microcode_Error do something special? - *** - */ - -#define compiled_error_backout() \ -{ long segment_size; \ - Restore_Cont(); \ - segment_size = Stack_Distance(last_return_code); \ - Store_Expression(Make_Unsigned_Fixnum(segment_size)); \ - /* The Store_Return is a NOP, the Save_Cont is done by the code \ - that follows. \ - */ \ - /* Store_Return(Datum(Fetch_Return())); */ \ - /* Save_Cont(); */ \ - Compiler_New_Subproblem(); \ -} diff --git a/v7/src/microcode/list.c b/v7/src/microcode/list.c deleted file mode 100644 index cdaacad24..000000000 --- a/v7/src/microcode/list.c +++ /dev/null @@ -1,300 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/list.c,v 9.23 1987/04/16 02:25:19 jinx Rel $ - * - * List creation and manipulation primitives. - */ - -#include "scheme.h" -#include "primitive.h" - -/* (CONS LEFT RIGHT) - Creates a pair with left component LEFT and right component - RIGHT. -*/ -Built_In_Primitive(Prim_Cons, 2, "CONS", 0x20) -{ - Primitive_2_Args(); - - Primitive_GC_If_Needed(2); - *Free++ = Arg1; - *Free++ = Arg2; - return Make_Pointer(TC_LIST, Free-2); -} - -/* (CDR PAIR) - Returns the second element in the pair. -*/ -Built_In_Primitive(Prim_Cdr, 1, "CDR", 0x22) -{ - Primitive_1_Arg(); - - Arg_1_Type(TC_LIST); - return Vector_Ref(Arg1, CONS_CDR); -} - -/* (CAR PAIR) - Returns the first element in the pair. -*/ -Built_In_Primitive(Prim_Car, 1, "CAR", 0x21) -{ - Primitive_1_Arg(); - - Arg_1_Type(TC_LIST); - return Vector_Ref(Arg1, CONS_CAR); -} - -/* (GENERAL-CAR-CDR LIST DIRECTIONS) - DIRECTIONS encodes a string of CAR and CDR operations to be - performed on LIST as follows: - 1 = NOP 101 = CDAR - 10 = CDR 110 = CADR - 11 = CAR 111 = CAAR - 100 = CDDR ... -*/ -Built_In_Primitive(Prim_General_Car_Cdr, 2, "GENERAL-CAR-CDR", 0x27) -{ - fast long CAR_CDR_Pattern; - Primitive_2_Args(); - - Arg_2_Type(TC_FIXNUM); - CAR_CDR_Pattern = Get_Integer(Arg2); - while (CAR_CDR_Pattern > 1) - { - Touch_In_Primitive(Arg1, Arg1); - if (Type_Code(Arg1) != TC_LIST) - Primitive_Error(ERR_ARG_1_WRONG_TYPE); - Arg1 = - Vector_Ref(Arg1, - ((CAR_CDR_Pattern & 1) == 0) ? CONS_CDR : CONS_CAR); - CAR_CDR_Pattern >>= 1; - } - return Arg1; -} - -/* (ASSQ ITEM A-LIST) - Searches the association list A-LIST for ITEM, using EQ? for - testing equality. Returns NIL if ITEM is not found, or the tail - of the list whose CAAR is ITEM. -*/ -Built_In_Primitive(Prim_Assq, 2, "ASSQ", 0x5E) -{ - Pointer This_Assoc_Pair, Key; - Primitive_2_Args(); - - Touch_In_Primitive(Arg1, Arg1); - Touch_In_Primitive(Arg2, Arg2); - while (Type_Code(Arg2) == TC_LIST) - { - Touch_In_Primitive(Vector_Ref(Arg2, CONS_CAR), This_Assoc_Pair); - if (Type_Code(This_Assoc_Pair) != TC_LIST) - Primitive_Error(ERR_ARG_2_WRONG_TYPE); - Touch_In_Primitive(Vector_Ref(This_Assoc_Pair, CONS_CAR), Key); - if (Key == Arg1) - return This_Assoc_Pair; - Touch_In_Primitive(Vector_Ref(Arg2, CONS_CDR), Arg2); - } - if (Arg2 != NIL) - Primitive_Error(ERR_ARG_2_WRONG_TYPE); - return NIL; -} - -/* (LENGTH LIST) - Returns the number of items in the list. - LENGTH will loop forever if given a circular structure. -*/ -Built_In_Primitive(Prim_Length, 1, "LENGTH", 0x5D) -{ - fast long i; - Primitive_1_Arg(); - - i = 0; - Touch_In_Primitive(Arg1, Arg1); - while (Type_Code(Arg1) == TC_LIST) - { - i += 1; - Touch_In_Primitive(Vector_Ref(Arg1, CONS_CDR), Arg1); - } - if (Arg1 != NIL) - Primitive_Error(ERR_ARG_1_WRONG_TYPE); - return Make_Unsigned_Fixnum(i); -} - -/* (MEMQ ITEM LIST) - Searches LIST for ITEM, using EQ? as a test. Returns NIL if it - is not found, or the sublist of LIST whose CAR is ITEM. -*/ -Built_In_Primitive(Prim_Memq, 2, "MEMQ", 0x1C) -{ - fast Pointer Key; - Primitive_2_Args(); - - Touch_In_Primitive(Arg1, Arg1); - Touch_In_Primitive(Arg2, Arg2); - while (Type_Code(Arg2) == TC_LIST) - { - Touch_In_Primitive(Vector_Ref(Arg2, CONS_CAR), Key); - if (Arg1 == Key) - return Arg2; - else - Touch_In_Primitive(Vector_Ref(Arg2, CONS_CDR), Arg2); - } - if (Arg2 != NIL) - Primitive_Error(ERR_ARG_2_WRONG_TYPE); - return NIL; -} - -/* (SET-CAR! PAIR VALUE) - Stores VALUE in the CAR of PAIR. Returns the previous CAR of PAIR. -*/ -Built_In_Primitive(Prim_Set_Car, 2, "SET-CAR!", 0x23) -{ - Primitive_2_Args(); - - Arg_1_Type(TC_LIST); - Side_Effect_Impurify(Arg1, Arg2); - return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CAR), Arg2); -} - -/* (SET-CDR! PAIR VALUE) - Stores VALUE in the CDR of PAIR. Returns the previous CDR of PAIR. -*/ -Built_In_Primitive(Prim_Set_Cdr, 2, "SET-CDR!", 0x24) -{ - Primitive_2_Args(); - - Arg_1_Type(TC_LIST); - Side_Effect_Impurify(Arg1, Arg2); - return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CDR), Arg2); -} - -/* (PAIR? OBJECT) - Returns #!TRUE if OBJECT has the type-code LIST (ie if it was - created by CONS). Returns NIL otherwise. -*/ -Built_In_Primitive(Prim_Pair, 1, "PAIR?", 0x7E) -{ - Primitive_1_Arg(); - - Touch_In_Primitive(Arg1, Arg1); - if (Type_Code(Arg1) == TC_LIST) - return TRUTH; - else - return NIL; -} - -/* (SYSTEM-PAIR? OBJECT) - Returns #!TRUE if the garbage collector type of OBJECT is PAIR. -*/ -Built_In_Primitive(Prim_Sys_Pair, 1, "SYSTEM-PAIR?", 0x85) -{ - Primitive_1_Arg(); - - Touch_In_Primitive(Arg1, Arg1); - if (GC_Type_List(Arg1)) - return TRUTH; - else - return NIL; -} - -/* (SYSTEM-PAIR-CAR GC-PAIR) - Same as CAR, but for anything of GC type PAIR. -*/ -Built_In_Primitive(Prim_Sys_Pair_Car, 1, "SYSTEM-PAIR-CAR", 0x86) -{ - Primitive_1_Arg(); - - Arg_1_GC_Type(GC_Pair); - return Vector_Ref(Arg1, CONS_CAR); -} - -/* (SYSTEM-PAIR-CDR GC-PAIR) - Same as CDR, but for anything of GC type PAIR. -*/ -Built_In_Primitive(Prim_Sys_Pair_Cdr, 1, "SYSTEM-PAIR-CDR", 0x87) -{ - Primitive_1_Arg(); - - Arg_1_GC_Type(GC_Pair); - return Vector_Ref(Arg1, CONS_CDR); -} - -/* (SYSTEM-PAIR-CONS TYPE-CODE OBJECT-1 OBJECT-2) - Like CONS, but returns an object with the specified type code - (not limited to type code LIST). -*/ -Built_In_Primitive(Prim_Sys_Pair_Cons, 3, "SYSTEM-PAIR-CONS", 0x84) -{ - long Type; - Primitive_3_Args(); - - Arg_1_Type(TC_FIXNUM); - Range_Check(Type, Arg1, 0, MAX_SAFE_TYPE, - ERR_ARG_1_BAD_RANGE); - if (GC_Type_Code(Type) == GC_Pair) - { - Primitive_GC_If_Needed(2); - *Free++ = Arg2; - *Free++ = Arg3; - return Make_Pointer(Type, Free-2); - } - else - Primitive_Error(ERR_ARG_1_BAD_RANGE); - /*NOTREACHED*/ -} - - -/* (SYSTEM-PAIR-SET-CAR! GC-PAIR NEW_CAR) - Same as SET-CAR!, but for anything of GC type PAIR. -*/ -Built_In_Primitive(Prim_Sys_Set_Car, 2, "SYSTEM-PAIR-SET-CAR!", 0x88) -{ - Primitive_2_Args(); - - Arg_1_GC_Type(GC_Pair); - Side_Effect_Impurify(Arg1, Arg2); - return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CAR), Arg2); -} - -/* (SYSTEM-PAIR-SET-CDR! GC-PAIR NEW_CDR) - Same as SET-CDR!, but for anything of GC type PAIR. -*/ -Built_In_Primitive(Prim_Sys_Set_Cdr, 2, "SYSTEM-PAIR-SET-CDR!", 0x89) -{ - Primitive_2_Args(); - - Arg_1_GC_Type(GC_Pair); - Side_Effect_Impurify(Arg1, Arg2); - return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CDR), Arg2); -} - diff --git a/v7/src/microcode/load.c b/v7/src/microcode/load.c deleted file mode 100644 index 6b7c2c34f..000000000 --- a/v7/src/microcode/load.c +++ /dev/null @@ -1,133 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/load.c,v 9.22 1987/04/16 02:25:31 jinx Exp $ - * - * This file contains common code for reading internal - * format binary files. - * - */ - -#include "fasl.h" - -/* Static storage for some shared variables */ - -long Heap_Count, Const_Count, - Version, Sub_Version, Machine_Type, Ext_Prim_Count, - Heap_Base, Const_Base, Dumped_Object, - Dumped_Heap_Top, Dumped_Constant_Top, Dumped_Stack_Top; -Pointer Ext_Prim_Vector; -Boolean Found_Ext_Prims, Byte_Invert_Fasl_Files; - -Boolean -Read_Header() -{ - Pointer Buffer[FASL_HEADER_LENGTH]; - Pointer Pointer_Heap_Base, Pointer_Const_Base; - - Load_Data(FASL_OLD_LENGTH, (char *) Buffer); - if (Buffer[FASL_Offset_Marker] != FASL_FILE_MARKER) - return false; -#ifdef BYTE_INVERSION - Byte_Invert_Header(Buffer, - (sizeof(Buffer) / sizeof(Pointer)), - Buffer[FASL_Offset_Heap_Base], - Buffer[FASL_Offset_Heap_Count]); -#endif - Heap_Count = Get_Integer(Buffer[FASL_Offset_Heap_Count]); - Pointer_Heap_Base = Buffer[FASL_Offset_Heap_Base]; - Heap_Base = Datum(Pointer_Heap_Base); - Dumped_Object = Datum(Buffer[FASL_Offset_Dumped_Obj]); - Const_Count = Get_Integer(Buffer[FASL_Offset_Const_Count]); - Pointer_Const_Base = Buffer[FASL_Offset_Const_Base]; - Const_Base = Datum(Pointer_Const_Base); - Version = The_Version(Buffer[FASL_Offset_Version]); - Sub_Version = The_Sub_Version(Buffer[FASL_Offset_Version]); - Machine_Type = The_Machine_Type(Buffer[FASL_Offset_Version]); - Dumped_Stack_Top = Get_Integer(Buffer[FASL_Offset_Stack_Top]); - Dumped_Heap_Top = - C_To_Scheme(Nth_Vector_Loc(Pointer_Heap_Base, Heap_Count)); - Dumped_Constant_Top = - C_To_Scheme(Nth_Vector_Loc(Pointer_Const_Base, Const_Count)); - Load_Data((FASL_HEADER_LENGTH - FASL_OLD_LENGTH), - ((char *) &(Buffer[FASL_OLD_LENGTH]))); -#ifdef BYTE_INVERSION - Byte_Invert_Region(((char *) &(Buffer[FASL_OLD_LENGTH])), - (FASL_HEADER_LENGTH - FASL_OLD_LENGTH)); -#endif - Ext_Prim_Vector = - Make_Non_Pointer(TC_CELL, Datum(Buffer[FASL_Offset_Ext_Loc])); - if (Reloc_or_Load_Debug) - { - printf("\nHeap_Count = %d; Heap_Base = %x; Dumped_Heap_Top = %x\n", - Heap_Count, Heap_Base, Dumped_Heap_Top); - printf("C_Count = %d; C_Base = %x, Dumped_C_Top = %x\n", - Const_Count, Const_Base, Dumped_Constant_Top); - printf("Dumped_S_Top = %x, Ext_Prim_Vector = 0x%08x\n", - Dumped_Stack_Top, Ext_Prim_Vector); - printf("Dumped Object (as read from file) = %x\n", Dumped_Object); - } - return true; -} - -#ifdef BYTE_INVERSION - -Byte_Invert_Header(Header, Headsize, Test1, Test2) - long *Header, Headsize, Test1, Test2; -{ - Byte_Invert_Fasl_Files = false; - - if ((Test1 & 0xff) == TC_BROKEN_HEART && - (Test2 & 0xff) == TC_BROKEN_HEART && - (Type_Code(Test1) != TC_BROKEN_HEART || - Type_Code(Test2) != TC_BROKEN_HEART)) - { - Byte_Invert_Fasl_Files = true; - Byte_Invert_Region(Header, Headsize); - } -} - -Byte_Invert_Region(Region, Size) - long *Region, Size; -{ - register long word, size; - - if (Byte_Invert_Fasl_Files) - for (size = Size; size > 0; size--, Region++) - { - word = (*Region); - *Region = (((word>>24)&0xff) | ((word>>8)&0xff00) | - ((word<<8)&0xff0000) | ((word<<24)&0xff000000)); - } -} - -#endif diff --git a/v7/src/microcode/locks.h b/v7/src/microcode/locks.h deleted file mode 100644 index c3fbf41d2..000000000 --- a/v7/src/microcode/locks.h +++ /dev/null @@ -1,47 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/locks.h,v 9.21 1987/01/22 14:28:42 jinx Rel $ - - Contains everything needed to lock and unlock parts of - the heap, pure/constant space and the like. - It also contains intercommunication stuff as well. */ - -#define Lock_Handle long * /* Address of lock word */ -#define CONTENTION_DELAY 10 /* For "slow" locks, back off */ -#define Lock_Cell(Cell) NULL /* Start lock */ -#define Unlock_Cell(Cell) /* End lock */ -#define Initialize_Heap_Locks() /* Clear at start up */ -#define Do_Store_No_Lock(To, F) *(To) = F -#define Sleep(How_Long) { } /* Delay for locks, etc. */ - - diff --git a/v7/src/microcode/lookup.h b/v7/src/microcode/lookup.h deleted file mode 100644 index 46c3ab9a7..000000000 --- a/v7/src/microcode/lookup.h +++ /dev/null @@ -1,252 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/lookup.h,v 9.36 1987/04/16 02:26:04 jinx Exp $ */ - -/* Macros and declarations for the variable lookup code. */ - -extern Pointer - *deep_lookup(), - *lookup_fluid(); - -extern long - deep_lookup_end(), - deep_assignment_end(); - -extern Pointer - unbound_trap_object[], - uncompiled_trap_object[], - illegal_trap_object[], - fake_variable_object[]; - -#define GC_allocate_test(N) GC_Check(N) - -#define AUX_LIST_TYPE TC_VECTOR - -#define AUX_CHUNK_SIZE 20 -#define AUX_LIST_COUNT ENV_EXTENSION_COUNT -#define AUX_LIST_FIRST ENV_EXTENSION_MIN_SIZE -#define AUX_LIST_INITIAL_SIZE (AUX_LIST_FIRST + AUX_CHUNK_SIZE) - -/* Variable compilation types. */ - -#define LOCAL_REF TC_NULL -#define GLOBAL_REF TC_UNINTERNED_SYMBOL -#define FORMAL_REF TC_CHARACTER -#define AUX_REF TC_FIXNUM -#define UNCOMPILED_REF TC_TRUE - -/* Common constants. */ - -#ifndef b32 -#define UNCOMPILED_VARIABLE Make_Non_Pointer(UNCOMPILED_REF, 0) -#else -#define UNCOMPILED_VARIABLE 0x08000000 -#endif - -/* Macros for speedy variable reference. */ - -#if (LOCAL_REF == 0) - -#define Lexical_Offset(Ind) ((long) (Ind)) -#define Make_Local_Offset(Ind) ((Pointer) (Ind)) - -#else - -#define Lexical_Offset(Ind) Get_Integer(Ind) -#define Make_Local_Offset(Ind) Make_Non_Pointer(LOCAL_REF, Ind) - -#endif - -/* The code below depends on the following. */ - -/* Done as follows because of VMS. */ - -#define lookup_inconsistency_p \ - ((VARIABLE_OFFSET == VARIABLE_COMPILED_TYPE) || \ - (VARIABLE_FRAME_NO != VARIABLE_COMPILED_TYPE)) - -#if (lookup_inconsistency_p) -#include "error: lookup.h inconsistency detected." -#endif - -#define get_offset(hunk) Lexical_Offset(Fetch(hunk[VARIABLE_OFFSET])) - -#ifdef PARALLEL_PROCESSOR - -#define verify(type_code, variable, code, label) \ -{ \ - variable = code; \ - if (Type_Code(Fetch(hunk[VARIABLE_COMPILED_TYPE])) != \ - type_code) \ - goto label; \ -} - -#define verified_offset(variable, code) variable - -/* Unlike Lock_Cell, cell must be (Pointer *). This currently does - not matter, but might on a machine with address mapping. - */ - -#define setup_lock(handle, cell) handle = Lock_Cell(cell) -#define remove_lock(handle) Unlock_Cell(handle) - -#else - -#define verify(type_code, variable, code, label) -#define verified_offset(variable, code) code -#define setup_lock(handle, cell) -#define remove_lock(ignore) - -#endif - -/* Pointer *cell, env, *hunk; */ - -#define lookup(cell, env, hunk, label) \ -{ \ - fast Pointer frame; \ - long offset; \ - \ -label: \ - \ - frame = Fetch(hunk[VARIABLE_COMPILED_TYPE]); \ - \ - switch (Type_Code(frame)) \ - { \ - case GLOBAL_REF: \ - /* frame is a pointer to the same symbol. */ \ - cell = Nth_Vector_Loc(frame, SYMBOL_GLOBAL_VALUE); \ - break; \ - \ - case LOCAL_REF: \ - cell = Nth_Vector_Loc(env, Lexical_Offset(frame)); \ - break; \ - \ - case FORMAL_REF: \ - lookup_formal(cell, env, hunk, label); \ - \ - case AUX_REF: \ - lookup_aux(cell, env, hunk, label); \ - \ - default: \ - /* Done here rather than in a separate case because of \ - peculiarities of the bobcat compiler. \ - */ \ - cell = ((Type_Code(frame) == UNCOMPILED_REF) ? \ - uncompiled_trap_object : \ - illegal_trap_object); \ - break; \ - } \ -} - -#define lookup_formal(cell, env, hunk, label) \ -{ \ - fast long depth; \ - \ - verify(FORMAL_REF, offset, get_offset(hunk), label); \ - depth = Get_Integer(frame); \ - frame = env; \ - while(--depth >= 0) \ - { \ - frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \ - PROCEDURE_ENVIRONMENT); \ - } \ - \ - cell = Nth_Vector_Loc(frame, \ - verified_offset(offset, get_offset(hunk))); \ - \ - break; \ -} - -#define lookup_aux(cell, env, hunk, label) \ -{ \ - fast long depth; \ - \ - verify(AUX_REF, offset, get_offset(hunk), label); \ - depth = Get_Integer(frame); \ - frame = env; \ - while(--depth >= 0) \ - { \ - frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \ - PROCEDURE_ENVIRONMENT); \ - } \ - \ - frame = Vector_Ref(frame, ENVIRONMENT_FUNCTION); \ - if (Type_Code(frame) != AUX_LIST_TYPE) \ - { \ - cell = uncompiled_trap_object; \ - break; \ - } \ - depth = verified_offset(offset, get_offset(hunk)); \ - if (depth > Vector_Length(frame)) \ - { \ - cell = uncompiled_trap_object; \ - break; \ - } \ - frame = Vector_Ref(frame, depth); \ - if ((frame == NIL) || \ - (Fast_Vector_Ref(frame, CONS_CAR) != hunk[VARIABLE_SYMBOL])) \ - { \ - cell = uncompiled_trap_object; \ - break; \ - } \ - cell = Nth_Vector_Loc(frame, CONS_CDR); \ - break; \ -} - -#define lookup_primitive_type_test() \ -{ \ - if (Type_Code(Arg1) != GLOBAL_ENV) Arg_1_Type(TC_ENVIRONMENT); \ - if (Type_Code(Arg2) != TC_INTERNED_SYMBOL) \ - Arg_2_Type(TC_UNINTERNED_SYMBOL); \ -} - -#define lookup_primitive_end(Result) \ -{ \ - if (Result == PRIM_DONE) \ - return Val; \ - if (Result == PRIM_INTERRUPT) \ - Primitive_Interrupt(); \ - Primitive_Error(Result); \ -} - -#define standard_lookup_primitive(action) \ -{ \ - long Result; \ - \ - lookup_primitive_type_test(); \ - Result = action; \ - lookup_primitive_end(Result); \ - /*NOTREACHED*/ \ -} - - diff --git a/v7/src/microcode/memmag.c b/v7/src/microcode/memmag.c deleted file mode 100644 index e5a6f4441..000000000 --- a/v7/src/microcode/memmag.c +++ /dev/null @@ -1,412 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.28 1987/04/16 02:26:14 jinx Exp $ */ - -/* Memory management top level. - - The memory management code is spread over 3 files: - - memmag.c: initialization. - - gcloop.c: main garbage collector loop. - - purify.c: constant/pure space hacking. - There is also a relevant header file, gccode.h. - - The object dumper, fasdump, shares properties and code with the - memory management utilities. - */ - -#include "scheme.h" -#include "primitive.h" -#include "gccode.h" - -/* Imports */ - -extern Pointer *GCLoop(); - -/* Exports */ - -extern void GCFlip(), GC(); -extern void Clear_Memory(), Setup_Memory(), Reset_Memory(); - -/* Memory Allocation, sequential processor: - - ------------------------------------------ - | Control Stack || | - | \/ | - ------------------------------------------ - | Constant + Pure Space /\ | - | || | - ------------------------------------------ - | | - | Heap Space | - ------------------------------------------ - - Each area has a pointer to its starting address and a pointer to the - next free cell. In addition, there is a pointer to the top of the - useable area of the heap (the heap is subdivided into two areas for - the purposes of GC, and this pointer indicates the top of the half - currently in use). - -*/ - -/* Initialize free pointers within areas. Stack_Pointer is - special: it always points to a cell which is in use. */ - -void -Clear_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size) - int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size; -{ - Heap_Top = Heap_Bottom + Our_Heap_Size; - Local_Heap_Base = Heap_Bottom; - Unused_Heap_Top = Heap_Bottom + 2*Our_Heap_Size; - Set_Mem_Top(Heap_Top - GC_Reserve); - Free = Heap_Bottom; - Free_Constant = Constant_Space; - Set_Pure_Top(); - Initialize_Stack(); - return; -} - -/* This procedure allocates and divides the total memory. */ - -void -Setup_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size) - int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size; -{ - /* Consistency check 1 */ - if (Our_Heap_Size == 0) - { - fprintf(stderr, "Configuration won't hold initial data.\n"); - exit(1); - } - - /* Allocate */ - Highest_Allocated_Address = - Allocate_Heap_Space(Stack_Allocation_Size(Our_Stack_Size) + - (2 * Our_Heap_Size) + - Our_Constant_Size + - HEAP_BUFFER_SPACE); - - /* Consistency check 2 */ - if (Heap == NULL) - { - fprintf(stderr, "Not enough memory for this configuration.\n"); - exit(1); - } - - /* Initialize the various global parameters */ - Heap += HEAP_BUFFER_SPACE; - Initial_Align_Float(Heap); - Unused_Heap = Heap + Our_Heap_Size; - Align_Float(Unused_Heap); - Constant_Space = Heap + 2*Our_Heap_Size; - Align_Float(Constant_Space); - - /* Consistency check 3 */ - if (((C_To_Scheme(Highest_Allocated_Address)) & TYPE_CODE_MASK) != 0) - { - fprintf(stderr, - "Largest address does not fit in datum field of Pointer.\n"); - fprintf(stderr, - "Allocate less space or re-compile without Heap_In_Low_Memory.\n"); - exit(1); - } - - Heap_Bottom = Heap; - Clear_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size); - return; -} - -/* In this version, this does nothing. */ - -void -Reset_Memory() -{ - return; -} - -/* Utilities for the garbage collector top level. - The main garbage collector loop is in gcloop.c -*/ - -/* Flip into unused heap */ - -void -GCFlip() -{ - Pointer *Temp; - - Temp = Unused_Heap; - Unused_Heap = Heap_Bottom; - Heap_Bottom = Temp; - Temp = Unused_Heap_Top; - Unused_Heap_Top = Heap_Top; - Heap_Top = Temp; - Free = Heap_Bottom; - Set_Mem_Top(Heap_Top - GC_Reserve); - Weak_Chain = NIL; - return; -} - -/* Here is the code which "prunes" objects from weak cons cells. See - the picture in gccode.h for a description of the structure built by - the GC. This code follows the chain of weak cells (in old space) and - either updates the new copy's CAR with the relocated version of the - object, or replaces it with NIL. - - Note that this is the only code in the system, besides the inner garbage - collector, which looks at both old and new space. -*/ - -Pointer Weak_Chain; - -void -Fix_Weak_Chain() -{ - fast Pointer *Old_Weak_Cell, *Scan, Old_Car, Temp, *Old, *Low_Constant; - - Low_Constant = Constant_Space; - while (Weak_Chain != NIL) - { - Old_Weak_Cell = Get_Pointer(Weak_Chain); - Scan = Get_Pointer(*Old_Weak_Cell++); - Weak_Chain = *Old_Weak_Cell; - Old_Car = *Scan; - Temp = Make_New_Pointer(Type_Code(Weak_Chain), Old_Car); - Weak_Chain = Make_New_Pointer(TC_NULL, Weak_Chain); - - switch(GC_Type(Temp)) - { case GC_Non_Pointer: - *Scan = Temp; - continue; - - case GC_Special: - if (Type_Code(Temp) != TC_REFERENCE_TRAP) - { - /* No other special type makes sense here. */ - goto fail; - } - if (Datum(Temp) <= TRAP_MAX_IMMEDIATE) - { - *Scan = Temp; - continue; - } - /* Otherwise, it is a pointer. Fall through */ - - /* Normal pointer types, the broken heart is in the first word. - Note that most special types are treated normally here. - The BH code updates *Scan if the object has been relocated. - Otherwise it falls through and we replace it with a full NIL. - Eliminating this assignment would keep old data (pl. of datum). - */ - case GC_Cell: - case GC_Pair: - case GC_Triple: - case GC_Quadruple: - case GC_Vector: - Old = Get_Pointer(Old_Car); - if (Old >= Low_Constant) - { - *Scan = Temp; - continue; - } - Normal_BH(false, continue); - *Scan = NIL; - continue; - - case GC_Compiled: - Old = Get_Pointer(Old_Car); - if (Old >= Low_Constant) - { - *Scan = Temp; - continue; - } - Compiled_BH(false, continue); - *Scan = NIL; - continue; - - case GC_Undefined: - default: /* Non Marked Headers and Broken Hearts */ - fail: - fprintf(stderr, - "\nFix_Weak_Chain: Bad Object: Type = 0x%02x; Datum = %x\n", - Type_Code(Temp), Datum(Temp)); - Microcode_Termination(TERM_INVALID_TYPE_CODE); - } - } - return; -} - -/* Here is the set up for the full garbage collection: - - - First it makes the constant space and stack into one large area - by "hiding" the gap between them with a non-marked header. - - - Then it saves away all the relevant microcode registers into new - space, making this the root for garbage collection. - - - Then it does the actual garbage collection in 4 steps: - 1) Trace constant space. - 2) Trace objects pointed out by the root and constant space. - 3) Trace the precious objects, remembering where consing started. - 4) Update all weak pointers. - - - Finally it restores the microcode registers from the copies in - new space. -*/ - -void GC() -{ Pointer *Root, *Result, *Check_Value, - The_Precious_Objects, *Root2; - - /* Save the microcode registers so that they can be relocated */ - Terminate_Old_Stacklet(); - Terminate_Constant_Space(Check_Value); - - Root = Free; - The_Precious_Objects = Get_Fixed_Obj_Slot(Precious_Objects); - Set_Fixed_Obj_Slot(Precious_Objects, NIL); - Set_Fixed_Obj_Slot(Lost_Objects_Base, NIL); - - *Free++ = Fixed_Objects; - *Free++ = Make_Pointer(TC_HUNK3, History); - *Free++ = Undefined_Externals; - *Free++ = Get_Current_Stacklet(); - *Free++ = ((Prev_Restore_History_Stacklet == NULL) ? - NIL : - Make_Pointer(TC_CONTROL_POINT, Prev_Restore_History_Stacklet)); - *Free++ = Current_State_Point; - *Free++ = Fluid_Bindings; - - /* The 4 step GC */ - Result = GCLoop(Constant_Space, &Free); - if (Result != Check_Value) - { - fprintf(stderr, "\nGC: Constant Scan ended too early.\n"); - Microcode_Termination(TERM_BROKEN_HEART); - } - Result = GCLoop(Root, &Free); - if (Free != Result) - { - fprintf(stderr, "\nGC-1: Heap Scan ended too early.\n"); - Microcode_Termination(TERM_BROKEN_HEART); - } - Root2 = Free; - *Free++ = The_Precious_Objects; - Result = GCLoop(Root2, &Free); - if (Free != Result) - { - fprintf(stderr, "\nGC-2: Heap Scan ended too early.\n"); - Microcode_Termination(TERM_BROKEN_HEART); - } - Fix_Weak_Chain(); - - /* Make the microcode registers point to the copies in new-space. */ - Fixed_Objects = *Root++; - Set_Fixed_Obj_Slot(Precious_Objects, *Root2); - Set_Fixed_Obj_Slot(Lost_Objects_Base, Make_Pointer(TC_ADDRESS, Root2)); - - History = Get_Pointer(*Root++); - Undefined_Externals = *Root++; - Set_Current_Stacklet(*Root); - Root += 1; /* Set_Current_Stacklet is sometimes a No-Op! */ - if (*Root == NIL) - { - Prev_Restore_History_Stacklet = NULL; - Root += 1; - } - else - Prev_Restore_History_Stacklet = Get_Pointer(*Root++); - Current_State_Point = *Root++; - Fluid_Bindings = *Root++; - Free_Stacklets = NULL; - return; -} - -/* (GARBAGE-COLLECT SLACK) - Requests a garbage collection leaving the specified amount of slack - for the top of heap check on the next GC. The primitive ends by invoking - the GC daemon if there is one. - - This primitive never returns normally. It always escapes into - the interpreter because some of its cached registers (eg. History) - have changed. -*/ - -Built_In_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT", 0x3A) -{ - Pointer GC_Daemon_Proc; - Primitive_1_Arg(); - - Arg_1_Type(TC_FIXNUM); - if (Free > Heap_Top) - { - fprintf(stderr, - "\nGC has been delayed too long, and you are out of room!\n"); - fprintf(stderr, - "Free = 0x%x; MemTop = 0x%x; Heap_Top = 0x%x\n", - Free, MemTop, Heap_Top); - Microcode_Termination(TERM_NO_SPACE); - } - GC_Reserve = Get_Integer(Arg1); - GCFlip(); - GC(); - IntCode &= ~INT_GC; - if (GC_Check(GC_Space_Needed)) - { - fprintf(stderr, - "\nGC just ended. The free pointer is at 0x%x, the top of this heap\n", - Free); - fprintf(stderr, - "is at 0x%x, and we are trying to cons 0x%x objects. Dead!\n", - MemTop, GC_Space_Needed); - Microcode_Termination(TERM_NO_SPACE); - } - Pop_Primitive_Frame(1); - GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon); - if (GC_Daemon_Proc == NIL) - { - Val = Make_Unsigned_Fixnum(MemTop - Free); - longjmp( *Back_To_Eval, PRIM_POP_RETURN); - /*NOTREACHED*/ - } - Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+1)); - Store_Return(RC_NORMAL_GC_DONE); - Store_Expression(Make_Unsigned_Fixnum(MemTop - Free)); - Save_Cont(); - Push(GC_Daemon_Proc); - Push(STACK_FRAME_HEADER); - Pushed(); - longjmp(*Back_To_Eval, PRIM_APPLY); - /* The following comment is by courtesy of LINT, your friendly sponsor. */ - /*NOTREACHED*/ -} diff --git a/v7/src/microcode/missing.c b/v7/src/microcode/missing.c deleted file mode 100644 index 015c09fb3..000000000 --- a/v7/src/microcode/missing.c +++ /dev/null @@ -1,150 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/missing.c,v 9.21 1987/01/22 14:29:02 jinx Rel $ - * This file contains utilities potentially missing from the math library - */ - -#ifdef DEBUG_MISSING -#include "config.h" -#endif - -static Boolean floating_table_initialized = false; -static double floating_table[(2*FLONUM_EXPT_SIZE)-1]; -static int exponent_table[(2*FLONUM_EXPT_SIZE)-1]; - -void initialize_floating_table() -{ register int index, exponent; - register int *int_table = &exponent_table[FLONUM_EXPT_SIZE-1]; - register double *the_table = &floating_table[FLONUM_EXPT_SIZE-1]; - register double x; - the_table[0] = 1.0; - int_table[0] = 0; - for (x = 2.0, index = 1, exponent = 1; - index < FLONUM_EXPT_SIZE; - x *= x, index += 1, exponent += exponent) - { the_table[index] = x; - int_table[index] = exponent; - } - for (x = 0.5, index = -1, exponent = -1; - index > -FLONUM_EXPT_SIZE; - x *= x, index -= 1, exponent += exponent) - { the_table[index] = x; - int_table[index] = exponent; - } - floating_table_initialized = true; - return; -} - -double frexp(value, eptr) -double value; -int *eptr; -{ register double mant; - register int exponent, index; - register double *the_table = &floating_table[FLONUM_EXPT_SIZE-1]; - register int *int_table = &exponent_table[FLONUM_EXPT_SIZE-1]; - - if (value == 0.0) - { *eptr = 0; - return 0.0; - } - if (!floating_table_initialized) initialize_floating_table(); - mant = ((value < 0.0) ? -value : value); - exponent = 0; - while (mant < 0.5) - { for (index = -FLONUM_EXPT_SIZE+1; - the_table[index] < mant; - index += 1) ; - exponent += int_table[index]; - mant /= the_table[index]; - } - if (mant >= 1.0) - { while (mant >= 2.0) - { for (index = FLONUM_EXPT_SIZE-1; - the_table[index] > mant; - index -= 1) ; - exponent += int_table[index]; - mant /= the_table[index]; - } - mant /= 2.0; - exponent += 1; - } - *eptr = exponent; - return ((value < 0.0) ? -mant : mant); -} - -double ldexp(value, exponent) -register double value; -register int exponent; -{ register int index; - register double *the_table = &floating_table[FLONUM_EXPT_SIZE-1]; - register int *int_table = &exponent_table[FLONUM_EXPT_SIZE-1]; - - if (value == 0.0) return 0.0; - if (!floating_table_initialized) initialize_floating_table(); - while (exponent > 0) - { for(index = FLONUM_EXPT_SIZE-1; - int_table[index] > exponent; - index -= 1) ; - exponent -= int_table[index]; - value *= the_table[index]; - } - while (exponent < 0) - { for(index = -FLONUM_EXPT_SIZE+1; - int_table[index] < exponent; - index += 1) ; - exponent -= int_table[index]; - value *= the_table[index]; - } - return value; -} - - -#ifdef DEBUG_MISSING - -#include - -main() -{ double input, output; - int exponent; - - while (true) - { printf("Number -> "); - scanf("%F", &input); - output = frexp(input, &exponent); - printf("Input = %G; Output = %G; Exponent = %d\n", - input, output, exponent); - printf("Result = %G\n", ldexp(output, exponent)); - } -} -#endif - diff --git a/v7/src/microcode/mul.c b/v7/src/microcode/mul.c deleted file mode 100644 index f48d76c37..000000000 --- a/v7/src/microcode/mul.c +++ /dev/null @@ -1,81 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/mul.c,v 9.22 1987/04/16 02:26:41 jinx Rel $ - * - * This file contains the portable fixnum multiplication procedure. - * Returns NIL if the result does not fit in a fixnum. - * Note: This has only been tried on machines with long = 32 bits. - * This file is included in the appropriate os file if needed. - */ - -#define HALF_WORD_SIZE ((sizeof(long)*CHAR_SIZE)/2) -#define HALF_WORD_MASK (1<> HALF_WORD_SIZE) & HALF_WORD_MASK); - Hi_B = ((B >> HALF_WORD_SIZE) & HALF_WORD_MASK); - Lo_A = (A & HALF_WORD_MASK); - Lo_B = (B & HALF_WORD_MASK); - Lo_C = (Lo_A * Lo_B); - if (Lo_C > FIXNUM_SIGN_BIT) - return NIL; - Middle_C = (Lo_A * Hi_B) + (Hi_A * Lo_B); - if (Middle_C >= MAX_MIDDLE) - return NIL; - if ((Hi_A > 0) && (Hi_B > 0)) - return NIL; - C = Lo_C + (Middle_C << HALF_WORD_SIZE); - if (Fixnum_Fits(C)) - { - if (Sign || (C == 0)) - return Make_Unsigned_Fixnum(C); - else - return Make_Unsigned_Fixnum(MAX_FIXNUM - C); - } - return NIL; -} diff --git a/v7/src/microcode/object.h b/v7/src/microcode/object.h deleted file mode 100644 index 938fdcd00..000000000 --- a/v7/src/microcode/object.h +++ /dev/null @@ -1,244 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/object.h,v 9.22 1987/04/16 02:27:09 jinx Exp $ */ - -/* This file contains definitions pertaining to the C view of - Scheme pointers: widths of fields, extraction macros, pre-computed - extraction masks, etc. */ - -/* The C type Pointer is defined at the end of CONFIG.H - The definition of POINTER_LENGTH here assumes that Pointer is the same - as unsigned long. If that ever changes, this definition must also. - POINTER_LENGTH is defined this way to make it available to - the preprocessor. */ - -#define POINTER_LENGTH ULONG_SIZE -#define TYPE_CODE_LENGTH 8 /* Not CHAR_SIZE!! */ -#define MAX_TYPE_CODE 0xFF /* ((1<> ADDRESS_LENGTH) & MAX_TYPE_CODE) -#define safe_pointer_type(P) (((P) >> ADDRESS_LENGTH) & SAFE_TYPE_MASK) -#else /* Faster for logical shifts */ -#define pointer_type(P) ((P) >> ADDRESS_LENGTH) -#define safe_pointer_type(P) ((pointer_type (P)) & SAFE_TYPE_MASK) -#endif - -#define pointer_datum(P) ((P) & ADDRESS_MASK) - -/* compatibility definitions */ -#define Type_Code(P) (pointer_type (P)) -#define Safe_Type_Code(P) (safe_pointer_type (P)) -#define Datum(P) (pointer_datum (P)) - -#define Make_Object(TC, D) \ -((((unsigned) (TC)) << ADDRESS_LENGTH) | (pointer_datum (D))) - -#ifndef Heap_In_Low_Memory /* Safe version */ - -typedef Pointer *relocation_type; /* Used to relocate pointers on fasload */ - -extern Pointer *Memory_Base; - -/* The "-1" in the value returned is a guarantee that there is one - word reserved exclusively for use by the garbage collector. */ - -#define Allocate_Heap_Space(space) \ - (Memory_Base = ((Pointer *) (malloc ((sizeof (Pointer)) * (space)))), \ - Heap = Memory_Base, \ - ((Memory_Base + (space)) - 1)) - -#define Get_Pointer(P) ((Pointer *) (Memory_Base + (pointer_datum (P)))) -#define C_To_Scheme(P) ((Pointer) ((P) - Memory_Base)) - -#else /* Storing absolute addresses */ - -typedef long relocation_type; /* Used to relocate pointers on fasload */ - -#define Allocate_Heap_Space(space) \ - (Heap = ((Pointer *) (malloc ((sizeof (Pointer)) * (space)))), \ - ((Heap + (space)) - 1)) - -#ifdef spectrum - -#define Quad1_Tag 0x40000000 -#define Get_Pointer(P) ((Pointer *) (((P) & ADDRESS_MASK) | Quad1_Tag)) -#define C_To_Scheme(P) ((Pointer) (((long) (P)) & ADDRESS_MASK)) - -#else /* Not Spectrum, fast case */ - -#define Get_Pointer(P) ((Pointer *) (pointer_datum (P))) -#define C_To_Scheme(P) ((Pointer) (P)) - -#endif /* spectrum */ -#endif /* Heap_In_Low_Memory */ - -#define Make_Pointer(TC, A) Make_Object((TC), C_To_Scheme(A)) -#define Make_Non_Pointer(TC, D) Make_Object(TC, ((Pointer) (D))) - -/* (Make_New_Pointer (TC, A)) may be more efficient than - (Make_Pointer (TC, (Get_Pointer (A)))) */ - -#define Make_New_Pointer(TC, A) (Make_Object (TC, ((Pointer) A))) - -#define Store_Type_Code(P, TC) P = (Make_Object ((TC), (P))) - -#define Store_Address(P, A) \ - P = (((P) & TYPE_CODE_MASK) | (pointer_datum ((Pointer) (A)))) - -#define Address(P) (pointer_datum (P)) - -/* These are used only where the object is known to be immutable. - On a parallel processor they don't require atomic references */ - -#define Fast_Vector_Ref(P, N) ((Get_Pointer(P))[N]) -#define Fast_Vector_Set(P, N, S) Fast_Vector_Ref(P, N) = (S) -#define Fast_User_Vector_Ref(P, N) Fast_Vector_Ref(P, (N)+1) -#define Fast_User_Vector_Set(P, N, S) Fast_Vector_Set(P, (N)+1, S) -#define Nth_Vector_Loc(P, N) (&(Fast_Vector_Ref(P, N))) -#define Vector_Length(P) (Get_Integer(Fast_Vector_Ref((P), 0))) - -/* General case vector handling requires atomicity for parallel processors */ - -#define Vector_Ref(P, N) Fetch(Fast_Vector_Ref(P, N)) -#define Vector_Set(P, N, S) Store(Fast_Vector_Ref(P, N), S) -#define User_Vector_Ref(P, N) Vector_Ref(P, (N)+1) -#define User_Vector_Set(P, N, S) Vector_Set(P, (N)+1, S) - -#define Make_Broken_Heart(N) (BROKEN_HEART_ZERO + (N)) -#define Make_Unsigned_Fixnum(N) (FIXNUM_ZERO + (N)) -#define Make_Signed_Fixnum(N) Make_Non_Pointer( TC_FIXNUM, (N)) -#define fixnum_p(P) ((pointer_type (P)) == TC_FIXNUM) -#define Get_Float(P) (* ((double *) (Nth_Vector_Loc ((P), 1)))) -#define Get_Integer(P) (pointer_datum (P)) - -#define fixnum_negative_p(P) (((P) & FIXNUM_SIGN_BIT) != 0) - -#define Sign_Extend(P, S) \ -{ \ - (S) = (Get_Integer (P)); \ - if (((S) & FIXNUM_SIGN_BIT) != 0) \ - (S) |= (-1 << ADDRESS_LENGTH); \ -} - -#define Fixnum_Fits(x) \ - ((((x) & SIGN_MASK) == 0) || \ - (((x) & SIGN_MASK) == SIGN_MASK)) - -/* Playing with the danger bit */ - -#define Without_Danger_Bit(P) ((P) & (~DANGER_BIT)) -#define Dangerous(P) ((P & DANGER_BIT) != 0) -#define Clear_Danger_Bit(P) P &= ~DANGER_BIT -#define Set_Danger_Bit(P) P |= DANGER_BIT -/* Side effect testing */ - -#define Is_Constant(address) \ - (((address) >= Constant_Space) && ((address) < Free_Constant)) - -#define Is_Pure(address) \ - ((Is_Constant (address)) && (Pure_Test (address))) - -#define Side_Effect_Impurify(Old_Pointer, Will_Contain) \ -if ((Is_Constant (Get_Pointer (Old_Pointer))) && \ - (GC_Type (Will_Contain) != GC_Non_Pointer) && \ - (! (Is_Constant (Get_Pointer (Will_Contain)))) && \ - (Pure_Test (Get_Pointer (Old_Pointer)))) \ - Primitive_Error (ERR_WRITE_INTO_PURE_SPACE); - -#ifdef FLOATING_ALIGNMENT - -#define FLOATING_BUFFER_SPACE \ - ((FLOATING_ALIGNMENT + 1)/sizeof(Pointer)) - -#define HEAP_BUFFER_SPACE \ - (TRAP_MAX_IMMEDIATE + 1 + FLOATING_BUFFER_SPACE) - -/* The space is there, find the correct position. */ - -#define Initial_Align_Float(Where) \ -{ \ - while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \ - Where -= 1; \ -} - -#define Align_Float(Where) \ -{ \ - while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \ - *Where++ = (Make_Non_Pointer (TC_MANIFEST_NM_VECTOR, 0)); \ -} - -#else not FLOATING_ALIGNMENT - -#define HEAP_BUFFER_SPACE (TRAP_MAX_IMMEDIATE + 1) - -#define Initial_Align_Float(Where) -#define Align_Float(Where) - -#endif FLOATING_ALIGNMENT diff --git a/v7/src/microcode/pagesize.h b/v7/src/microcode/pagesize.h deleted file mode 100644 index 32adae61e..000000000 --- a/v7/src/microcode/pagesize.h +++ /dev/null @@ -1,25 +0,0 @@ -#ifdef BSD -#ifndef BSD4_1 -#define HAVE_GETPAGESIZE -#endif -#endif - -#ifndef HAVE_GETPAGESIZE - -#include - -#ifdef EXEC_PAGESIZE -#define getpagesize() EXEC_PAGESIZE -#else -#ifdef NBPG -#define getpagesize() NBPG * CLSIZE -#ifndef CLSIZE -#define CLSIZE 1 -#endif /* no CLSIZE */ -#else /* no NBPG */ -#define getpagesize() NBPC -#endif /* no NBPG */ -#endif /* no EXEC_PAGESIZE */ - -#endif /* not HAVE_GETPAGESIZE */ - diff --git a/v7/src/microcode/ppband.c b/v7/src/microcode/ppband.c deleted file mode 100644 index f1d1d3b86..000000000 --- a/v7/src/microcode/ppband.c +++ /dev/null @@ -1,268 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/ppband.c,v 9.24 1987/04/03 00:06:29 jinx Exp $ - * - * Dumps Scheme FASL in user-readable form . - */ - -#include "scheme.h" - -/* These are needed by load.c */ - -static Pointer *Memory_Base; - -#define Load_Data(Count,To_Where) \ - fread(To_Where, sizeof(Pointer), Count, stdin) - -#define Reloc_or_Load_Debug true - -#include "load.c" -#include "gctype.c" - -#ifdef Heap_In_Low_Memory -#ifdef spectrum -#define File_To_Pointer(P) ((((long) (P))&ADDRESS_MASK) / sizeof(Pointer)) -#else -#define File_To_Pointer(P) ((P) / sizeof(Pointer)) -#endif /* spectrum */ -#else -#define File_To_Pointer(P) (P) -#endif - -#ifndef Conditional_Bug -#define Relocate(P) \ - (((long) (P) < Const_Base) ? \ - File_To_Pointer(((long) (P)) - Heap_Base) : \ - (Heap_Count+File_To_Pointer(((long) (P)) - Const_Base))) -#else -#define Relocate_Into(What, P) -if (((long) (P)) < Const_Base) - (What) = File_To_Pointer(((long) (P)) - Heap_Base); -else - (What) = Heap_Count + File_To_Pointer(((long) P) - Const_Base); - -static long Relocate_Temp; -#define Relocate(P) (Relocate_Into(Relocate_Temp, P), Relocate_Temp) -#endif - -static Pointer *Data, *end_of_memory; - -Boolean -scheme_string(From, Quoted) -long From; -Boolean Quoted; -{ fast long i, Count; - fast char *Chars; - Chars = (char *) &Data[From+STRING_CHARS]; - if (Chars < ((char *) end_of_memory)) - { Count = Get_Integer(Data[From+STRING_LENGTH]); - if (&Chars[Count] < ((char *) end_of_memory)) - { putchar(Quoted ? '\"' : '\''); - for (i=0; i < Count; i++) printf("%c", *Chars++); - if (Quoted) putchar('\"'); - putchar('\n'); - return true; - } - } - if (Quoted) - printf("String not in memory; datum = %x\n", From); - return false; -} - -#define via(File_Address) Relocate(Address(Data[File_Address])) - -void -scheme_symbol(From) -long From; -{ Pointer *symbol; - symbol = &Data[From+SYMBOL_NAME]; - if ((symbol >= end_of_memory) || - !scheme_string(via(From+SYMBOL_NAME), false)) - printf("symbol not in memory; datum = %x\n", From); - return; -} - -Display(Location, Type, The_Datum) -long Location, Type, The_Datum; -{ long Points_To; - printf("%5x: %2x|%6x ", Location, Type, The_Datum); - if (GC_Type_Map[Type & MAX_SAFE_TYPE] != GC_Non_Pointer) - Points_To = Relocate((Pointer *) The_Datum); - else - Points_To = The_Datum; - if (Type > MAX_SAFE_TYPE) printf("*"); - switch (Type & SAFE_TYPE_MASK) - { /* "Strange" cases */ - case TC_NULL: if (The_Datum == 0) - { printf("NIL\n"); - return; - } - else printf("[NULL "); - break; - case TC_TRUE: if (The_Datum == 0) - { printf("TRUE\n"); - return; - } - else printf("[TRUE "); - break; - case TC_BROKEN_HEART: printf("[BROKEN-HEART "); - if (The_Datum == 0) - Points_To = 0; - break; - case TC_MANIFEST_SPECIAL_NM_VECTOR: printf("[MANIFEST-SPECIAL-NM "); - Points_To = The_Datum; - break; - case TC_MANIFEST_NM_VECTOR: printf("[MANIFEST-NM-VECTOR "); - Points_To = The_Datum; - break; - case TC_INTERNED_SYMBOL: scheme_symbol(Points_To); - return; - case TC_UNINTERNED_SYMBOL: - printf("uninterned "); - scheme_symbol(Points_To); - return; - case TC_CHARACTER_STRING: scheme_string(Points_To, true); - return; - case TC_FIXNUM: printf("%d\n", Points_To); - return; - - /* Default cases */ - case TC_LIST: printf("[LIST "); break; - case TC_CHARACTER: printf("[CHARACTER "); break; - case TC_SCODE_QUOTE: printf("[SCODE-QUOTE "); break; - case TC_PCOMB2: printf("[PCOMB2 "); break; - case TC_BIG_FLONUM: printf("[BIG-FLONUM "); break; - case TC_COMBINATION_1: printf("[COMBINATION-1 "); break; - case TC_EXTENDED_PROCEDURE: printf("[EXTENDED-PROCEDURE "); break; - case TC_VECTOR: printf("[VECTOR "); break; - case TC_RETURN_CODE: printf("[RETURN-CODE "); break; - case TC_COMBINATION_2: printf("[COMBINATION-2 "); break; - case TC_COMPILED_PROCEDURE: printf("[COMPILED-PROCEDURE "); break; - case TC_BIG_FIXNUM: printf("[BIG-FIXNUM "); break; - case TC_PROCEDURE: printf("[PROCEDURE "); break; - case TC_PRIMITIVE_EXTERNAL: printf("[PRIMITIVE-EXTERNAL "); break; - case TC_DELAY: printf("[DELAY "); break; - case TC_ENVIRONMENT: printf("[ENVIRONMENT "); break; - case TC_DELAYED: printf("[DELAYED "); break; - case TC_EXTENDED_LAMBDA: printf("[EXTENDED-LAMBDA "); break; - case TC_COMMENT: printf("[COMMENT "); break; - case TC_NON_MARKED_VECTOR: printf("[NON-MARKED-VECTOR "); break; - case TC_LAMBDA: printf("[LAMBDA "); break; - case TC_PRIMITIVE: printf("[PRIMITIVE "); break; - case TC_SEQUENCE_2: printf("[SEQUENCE-2 "); break; - case TC_PCOMB1: printf("[PCOMB1 "); break; - case TC_CONTROL_POINT: printf("[CONTROL-POINT "); break; - case TC_ACCESS: printf("[ACCESS "); break; - case TC_DEFINITION: printf("[DEFINITION "); break; - case TC_ASSIGNMENT: printf("[ASSIGNMENT "); break; - case TC_HUNK3: printf("[HUNK3 "); break; - case TC_IN_PACKAGE: printf("[IN-PACKAGE "); break; - case TC_COMBINATION: printf("[COMBINATION "); break; - case TC_COMPILED_EXPRESSION: printf("[COMPILED-EXPRESSION "); break; - case TC_LEXPR: printf("[LEXPR "); break; - case TC_PCOMB3: printf("[PCOMB3 "); break; - - case TC_VARIABLE: printf("[VARIABLE "); break; - case TC_THE_ENVIRONMENT: printf("[THE-ENVIRONMENT "); break; - case TC_FUTURE: printf("[FUTURE "); break; - case TC_VECTOR_1B: printf("[VECTOR-1B "); break; - case TC_PCOMB0: printf("[PCOMB0 "); break; - case TC_VECTOR_16B: printf("[VECTOR-16B "); break; - case TC_SEQUENCE_3: printf("[SEQUENCE-3 "); break; - case TC_CONDITIONAL: printf("[CONDITIONAL "); break; - case TC_DISJUNCTION: printf("[DISJUNCTION "); break; - case TC_CELL: printf("[CELL "); break; - case TC_WEAK_CONS: printf("[WEAK-CONS "); break; - case TC_REFERENCE_TRAP: printf("[REFERENCE-TRAP "); break; - case TC_RETURN_ADDRESS: printf("[RETURN-ADDRESS "); break; - case TC_COMPILER_LINK: printf("[COMPILER-LINK "); break; - case TC_STACK_ENVIRONMENT: printf("[STACK-ENVIRONMENT "); break; - case TC_COMPLEX: printf("[COMPLEX "); break; - case TC_QUAD: printf("[QUAD "); break; - default: printf("[02x%x ", Type); break; - } - printf("%x]\n", Points_To); -} - -main(argc, argv) -int argc; -char **argv; -{ Pointer *Next; - long i; - if (argc == 1) - { if (!Read_Header()) - { fprintf(stderr, "Input does not appear to be in FASL format.\n"); - exit(1); - } - printf("Dumped object at 0x%x\n", Relocate(Dumped_Object)); - if (Sub_Version >= FASL_LONG_HEADER) - printf("External primitives at 0x%x\n\n", Relocate(Ext_Prim_Vector)); - } - else - { Const_Count = 0; - sscanf(argv[1], "%x", &Heap_Base); - sscanf(argv[2], "%x", &Const_Base); - sscanf(argv[3], "%d", &Heap_Count); - printf("Heap Base = 0x%08x; Constant Base = 0x%08x; Heap Count = %d\n", - Heap_Base, Const_Base, Heap_Count); - } - Data = (Pointer *) malloc(sizeof(Pointer) * (Heap_Count + Const_Count)); - end_of_memory = &Data[Heap_Count + Const_Count]; - Load_Data(Heap_Count + Const_Count, Data); - printf("Heap contents\n\n"); - for (Next=Data, i=0; i < Heap_Count; Next++, i++) - if (Safe_Type_Code(*Next)==TC_MANIFEST_NM_VECTOR) - { long j, count = Get_Integer(*Next); - Display(i, Type_Code(*Next), Address(*Next)); - Next += 1; - for (j=0; j < count ; j++, Next++) - printf(" %02x%06x\n", - Type_Code(*Next), Address(*Next)); - i += count; - Next -= 1; - } - else Display(i, Type_Code(*Next), Address(*Next)); - printf("\n\nConstant space\n\n"); - for (; i < Heap_Count+Const_Count; Next++, i++) - if (Safe_Type_Code(*Next)==TC_MANIFEST_NM_VECTOR) - { long j, count = Get_Integer(*Next); - Display(i, Type_Code(*Next), Address(*Next)); - Next += 1; - for (j=0; j < count ; j++, Next++) - printf(" %02x%06x\n", - Type_Code(*Next), Address(*Next)); - i += count; - Next -= 1; - } - else Display(i, Type_Code(*Next), Address(*Next)); -} diff --git a/v7/src/microcode/prim.c b/v7/src/microcode/prim.c deleted file mode 100644 index 59eaae3bf..000000000 --- a/v7/src/microcode/prim.c +++ /dev/null @@ -1,293 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prim.c,v 9.25 1987/04/16 23:20:46 jinx Rel $ - * - * The leftovers ... primitives that don't seem to belong elsewhere. - * - */ - -#include "scheme.h" -#include "primitive.h" - -/* Random predicates: */ - -/* (NULL? OBJECT) - Returns #!TRUE if OBJECT is NIL. Otherwise returns NIL. This is - the primitive known as NOT, NIL?, and NULL? in Scheme. -*/ -Built_In_Primitive(Prim_Null, 1, "NULL?", 0xC) -{ - Primitive_1_Arg(); - - Touch_In_Primitive(Arg1, Arg1); - return (Arg1 == NIL) ? TRUTH : NIL; -} - -/* (EQ? OBJECT-1 OBJECT-2) - Returns #!TRUE if the two objects have the same type code - and datum. Returns NIL otherwise. -*/ -Built_In_Primitive(Prim_Eq, 2, "EQ?", 0xD) -{ - Primitive_2_Args(); - - if (Arg1 == Arg2) - return TRUTH; - Touch_In_Primitive(Arg1, Arg1); - Touch_In_Primitive(Arg2, Arg2); - return ((Arg1 == Arg2) ? TRUTH : NIL); -} - -/* Pointer manipulation */ - -/* (MAKE-NON-POINTER-OBJECT NUMBER) - Returns an (extended) fixnum with the same value as NUMBER. In - the CScheme interpreter this is basically a no-op, since fixnums - already store 24 bits. -*/ -Built_In_Primitive(Prim_Make_Non_Pointer, 1, - "MAKE-NON-POINTER-OBJECT", 0xB1) -{ - Primitive_1_Arg(); - - Arg_1_Type(TC_FIXNUM); - return Arg1; -} - -/* (PRIMITIVE-DATUM OBJECT) - Returns the datum part of OBJECT. -*/ -Built_In_Primitive(Prim_Primitive_Datum, 1, "PRIMITIVE-DATUM", 0xB0) -{ - Primitive_1_Arg(); - - return Make_New_Pointer(TC_ADDRESS, Arg1); -} - -/* (PRIMITIVE-TYPE OBJECT) - Returns the type code of OBJECT as a number. - Note: THE OBJECT IS TOUCHED FIRST. -*/ -Built_In_Primitive(Prim_Prim_Type, 1, "PRIMITIVE-TYPE", 0x10) -{ - Primitive_1_Arg(); - - Touch_In_Primitive(Arg1, Arg1); - return Make_Unsigned_Fixnum(Safe_Type_Code(Arg1)); -} - -/* (PRIMITIVE-GC-TYPE OBJECT) - Returns a fixnum indicating the GC type of the object. The object - is NOT touched first. -*/ - -Built_In_Primitive(Prim_Gc_Type, 1, "PRIMITIVE-GC-TYPE", 0xBC) -{ - Primitive_1_Arg(); - - return Make_Non_Pointer(TC_FIXNUM, GC_Type(Arg1)); -} - -/* (PRIMITIVE-TYPE? TYPE-CODE OBJECT) - Return #!TRUE if the type code of OBJECT is TYPE-CODE, NIL - otherwise. - Note: THE OBJECT IS TOUCHED FIRST. -*/ -Built_In_Primitive(Prim_Prim_Type_QM, 2, "PRIMITIVE-TYPE?", 0xF) -{ - Primitive_2_Args(); - - Arg_1_Type(TC_FIXNUM); - Touch_In_Primitive(Arg2, Arg2); - if (Type_Code(Arg2) == Get_Integer(Arg1)) - return TRUTH; - else - return NIL; -} - -/* (PRIMITIVE-SET-TYPE TYPE-CODE OBJECT) - Returns a new object with TYPE-CODE and the datum part of - OBJECT. - Note : IT TOUCHES ITS SECOND ARGUMENT (for completeness sake). - This is a "gc-safe" (paranoid) operation. -*/ - -Built_In_Primitive(Prim_Primitive_Set_Type, 2, "PRIMITIVE-SET-TYPE", 0x11) -{ - long New_GC_Type, New_Type; - Primitive_2_Args(); - - Arg_1_Type(TC_FIXNUM); - Range_Check(New_Type, Arg1, 0, MAX_SAFE_TYPE, ERR_ARG_1_BAD_RANGE); - Touch_In_Primitive(Arg2, Arg2); - New_GC_Type = GC_Type_Code(New_Type); - if ((GC_Type(Arg2) == New_GC_Type) || - (New_GC_Type == GC_Non_Pointer)) - return Make_New_Pointer(New_Type, Arg2); - else - Primitive_Error(ERR_ARG_1_BAD_RANGE); - /*NOTREACHED*/ -} - -/* Subprimitives. - Many primitives can be built out of these, and eventually should be. - These are extremely unsafe, since there is no consistency checking. - In particular, they are not gc-safe: You can screw yourself royally - by using them. -*/ - -/* (&MAKE-OBJECT TYPE-CODE OBJECT) - Makes a Scheme object whose datum field is the datum field of - OBJECT, and whose type code is TYPE-CODE. It does not touch. -*/ - -Built_In_Primitive(Prim_And_Make_Object, 2, "&MAKE-OBJECT", 0x8D) -{ - long New_Type; - Primitive_2_Args(); - - Arg_1_Type(TC_FIXNUM); - Range_Check(New_Type, Arg1, 0, MAX_SAFE_TYPE, ERR_ARG_1_BAD_RANGE); - return Make_New_Pointer(New_Type, Arg2); -} - -/* (SYSTEM-MEMORY-REF OBJECT INDEX) - Fetches the index'ed slot in object. - Performs no type checking in object. -*/ - -Built_In_Primitive(Prim_System_Memory_Ref, 2, "SYSTEM-MEMORY-REF", 0x195) -{ - Primitive_2_Args(); - - Arg_2_Type(TC_FIXNUM); - return Vector_Ref(Arg1, Get_Integer(Arg2)); -} - -/* (SYSTEM-MEMORY-SET! OBJECT INDEX VALUE) - Stores value in the index'ed slot in object. - Performs no type checking in object. -*/ - -Built_In_Primitive(Prim_System_Memory_Set, 3, "SYSTEM-MEMORY-SET!", 0x196) -{ - long index; - Primitive_3_Args(); - - Arg_2_Type(TC_FIXNUM); - index = Get_Integer(Arg2); - return Swap_Pointers(Nth_Vector_Loc(Arg1, index), Arg3); -} - -/* Playing with the danger bit */ - -/* (OBJECT-DANGEROUS? OBJECT) - Returns #!TRUE if OBJECT has the danger bit set, NIL otherwise. -*/ -Built_In_Primitive(Prim_Dangerous_QM, 1, "OBJECT-DANGEROUS?", 0x49) -{ - Primitive_1_Arg(); - - return (Dangerous(Arg1)) ? TRUTH : NIL; -} - -/* (MAKE-OBJECT-DANGEROUS OBJECT) - Returns OBJECT, but with the danger bit set. -*/ -Built_In_Primitive(Prim_Dangerize, 1, "MAKE-OBJECT-DANGEROUS", 0x48) -{ - Primitive_1_Arg(); - - return Set_Danger_Bit(Arg1); -} - -/* (MAKE-OBJECT-SAFE OBJECT) - Returns OBJECT with the danger bit cleared. This does not - side-effect the object, it merely returns a new (non-dangerous) - pointer to the same item. -*/ -Built_In_Primitive(Prim_Undangerize, 1, "MAKE-OBJECT-SAFE", 0x47) -{ - Primitive_1_Arg(); - - return Clear_Danger_Bit(Arg1); -} - -/* Cells */ - -/* (MAKE-CELL CONTENTS) - Creates a cell with contents CONTENTS. -*/ -Built_In_Primitive(Prim_Make_Cell, 1, "MAKE-CELL", 0x61) -{ - Primitive_1_Arg(); - - Primitive_GC_If_Needed(1); - *Free++ = Arg1; - return Make_Pointer(TC_CELL, Free-1); -} - -/* (CELL-CONTENTS CELL) - Returns the contents of the cell CELL. -*/ -Built_In_Primitive(Prim_Cell_Contents, 1, "CELL-CONTENTS", 0x62) -{ - Primitive_1_Arg(); - - Arg_1_Type(TC_CELL); - return(Vector_Ref(Arg1, CELL_CONTENTS)); -} - -/* (CELL? OBJECT) - Returns #!TRUE if OBJECT has type-code CELL, otherwise returns - NIL. -*/ -Built_In_Primitive(Prim_Cell, 1, "CELL?", 0x63) -{ - Primitive_1_Arg(); - - Touch_In_Primitive(Arg1,Arg1); - return (Type_Code(Arg1 == TC_CELL)) ? TRUTH : NIL; -} - -/* (SET-CELL-CONTENTS! CELL VALUE) - Stores VALUE as contents of CELL. Returns the previous contents of CELL. -*/ -Built_In_Primitive(Prim_Set_Cell_Contents, 2, "SET-CELL-CONTENTS!", 0x8C) -{ - Primitive_2_Args(); - - Arg_1_Type(TC_CELL); - Side_Effect_Impurify(Arg1, Arg2); - return Swap_Pointers(Nth_Vector_Loc(Arg1, CELL_CONTENTS), Arg2); -} diff --git a/v7/src/microcode/prim.h b/v7/src/microcode/prim.h deleted file mode 100644 index dd7b415d5..000000000 --- a/v7/src/microcode/prim.h +++ /dev/null @@ -1,62 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prim.h,v 9.36 1987/04/16 02:27:34 jinx Rel $ */ - -/* - Primitive declarations. - - Note that the following cannot be changed without changing - Findprim.c. -*/ - -extern Pointer (*(Primitive_Procedure_Table[]))(); -extern int Primitive_Arity_Table[]; -extern char *Primitive_Name_Table[]; -extern long MAX_PRIMITIVE; - -extern Pointer (*(External_Procedure_Table[]))(); -extern int External_Arity_Table[]; -extern char *External_Name_Table[]; -extern long MAX_EXTERNAL_PRIMITIVE; - -extern Pointer Undefined_Externals, Make_Prim_Exts(); - -/* Utility macros */ - -#define NUndefined() \ -((Undefined_Externals == NIL) ? \ - 0 : \ - Get_Integer(User_Vector_Ref(Undefined_Externals, 0))) - -#define CHUNK_SIZE 20 /* Grow undefined vector by this much */ - diff --git a/v7/src/microcode/prims.h b/v7/src/microcode/prims.h deleted file mode 100644 index 4d5af0011..000000000 --- a/v7/src/microcode/prims.h +++ /dev/null @@ -1,195 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prims.h,v 9.22 1987/04/16 02:27:43 jinx Exp $ */ - -/* This file contains some macros for defining primitives, - for argument type or value checking, and for accessing - the arguments. */ - -/* Definition of primitives. */ - -#define Define_Primitive(C_Name, Number_of_args, Scheme_Name) \ -extern Pointer C_Name(); \ -Pointer C_Name() - -#define Built_In_Primitive(C_Name, Number_of_args, Scheme_Name, index) \ -extern Pointer C_Name(); \ -Pointer C_Name() - -/* Preambles for primitive procedures. These store the arguments into - * local variables for fast access. - */ - -#define Primitive_0_Args() - -#define Primitive_1_Args() fast Pointer Arg1 = Stack_Ref(0) - -#define Primitive_2_Args() Primitive_1_Args(); \ - fast Pointer Arg2 = Stack_Ref(1) - -#define Primitive_3_Args() Primitive_2_Args(); \ - fast Pointer Arg3 = Stack_Ref(2) - -#define Primitive_4_Args() Primitive_3_Args(); \ - fast Pointer Arg4 = Stack_Ref(3) - -#define Primitive_5_Args() Primitive_4_Args(); \ - fast Pointer Arg5 = Stack_Ref(4) - -#define Primitive_6_Args() Primitive_5_Args(); \ - fast Pointer Arg6 = Stack_Ref(5) - -#define Primitive_7_Args() Primitive_6_Args(); \ - fast Pointer Arg7 = Stack_Ref(6) - -#define Primitive_1_Arg() Primitive_1_Args() - -/* Various utilities */ - -#define Primitive_Error(Err_No) \ -{ \ - signal_error_from_primitive (Err_No); \ -} - -#define Primitive_Interrupt() \ -{ \ - signal_interrupt_from_primitive (); \ -} - -#define Special_Primitive_Interrupt(Local_Mask) \ -{ \ - special_interrupt_from_primitive (Local_Mask); \ -} - -#define Primitive_GC(Amount) \ -{ \ - Request_GC (Amount); \ - Primitive_Interrupt (); \ -} - -#define Primitive_GC_If_Needed(Amount) \ -if (GC_Check (Amount)) Primitive_GC(Amount) - -#define Range_Check(To_Where, P, Low, High, Error) \ -{ \ - To_Where = Get_Integer (P); \ - if ((To_Where < (Low)) || (To_Where > (High))) \ - Primitive_Error (Error); \ -} - -#define Sign_Extend_Range_Check(To_Where, P, Low, High, Error) \ -{ \ - Sign_Extend ((P), To_Where); \ - if ((To_Where < (Low)) || (To_Where > (High))) \ - Primitive_Error (Error); \ -} - -#define Arg_1_Type(TC) \ -if ((pointer_type (Arg1)) != (TC)) error_wrong_type_arg_1 () - -#define Arg_2_Type(TC) \ -if ((pointer_type (Arg2)) != (TC)) error_wrong_type_arg_2 () - -#define Arg_3_Type(TC) \ -if ((pointer_type (Arg3)) != (TC)) error_wrong_type_arg_3 () - -#define Arg_4_Type(TC) \ -if ((pointer_type (Arg4)) != (TC)) error_wrong_type_arg_4 () - -#define Arg_5_Type(TC) \ -if ((pointer_type (Arg5)) != (TC)) error_wrong_type_arg_5 () - -#define Arg_6_Type(TC) \ -if ((pointer_type (Arg6)) != (TC)) error_wrong_type_arg_6 () - -#define Arg_7_Type(TC) \ -if ((pointer_type (Arg7)) != (TC)) error_wrong_type_arg_7 () - -#define Arg_8_Type(TC) \ -if ((pointer_type (Arg8)) != (TC)) error_wrong_type_arg_8 () - -#define Arg_9_Type(TC) \ -if ((pointer_type (Arg9)) != (TC)) error_wrong_type_arg_9 () - -#define Arg_10_Type(TC) \ -if ((pointer_type (Arg10)) != (TC)) error_wrong_type_arg_10 () - - -#define Arg_1_GC_Type(GCTC) \ -if ((GC_Type (Arg1)) != GCTC) error_wrong_type_arg_1 () - -#define Arg_2_GC_Type(GCTC) \ -if ((GC_Type (Arg2)) != GCTC) error_wrong_type_arg_2 () - -#define Arg_3_GC_Type(GCTC) \ -if ((GC_Type (Arg3)) != GCTC) error_wrong_type_arg_3 () - -#define guarantee_fixnum_arg_1() \ -if (! (fixnum_p (Arg1))) error_wrong_type_arg_1 () - -#define guarantee_fixnum_arg_2() \ -if (! (fixnum_p (Arg2))) error_wrong_type_arg_2 () - -#define guarantee_fixnum_arg_3() \ -if (! (fixnum_p (Arg3))) error_wrong_type_arg_3 () - -#define guarantee_fixnum_arg_4() \ -if (! (fixnum_p (Arg4))) error_wrong_type_arg_4 () - -#define guarantee_fixnum_arg_5() \ -if (! (fixnum_p (Arg5))) error_wrong_type_arg_5 () - -#define guarantee_fixnum_arg_6() \ -if (! (fixnum_p (Arg6))) error_wrong_type_arg_6 () - -extern long guarantee_nonnegative_int_arg_1(); -extern long guarantee_nonnegative_int_arg_2(); -extern long guarantee_nonnegative_int_arg_3(); -extern long guarantee_nonnegative_int_arg_4(); -extern long guarantee_nonnegative_int_arg_5(); -extern long guarantee_nonnegative_int_arg_6(); -extern long guarantee_nonnegative_int_arg_7(); -extern long guarantee_nonnegative_int_arg_8(); -extern long guarantee_nonnegative_int_arg_9(); -extern long guarantee_nonnegative_int_arg_10(); - -extern long guarantee_index_arg_1(); -extern long guarantee_index_arg_2(); -extern long guarantee_index_arg_3(); -extern long guarantee_index_arg_4(); -extern long guarantee_index_arg_5(); -extern long guarantee_index_arg_6(); -extern long guarantee_index_arg_7(); -extern long guarantee_index_arg_8(); -extern long guarantee_index_arg_9(); -extern long guarantee_index_arg_10(); diff --git a/v7/src/microcode/primutl.c b/v7/src/microcode/primutl.c deleted file mode 100644 index 09a30bc8c..000000000 --- a/v7/src/microcode/primutl.c +++ /dev/null @@ -1,262 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/primutl.c,v 9.40 1987/04/16 14:34:28 jinx Rel $ - * - * This file contains the support routines for mapping primitive names - * to numbers within the microcode. This mechanism is only used by - * the runtime system on "external" primitives. "Built-in" primitives - * must match their position in utabmd.scm. Eventually both - * mechanisms will be merged. External primitives are written in C - * and available in Scheme, but not always present in all versions of - * the interpreter. Thus, these objects are always referenced - * externally by name and converted to numeric references only for the - * duration of a single Scheme session. - */ - -#include "scheme.h" -#include "primitive.h" - -/* Common utilities. */ - -/* In the following two procedures, size is really 1 less than size. - It is really the index of the last valid entry. - */ - -long -primitive_name_to_code(name, table, size) - char *name; - char *table[]; - long size; -{ - fast long i; - - for (i = size; i >= 0; i -= 1) - { - fast char *s1, *s2; - - s1 = name; - s2 = table[i]; - - while (*s1++ == *s2) - if (*s2++ == '\0') - return i; - - } - return -1; -} - -char * -primitive_code_to_name(code, table, size) - long code; - char *table[]; - long size; -{ - if ((code > size) || (code < 0)) - return ((char *) NULL); - else - return table[code]; -} - -int -primitive_code_to_arity(code, table, size) - long code; - int table[]; - long size; -{ - if ((code > size) || (code < 0)) - return -1; - else - return table[code]; -} - -/* Utilities exclusively for built-in primitives. */ - -extern Pointer make_primitive(); - -Pointer -make_primitive(name) - char *name; -{ - long code; - - code = primitive_name_to_code(name, - &Primitive_Name_Table[0], - MAX_PRIMITIVE); - if (code == -1) - return NIL; - return - Make_Non_Pointer(TC_PRIMITIVE, code); -} - -extern long primitive_to_arity(); - -long -primitive_to_arity(code) - int code; -{ - return - primitive_code_to_arity(code, - &Primitive_Arity_Table[0], - MAX_PRIMITIVE); -} - -extern char *primitive_to_name(); - -char * -primitive_to_name(code) - int code; -{ - return - primitive_code_to_name(code, - &Primitive_Name_Table[0], - MAX_PRIMITIVE); -} - -/* Utilities exclusively for external primitives. */ - -Pointer Undefined_Externals = NIL; - -Pointer -external_primitive_name(code) - long code; -{ - extern Pointer string_to_symbol(); - - return - string_to_symbol(C_String_To_Scheme_String(External_Name_Table[code])); -} - -extern long make_external_primitive(); - -long -make_external_primitive(Symbol, Intern_It) - Pointer Symbol, Intern_It; -{ - extern Boolean string_equal(); - Pointer *Next, Name; - long i, Max; - - Name = Fast_Vector_Ref(Symbol, SYMBOL_NAME); - - i = primitive_name_to_code(Scheme_String_To_C_String(Name), - &External_Name_Table[0], - MAX_EXTERNAL_PRIMITIVE); - if (i != -1) - return Make_Non_Pointer(TC_PRIMITIVE_EXTERNAL, i); - else if (Intern_It == NIL) - return NIL; - - Max = NUndefined(); - if (Max > 0) - Next = Nth_Vector_Loc(Undefined_Externals, 2); - - for (i = 1; i <= Max; i++) - { - if (string_equal(Name, Fast_Vector_Ref(*Next++, SYMBOL_NAME))) - return Make_Non_Pointer(TC_PRIMITIVE_EXTERNAL, - (MAX_EXTERNAL_PRIMITIVE + i)); - } - if (Intern_It != TRUTH) - return NIL; - - /* Intern the primitive name by adding it to the vector of - undefined primitives */ - - if ((Max % CHUNK_SIZE) == 0) - { - Primitive_GC_If_Needed(Max + CHUNK_SIZE + 2); - if (Max > 0) Next = - Nth_Vector_Loc(Undefined_Externals, 2); - Undefined_Externals = Make_Pointer(TC_VECTOR, Free); - *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, (Max + CHUNK_SIZE + 1)); - *Free++ = Make_Unsigned_Fixnum(Max + 1); - for (i = 0; i < Max; i++) - *Free++ = Fetch(*Next++); - *Free++ = Symbol; - for (i = 1; i < CHUNK_SIZE; i++) - *Free++ = NIL; - } - else - { - User_Vector_Set(Undefined_Externals, (Max + 1), Symbol); - User_Vector_Set(Undefined_Externals, 0, Make_Unsigned_Fixnum(Max + 1)); - } - return - Make_Non_Pointer(TC_PRIMITIVE_EXTERNAL, - (MAX_EXTERNAL_PRIMITIVE + Max + 1)); -} - -extern long external_primitive_to_arity(); - -long -external_primitive_to_arity(code) - int code; -{ - return - primitive_code_to_arity(code, - &External_Arity_Table[0], - MAX_EXTERNAL_PRIMITIVE); -} - -extern Pointer Make_Prim_Exts(); - -/* - Used to create a vector with symbols for each of the external - primitives known to the system. -*/ - -Pointer -Make_Prim_Exts() -{ - fast Pointer Result, *scan; - fast long i, Max, Count; - - Max = NUndefined(); - Count = (MAX_EXTERNAL_PRIMITIVE + Max + 1); - Primitive_GC_If_Needed(Count + 1); - Result = Make_Pointer(TC_VECTOR, Free); - scan = Free; - Free += Count + 1; - - *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Count); - for (i = 0; i <= MAX_EXTERNAL_PRIMITIVE; i++) - { - *scan++ = external_primitive_name(i); - } - for (i = 1; i <= Max; i++) - { - *scan++ = User_Vector_Ref(Undefined_Externals, i); - } - return Result; -} diff --git a/v7/src/microcode/pruxfs.c b/v7/src/microcode/pruxfs.c deleted file mode 100644 index b9b049cad..000000000 --- a/v7/src/microcode/pruxfs.c +++ /dev/null @@ -1,91 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/pruxfs.c,v 9.21 1987/01/22 14:34:49 jinx Exp $ - - Simple unix primitives. - -*/ - -#include -#include "scheme.h" -#include "primitive.h" - -/* Looks up in the user's shell environment the value of the - variable specified as a string. */ - -Define_Primitive( Prim_get_environment_variable, 1, "GET-ENVIRONMENT-VARIABLE") -{ - char *variable_value; - extern char *getenv(); - Primitive_1_Arg(); - - Arg_1_Type( TC_CHARACTER_STRING); - variable_value = getenv( Scheme_String_To_C_String( Arg1)); - return ((variable_value == NULL) - ? NIL - : C_String_To_Scheme_String( variable_value)); -} - -Define_Primitive( Prim_get_user_name, 0, "CURRENT-USER-NAME") -{ - char *user_name; - char *getlogin(); - Primitive_0_Args(); - - user_name = getlogin(); - if (user_name == NULL) - { - unsigned short getuid(); - struct passwd *entry; - struct passwd *getpwuid(); - - entry = getpwuid( getuid()); - if (entry == NULL) - Primitive_Error( ERR_EXTERNAL_RETURN); - user_name = entry->pw_name; - } - return (C_String_To_Scheme_String( user_name)); -} - -Define_Primitive( Prim_get_user_home_directory, 1, "GET-USER-HOME-DIRECTORY") -{ - struct passwd *entry; - struct passwd *getpwnam(); - Primitive_1_Arg(); - - Arg_1_Type( TC_CHARACTER_STRING); - entry = getpwnam( Scheme_String_To_C_String( Arg1)); - return ((entry == NULL) - ? NIL - : C_String_To_Scheme_String( entry->pw_dir)); -} diff --git a/v7/src/microcode/psbmap.h b/v7/src/microcode/psbmap.h deleted file mode 100644 index c414e24dc..000000000 --- a/v7/src/microcode/psbmap.h +++ /dev/null @@ -1,268 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbmap.h,v 9.21 1987/01/22 14:33:52 jinx Rel $ - * - * This file contains macros and declarations for Bintopsb.c - * and Psbtobin.c - * - */ - -/* These definitions insure that the appropriate code is extracted - from the included files. -*/ - -#include -#define fast register - -#include "config.h" -#include "object.h" -#include "bignum.h" -#include "gc.h" -#include "types.h" -#include "sdata.h" -#include "const.h" -#include "gccode.h" -#include "character.h" - -#ifdef HAS_FREXP -extern double frexp(), ldexp(); -#else -#include "missing.c" -#endif - -#define PORTABLE_VERSION 1 - -/* Number of objects which, when traced recursively, point at all other - objects dumped. Currently the dumped object and the external - primitives vector. - */ - -#define NROOTS 2 - -/* Types to recognize external object references. Any occurrence of these - (which are external types and thus handled separately) means a reference - to an external object. - */ - -#define CONSTANT_CODE TC_BIG_FIXNUM -#define HEAP_CODE TC_FIXNUM - -#define fixnum_to_bits FIXNUM_LENGTH -#define bignum_to_bits(len) ((len) * SHIFT) -#define bits_to_bigdigit(nbits) (((nbits) + (SHIFT-1)) / SHIFT) - -#define hex_digits(nbits) (((nbits) + 3) / 4) - -#define to_pointer(size) \ - (((size) + (sizeof(Pointer) - 1)) / sizeof(Pointer)) - -#define bigdigit_to_pointer(ndig) \ - to_pointer((ndig) * sizeof(bigdigit)) - -/* This assumes that a bignum header is 2 Pointers. - The bignum code is not very portable, unfortunately */ - -#define bignum_header_to_pointer Align(0) - -#define float_to_pointer \ - to_pointer(sizeof(double)) -#define flonum_to_pointer(nchars) \ - ((nchars) * (1 + float_to_pointer)) - -#define char_to_pointer(nchars) \ - to_pointer(nchars) -#define pointer_to_char(npoints) \ - ((npoints) * sizeof(Pointer)) - -/* Global data */ - -/* If true, make all integers fixnums if possible, and all strings as - short as possible (trim extra stuff). */ - -static Boolean Compact_P = true; - -/* If true, null out all elements of random non-marked vectors. */ - -static Boolean Null_NMV = false; - -#ifndef Heap_In_Low_Memory -static Pointer *Memory_Base; -#endif - -static FILE *Input_File, *Output_File; - -static char *Program_Name; - -/* Status flags */ - -#define COMPACT_P 1 -#define NULL_NMV 2 - -#define Make_Flags() \ -((Compact_P ? COMPACT_P : 0) | \ - (Null_NMV ? NULL_NMV : 0)) - -#define Read_Flags(f) \ -Compact_P = ((f) & COMPACT_P); \ -Null_NMV = ((f) & NULL_NMV) - -/* Argument List Parsing */ - -struct Option_Struct { char *name; - Boolean value; - Boolean *ptr; - }; - -Boolean strequal(s1, s2) -fast char *s1, *s2; -{ while (*s1 != '\0') - if (*s1++ != *s2++) return false; - return (*s2 == '\0'); -} - -char *Find_Options(argc, argv, Noptions, Options) -int argc; -char **argv; -int Noptions; -struct Option_Struct Options[]; -{ for ( ; --argc >= 0; argv++) - { char *this = *argv; - int n; - for (n = 0; - ((n < Noptions) && (!strequal(this, Options[n].name))); - n++) ; - if (n >= Noptions) return this; - *(Options[n].ptr) = Options[n].value; - } - return NULL; -} - -/* Usage information */ - -Print_Options(n, options, where) -int n; -struct Option_Struct *options; -FILE *where; -{ if (--n < 0) return; - fprintf(where, "[%s]", options->name); - options += 1; - for (; --n >= 0; options += 1) - fprintf(where, " [%s]", options->name); - return; -} - -Print_Usage_and_Exit(noptions, options, io_options) -int noptions; -struct Option_Struct *options; -char *io_options; -{ fprintf(stderr, "usage: %s%s%s", - Program_Name, - (((io_options == NULL) || - (io_options[0] == '\0')) ? "" : " "), - io_options); - if (noptions != 0) - { putc(' ', stderr); - Print_Options(noptions, options, stderr); - } - putc('\n', stderr); - exit(1); -} - -/* Top level of program */ - -/* When debugging force arguments on command line */ - -#ifdef DEBUG -#undef unix -#endif - -#ifdef unix - -/* On unix use io redirection */ - -Setup_Program(argc, argv, Noptions, Options) -int argc; -char *argv[]; -int Noptions; -struct Option_Struct *Options; -{ extern do_it(); - Program_Name = argv[0]; - Input_File = stdin; - Output_File = stdout; - if (((argc - 1) > Noptions) || - (Find_Options((argc - 1), &argv[1], Noptions, Options) != NULL)) - Print_Usage_and_Exit(Noptions, Options, ""); - do_it(); - return; -} - -#else - -/* Otherwise use command line arguments */ - -Setup_Program(argc, argv, Noptions, Options) -int argc; -char *argv[]; -int Noptions; -struct Option_Struct *Options; -{ extern do_it(); - Program_Name = argv[0]; - if ((argc < 3) || - ((argc - 3) > Noptions) || - (Find_Options((argc - 3), &argv[3], Noptions, Options) != NULL)) - Print_Usage_and_Exit(Noptions, Options, "input_file output_file"); - Input_File = ((strequal(argv[1], "-")) ? - stdin : - fopen(argv[1], "r")); - if (Input_File == NULL) - { perror("Open failed."); - exit(1); - } - Output_File = ((strequal(argv[2], "-")) ? - stdout : - fopen(argv[2], "w")); - if (Output_File == NULL) - { perror("Open failed."); - fclose(Input_File); - exit(1); - } - fprintf(stderr, "%s: Reading from %s, writing to %s.\n", - Program_Name, argv[1], argv[2]); - do_it(); - fclose(Input_File); - fclose(Output_File); - return; -} - -#endif - diff --git a/v7/src/microcode/psbtobin.c b/v7/src/microcode/psbtobin.c deleted file mode 100644 index 85909d96c..000000000 --- a/v7/src/microcode/psbtobin.c +++ /dev/null @@ -1,622 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbtobin.c,v 9.23 1987/04/16 02:06:10 jinx Exp $ - * - * This File contains the code to translate portable format binary - * files to internal format. - * - */ - -/* Cheap renames */ - -#define Portable_File Input_File -#define Internal_File Output_File - -#include "translate.h" - -static long Dumped_Object_Addr, Dumped_Ext_Prim_Addr; -static long Dumped_Heap_Base, Heap_Objects, Heap_Count; -static long Dumped_Constant_Base, Constant_Objects, Constant_Count; -static long Dumped_Pure_Base, Pure_Objects, Pure_Count; -static Pointer *Heap; -static Pointer *Heap_Base, *Heap_Table, *Heap_Object_Base, *Free; -static Pointer *Constant_Base, *Constant_Table, - *Constant_Object_Base, *Free_Constant; -static Pointer *Pure_Base, *Pure_Table, *Pure_Object_Base, *Free_Pure; -static Pointer *Stack_Top; - -Write_Data(Count, From_Where) -long Count; -Pointer *From_Where; -{ fwrite(((char *) From_Where), sizeof(Pointer), Count, Internal_File); -} - -#include "dump.c" - -#define OUT(c) return ((long) ((c) & MAX_CHAR)) - -long read_a_char() -{ fast char C = getc(Portable_File); - if (C != '\\') OUT(C); - C = getc(Portable_File); - switch(C) - { case 'n': OUT('\n'); - case 't': OUT('\n'); - case 'r': OUT('\r'); - case 'f': OUT('\f'); - case '0': OUT('\0'); - case 'X': - { long Code; - fprintf(stderr, - "%s: File is not Portable. Character Code Found.\n", - Program_Name); - fscanf(Portable_File, "%d", &Code); - getc(Portable_File); /* Space */ - OUT(Code); - } - case '\\': OUT('\\'); - default : OUT(C); - } -} - -Pointer *read_a_string(To, Slot) -Pointer *To, *Slot; -{ long maxlen, len, Pointer_Count; - fast char *string = ((char *) (&To[STRING_CHARS])); - *Slot = Make_Pointer(TC_CHARACTER_STRING, To); - fscanf(Portable_File, "%ld %ld", &maxlen, &len); - maxlen += 1; /* Null terminated */ - Pointer_Count = STRING_CHARS + char_to_pointer(maxlen); - To[STRING_HEADER] = - Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1)); - To[STRING_LENGTH] = Make_Non_Pointer(TC_FIXNUM, len); - getc(Portable_File); /* Space */ - while (--len >= 0) *string++ = ((char) read_a_char()); - *string = '\0'; - return (To + Pointer_Count); -} - -Pointer *read_an_integer(The_Type, To, Slot) -int The_Type; -Pointer *To; -Pointer *Slot; -{ Boolean negative; - long size_in_bits; - - getc(Portable_File); /* Space */ - negative = ((getc(Portable_File)) == '-'); - fscanf(Portable_File, "%ld", &size_in_bits); - if ((size_in_bits <= fixnum_to_bits) && - (The_Type == TC_FIXNUM)) - { fast long Value = 0; - fast int Normalization; - fast long ndigits; - long digit; - if (size_in_bits != 0) - for(Normalization = 0, - ndigits = hex_digits(size_in_bits); - --ndigits >= 0; - Normalization += 4) - { fscanf(Portable_File, "%1lx", &digit); - Value += (digit << Normalization); - } - if (negative) Value = -Value; - *Slot = Make_Non_Pointer(TC_FIXNUM, Value); - return To; - } - else if (size_in_bits == 0) - { bigdigit *REG = BIGNUM(To); - Prepare_Header(REG, 0, POSITIVE); - *Slot = Make_Pointer(TC_BIG_FIXNUM, To); - return (To + Align(0)); - } - else - { fast bigdigit *The_Bignum; - fast long size, nbits, ndigits; - fast unsigned long Temp; - long Length; - if ((The_Type == TC_FIXNUM) && (!Compact_P)) - fprintf(stderr, - "%s: Fixnum too large, coercing to bignum.\n", - Program_Name); - size = bits_to_bigdigit(size_in_bits); - ndigits = hex_digits(size_in_bits); - Length = Align(size); - The_Bignum = BIGNUM(To); - Prepare_Header(The_Bignum, size, (negative ? NEGATIVE : POSITIVE)); - for (The_Bignum = Bignum_Bottom(The_Bignum), nbits = 0, Temp = 0; - --size >= 0; - ) - { for ( ; - (nbits < SHIFT) && (ndigits > 0); - ndigits -= 1, nbits += 4) - { long digit; - fscanf(Portable_File, "%1lx", &digit); - Temp |= (((unsigned long) digit) << nbits); - } - *The_Bignum++ = Rem_Radix(Temp); - Temp = Div_Radix(Temp); - nbits -= SHIFT; - } - *Slot = Make_Pointer(TC_BIG_FIXNUM, To); - return (To + Length); - } -} - -/* Underflow and Overflow */ - -/* dflmax and dflmin exist in the Berserkely FORTRAN library */ - -static double the_max = 0.0; - -#define dflmin() 0.0 /* Cop out */ -#define dflmax() ((the_max == 0.0) ? compute_max() : the_max) - -double compute_max() -{ fast double Result = 0.0; - fast int expt; - for (expt = MAX_FLONUM_EXPONENT; - expt != 0; - expt >>= 1) - Result += ldexp(1.0, expt); - the_max = Result; - return Result; -} - -double read_a_flonum() -{ Boolean negative; - long size_in_bits, exponent; - fast double Result; - - getc(Portable_File); /* Space */ - negative = ((getc(Portable_File)) == '-'); - fscanf(Portable_File, "%ld %ld", &exponent, &size_in_bits); - if (size_in_bits == 0) Result = 0.0; - else if ((exponent > MAX_FLONUM_EXPONENT) || - (exponent < -MAX_FLONUM_EXPONENT)) - { /* Skip over mantissa */ - while (getc(Portable_File) != '\n') ; - fprintf(stderr, - "%s: Floating point exponent too %s!\n", - Program_Name, - ((exponent < 0) ? "small" : "large")); - Result = ((exponent < 0) ? dflmin() : dflmax()); - } - else - { fast long ndigits; - fast double Normalization; - long digit; - if (size_in_bits > FLONUM_MANTISSA_BITS) - fprintf(stderr, - "%s: Some precision may be lost.", - Program_Name); - getc(Portable_File); /* Space */ - for (ndigits = hex_digits(size_in_bits), - Result = 0.0, - Normalization = (1.0 / 16.0); - --ndigits >= 0; - Normalization /= 16.0) - { - fscanf(Portable_File, "%1lx", &digit); - Result += (((double ) digit) * Normalization); - } - Result = ldexp(Result, ((int) exponent)); - } - if (negative) Result = -Result; - return Result; -} - -Pointer * -Read_External(N, Table, To) - long N; - fast Pointer *Table, *To; -{ - fast Pointer *Until = &Table[N]; - int The_Type; - - while (Table < Until) - { - fscanf(Portable_File, "%2x", &The_Type); - switch(The_Type) - { - case TC_CHARACTER_STRING: - To = read_a_string(To, Table++); - continue; - case TC_FIXNUM: - case TC_BIG_FIXNUM: - To = read_an_integer(The_Type, To, Table++); - continue; - case TC_CHARACTER: - { - long the_char_code; - - getc(Portable_File); /* Space */ - fscanf( Portable_File, "%3x", &the_char_code); - *Table++ = Make_Non_Pointer( TC_CHARACTER, the_char_code); - continue; - } - case TC_BIG_FLONUM: - { - double The_Flonum = read_a_flonum(); - - Align_Float(To); - *Table++ = Make_Pointer(TC_BIG_FLONUM, To); - *To++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (float_to_pointer)); - *((double *) To) = The_Flonum; - To += float_to_pointer; - continue; - } - default: - fprintf(stderr, - "%s: Unknown external object found; Type = 0x%02x\n", - Program_Name, The_Type); - exit(1); - } - } - return To; -} - -#if false -Move_Memory(From, N, To) -fast Pointer *From, *To; -long N; -{ fast Pointer *Until = &From[N]; - while (From < Until) *To++ = *From++; - return; -} -#endif - -Relocate_Objects(From, N, disp) -fast Pointer *From; -long N; -fast long disp; -{ fast Pointer *Until = &From[N]; - while (From < Until) - { switch(Type_Code(*From)) - { case TC_FIXNUM: - case TC_CHARACTER: - From += 1; - break; - case TC_BIG_FIXNUM: - case TC_BIG_FLONUM: - case TC_CHARACTER_STRING: - *From++ == Make_Object(Type_Code(*From), (disp + Datum(*From))); - break; - default: - fprintf(stderr, - "%s: Unknown External Object Reference with Type 0x%02x", - Program_Name, - Type_Code(*From)); - } - } -} - -#define Relocate_Into(Where, Addr) \ -if ((Addr) < Dumped_Pure_Base) \ - (Where) = &Heap_Object_Base[(Addr) - Dumped_Heap_Base]; \ -else if ((Addr) < Dumped_Constant_Base) \ - (Where) = &Pure_Base[(Addr) - Dumped_Pure_Base]; \ -else (Where) = &Constant_Base[(Addr) - Dumped_Constant_Base]; - -#ifndef Conditional_Bug - -#define Relocate(Addr) \ -(((Addr) < Dumped_Pure_Base) ? \ - &Heap_Object_Base[(Addr) - Dumped_Heap_Base] : \ - (((Addr) < Dumped_Constant_Base) ? \ - &Pure_Base[(Addr) - Dumped_Pure_Base] : \ - &Constant_Base[(Addr) - Dumped_Constant_Base])) - -#else -static Pointer *Relocate_Temp; -#define Relocate(Addr) \ - (Relocate_Into(Relocate_Temp, Addr), Relocate_Temp) -#endif - -Pointer *Read_Pointers_and_Relocate(N, To) -fast long N; -fast Pointer *To; -{ int The_Type; - long The_Datum; -/* Align_Float(To); */ - while (--N >= 0) - { fscanf(Portable_File, "%2x %lx", &The_Type, &The_Datum); - switch(The_Type) - { case CONSTANT_CODE: - *To++ = Constant_Table[The_Datum]; - continue; - - case HEAP_CODE: - *To++ = Heap_Table[The_Datum]; - continue; - - case TC_MANIFEST_NM_VECTOR: - if (!(Null_NMV)) /* Unknown object! */ - fprintf(stderr, "%s: File is not portable: NMH found\n", - Program_Name); - *To++ = Make_Non_Pointer(The_Type, The_Datum); - { fast long count = The_Datum; - N -= count; - while (--count >= 0) - { fscanf(Portable_File, "%2x %lx", &The_Type, &The_Datum); - *To++ = Make_Non_Pointer(The_Type, The_Datum); - } - } - continue; - - case TC_BROKEN_HEART: - if (The_Datum != 0) - { fprintf(stderr, "%s: Broken Heart Found\n", Program_Name); - exit(1); - } - /* Fall Through */ - case TC_PRIMITIVE_EXTERNAL: - case TC_MANIFEST_SPECIAL_NM_VECTOR: - case_simple_Non_Pointer: - *To++ = Make_Non_Pointer(The_Type, The_Datum); - continue; - - case TC_REFERENCE_TRAP: - if (The_Datum <= TRAP_MAX_IMMEDIATE) - { - *To++ = Make_Non_Pointer(The_Type, The_Datum); - continue; - } - /* It is a pointer, fall through. */ - default: - /* Should be stricter */ - *To++ = Make_Pointer(The_Type, Relocate(The_Datum)); - continue; - } - } -/* Align_Float(To); */ - return To; -} - -#ifdef DEBUG -Print_External_Objects(area_name, Table, N) -char *area_name; -fast Pointer *Table; -fast long N; -{ fast Pointer *Table_End = &Table[N]; - - fprintf(stderr, "%s External Objects:\n", area_name); - fprintf(stderr, "Table = 0x%x; N = %d\n", Table, N); - - for( ; Table < Table_End; Table++) - switch (Type_Code(*Table)) - { case TC_FIXNUM: - { long The_Number; - Sign_Extend(*Table, The_Number); - fprintf(stderr, - "Table[%6d] = Fixnum %d\n", - (N-(Table_End-Table)), - The_Number); - break; - } - case TC_CHARACTER: - fprintf(stderr, - "Table[%6d] = Character %c = 0x%02x\n", - (N-(Table_End-Table)), - Get_Integer(*Table), - Get_Integer(*Table)); - break; - -/* Print_External_Objects continues on the next page */ - -/* Print_External_Objects, continued */ - - case TC_CHARACTER_STRING: - fprintf(stderr, - "Table[%6d] = string \"%s\"\n", - (N-(Table_End-Table)), - ((char *) Nth_Vector_Loc(*Table, STRING_CHARS))); - break; - case TC_BIG_FIXNUM: - fprintf(stderr, - "Table[%6d] = Bignum\n", - (N-(Table_End-Table))); - break; - case TC_BIG_FLONUM: - fprintf(stderr, - "Table[%6d] = Flonum %lf\n", - (N-(Table_End-Table)), - (* ((double *) Nth_Vector_Loc(*Table, 1)))); - break; - default: - fprintf(stderr, - "Table[%6d] = Unknown External Object 0x%8x\n", - (N-(Table_End-Table)), - *Table); - break; - } -} -#endif - -long Read_Header_and_Allocate() -{ long Portable_Version, Flags, Version, Sub_Version; - long NFlonums, NIntegers, NStrings, NBits, NChars; - long Size; - - /* Read Header */ - - fscanf(Input_File, "%ld %ld %ld %ld", - &Portable_Version, &Flags, &Version, &Sub_Version); - fscanf(Input_File, "%ld %ld %ld", - &Heap_Count, &Dumped_Heap_Base, &Heap_Objects); - fscanf(Input_File, "%ld %ld %ld", - &Constant_Count, &Dumped_Constant_Base, &Constant_Objects); - fscanf(Input_File, "%ld %ld %ld", - &Pure_Count, &Dumped_Pure_Base, &Pure_Objects); - fscanf(Input_File, "%ld %ld %ld %ld %ld", - &NFlonums, &NIntegers, &NStrings, &NBits, &NChars); - fscanf(Input_File, "%ld %ld", - &Dumped_Object_Addr, &Dumped_Ext_Prim_Addr); - - if ((Portable_Version != PORTABLE_VERSION) || - (Version != FASL_FORMAT_VERSION) || - (Sub_Version != FASL_SUBVERSION)) - { fprintf(stderr, - "FASL File Version %4d Subversion %4d Portable Version %4d\n", - Version, Sub_Version , Portable_Version); - fprintf(stderr, - "Expected: Version %4d Subversion %4d Portable Version %4d\n", - FASL_FORMAT_VERSION, FASL_SUBVERSION, PORTABLE_VERSION); - exit(1); - } - - Read_Flags(Flags); - - Size = (6 + /* SNMV */ - HEAP_BUFFER_SPACE + - Heap_Count + Heap_Objects + - Constant_Count + Constant_Objects + - Pure_Count + Pure_Objects + - flonum_to_pointer(NFlonums) + - ((NIntegers * bignum_header_to_pointer) + - (bigdigit_to_pointer(bits_to_bigdigit(NBits)))) + - ((NStrings * STRING_CHARS) + (char_to_pointer(NChars)))); - - Allocate_Heap_Space(Size); - if (Heap == NULL) - { fprintf(stderr, - "%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n", - Program_Name, Size); - exit(1); - } - Heap += HEAP_BUFFER_SPACE; - Initial_Align_Float(Heap); - return (Size - HEAP_BUFFER_SPACE); -} - -do_it() -{ long Size; - Size = Read_Header_and_Allocate(); - Stack_Top = &Heap[Size]; - - Heap_Table = &Heap[0]; - Heap_Base = &Heap_Table[Heap_Objects]; - Heap_Object_Base = - Read_External(Heap_Objects, Heap_Table, Heap_Base); - - Pure_Table = &Heap_Object_Base[Heap_Count]; - Pure_Base = &Pure_Table[Pure_Objects + 2]; /* SNMV */ - Pure_Object_Base = - Read_External(Pure_Objects, Pure_Table, Pure_Base); - - Constant_Table = &Heap[Size - Constant_Objects]; - Constant_Base = &Pure_Object_Base[Pure_Count + 2]; /* SNMV */ - Constant_Object_Base = - Read_External(Constant_Objects, Constant_Table, Constant_Base); - -#ifdef DEBUG - Print_External_Objects("Heap", Heap_Table, Heap_Objects); - Print_External_Objects("Pure", Pure_Table, Pure_Objects); - Print_External_Objects("Constant", Constant_Table, Constant_Objects); -#endif - - /* Read the normal objects */ - - Free = - Read_Pointers_and_Relocate(Heap_Count, Heap_Object_Base); - Free_Pure = - Read_Pointers_and_Relocate(Pure_Count, Pure_Object_Base); - Free_Constant = - Read_Pointers_and_Relocate(Constant_Count, Constant_Object_Base); - - /* Dump the objects */ - - { Pointer *Dumped_Object, *Dumped_Ext_Prim; - Relocate_Into(Dumped_Object, Dumped_Object_Addr); - Relocate_Into(Dumped_Ext_Prim, Dumped_Ext_Prim_Addr); - -#ifdef DEBUG - fprintf(stderr, "Dumping:\n"); - fprintf(stderr, - "Heap = 0x%x; Heap Count = %d\n", - Heap_Base, (Free - Heap_Base)); - fprintf(stderr, - "Pure Space = 0x%x; Pure Count = %d\n", - Pure_Base, (Free_Pure - Pure_Base)); - fprintf(stderr, - "Constant Space = 0x%x; Constant Count = %d\n", - Constant_Base, (Free_Constant - Constant_Base)); - fprintf(stderr, - "& Dumped Object = 0x%x; Dumped Object = 0x%x\n", - Dumped_Object, *Dumped_Object); - fprintf(stderr, - "& Dumped Ext Prim = 0x%x; Dumped Ext Prim = 0x%x\n", - Dumped_Ext_Prim, *Dumped_Ext_Prim); -#endif - - /* Is there a Pure/Constant block? */ - - if ((Constant_Objects == 0) && (Constant_Count == 0) && - (Pure_Objects == 0) && (Pure_Count == 0)) - Write_File((Free - Heap_Base), Heap_Base, Dumped_Object, - 0, &Heap[Size], Dumped_Ext_Prim); - else - { long Pure_Length = (Constant_Base - Pure_Base) + 1; - long Total_Length = (Free_Constant - Pure_Base) + 4; - Pure_Base[-2] = - Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, (Pure_Length - 1)); - Pure_Base[-1] = - Make_Non_Pointer(PURE_PART, Total_Length); - Constant_Base[-2] = - Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1); - Constant_Base[-1] = - Make_Non_Pointer(CONSTANT_PART, (Pure_Length - 1)); - Free_Constant[0] = - Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1); - Free_Constant[1] = - Make_Non_Pointer(END_OF_BLOCK, Total_Length); - - Write_File((Free - Heap_Base), Heap_Base, Dumped_Object, - Total_Length, (Pure_Base - 2), Dumped_Ext_Prim); - } - } - return; -} - -/* Top level */ - -static int Noptions = 0; -/* C does not usually like empty initialized arrays, so ... */ -static struct Option_Struct Options[] = {{"dummy", true, NULL}}; - -main(argc, argv) -int argc; -char *argv[]; -{ Setup_Program(argc, argv, Noptions, Options); - return; -} diff --git a/v7/src/microcode/purify.c b/v7/src/microcode/purify.c deleted file mode 100644 index 2cfb7bdbe..000000000 --- a/v7/src/microcode/purify.c +++ /dev/null @@ -1,399 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.26 1987/04/16 02:27:53 jinx Exp $ - * - * This file contains the code that copies objects into pure - * and constant space. - * - */ - -#include "scheme.h" -#include "primitive.h" -#include "gccode.h" -#include "zones.h" - -/* Imports */ - -extern void GCFlip(), GC(); -extern Pointer *GCLoop(); - -/* This is a copy of GCLoop, with GC_Mode handling added, and - debugging printout removed. -*/ - -#define Purify_Pointer(Code) \ -Old = Get_Pointer(Temp); \ -if ((GC_Mode == CONSTANT_COPY) && \ - (Old > Low_Constant)) \ - continue; \ -Code - -#define Setup_Pointer_for_Purify(Extra_Code) \ -Purify_Pointer(Setup_Pointer(false, Extra_Code)) - -#define Indirect_BH(In_GC) \ -if (Type_Code(*Old) == TC_BROKEN_HEART) continue; - -#define Transport_Vector_Indirect() \ -Real_Transport_Vector(); \ -*Get_Pointer(Temp) = New_Address - -Pointer *PurifyLoop(Scan, To_Pointer, GC_Mode) -fast Pointer *Scan; -Pointer **To_Pointer; -int GC_Mode; -{ fast Pointer *To, *Old, Temp, *Low_Constant, New_Address; - - To = *To_Pointer; - Low_Constant = Constant_Space; - for ( ; Scan != To; Scan++) - { Temp = *Scan; - Switch_by_GC_Type(Temp) - { case TC_BROKEN_HEART: - if (Scan == (Get_Pointer(Temp))) - { *To_Pointer = To; - return Scan; - } - fprintf(stderr, "Purify: Broken heart in scan.\n"); - Microcode_Termination(TERM_BROKEN_HEART); - - case TC_MANIFEST_NM_VECTOR: - case TC_MANIFEST_SPECIAL_NM_VECTOR: - Scan += Get_Integer(Temp); - break; - - case_Non_Pointer: - break; - - case_compiled_entry_point: - if (GC_Mode == PURE_COPY) break; - Purify_Pointer(Setup_Internal(false, - Transport_Compiled(), - Compiled_BH(false, continue))); - - case_Cell: - Setup_Pointer_for_Purify(Transport_Cell()); - -/* PurifyLoop continues on the next page */ - -/* PurifyLoop, continued */ - - /* - Symbols, variables, and reference traps cannot be put into - pure space. The strings contained in the first two can, on the - other hand. - */ - - case TC_REFERENCE_TRAP: - if ((Datum(Temp) <= TRAP_MAX_IMMEDIATE) || (GC_Mode == PURE_COPY)) - { - /* It is a non pointer. */ - break; - } - goto purify_pair; - - case TC_INTERNED_SYMBOL: - case TC_UNINTERNED_SYMBOL: - if (GC_Mode == PURE_COPY) - { Temp = Vector_Ref(Temp, SYMBOL_NAME); - Purify_Pointer(Setup_Internal(false, - Transport_Vector_Indirect(), - Indirect_BH(false))); - } - /* Fall through */ - case_Fasdump_Pair: - purify_pair: - Setup_Pointer_for_Purify(Transport_Pair()); - - case TC_WEAK_CONS: - Setup_Pointer_for_Purify(Transport_Weak_Cons()); - - case TC_VARIABLE: - case_Triple: - Setup_Pointer_for_Purify(Transport_Triple()); - -/* PurifyLoop continues on the next page */ - -/* PurifyLoop, continued */ - - case_Quadruple: - Setup_Pointer_for_Purify(Transport_Quadruple()); - - /* No need to handle futures specially here, since PurifyLoop - is always invoked after running GCLoop, which will have - spliced all spliceable futures unless the GC itself of the - GC dameons spliced them, but this should not occur. - */ - - case TC_FUTURE: - case TC_ENVIRONMENT: - if (GC_Mode == PURE_COPY) - { - /* This should actually do an indirect pair transport of - the procedure, at least. - */ - break; - } - /* Fall through */ -#ifndef FLOATING_ALIGNMENT - case TC_BIG_FLONUM: - /* Fall through */ -#endif - case_Purify_Vector: - purify_vector: - Setup_Pointer_for_Purify(Transport_Vector()); - -#ifdef FLOATING_ALIGNMENT - case TC_BIG_FLONUM: - Setup_Pointer_for_Purify(Transport_Flonum()); -#endif - - default: - fprintf(stderr, - "PurifyLoop: Bad type code = 0x%02x\n", - Type_Code(Temp)); - Invalid_Type_Code(); - } /* Switch_by_GC_Type */ - } /* For loop */ - *To_Pointer = To; - return To; -} /* PurifyLoop */ - -/* Description of the algorithm for PURIFY: - - The algorithm is trickier than would first appear necessary. This - is because the size of the object being purified must be - calculated. The idea is that the entire object is copied into the - new heap, and then a normal GC is done (the broken hearts created - by the copy will, of course, now be used to relocate references to - parts of the object). If there is not enough room in constant - space for the object, processing stops with a #!false return and - the world flipped into the new heap. Otherwise, the - process is repeated, moving the object into constant space on the - first pass and then doing a GC back into the original heap. - - Notice that in order to make a pure object, the copy process - proceeds in two halves. During the first half (which collects the - pure part) Compiled Code, Environments, Symbols, and Variables - (i.e. things whose contents change) are NOT copied. Then a header - is put down indicating constant (not pure) area, and then they ARE - copied. - - The constant area contains a contiguous set of blocks of the - following format: - - >>Top of Memory (Stack above here)<< - - . (direction of growth) - . ^ - . / \ - . | - . | - |----------------------|... - | END | Total Size M | . Where END = TC_FIXNUM - |----------------------| . SNMH = TC_MANIFEST_SPECIAL_... - | SNMH | 1 | | CONST = TC_TRUE - |----------------------| | PURE = TC_FALSE - | | | - | | | - | CONSTANT AREA | | - | | | - | | . - ...|----------------------| > M - . | CONST | Pure Size N | . - . |----------------------| | - | | SNMH | 1 | | - | |----------------------| | - | | | | -N < | | | - | | PURE AREA | | - | | | | - . | | . - . |----------------------| . - ...| PURE | Total Size M |... - |----------------------| - | SNMH | Pure Size N | - |----------------------| - - >>Base of Memory (Heap below here)<< -*/ - -/* The result returned by Purify is a vector containing this data */ - -#define Purify_Vector_Header 0 -#define Purify_Length 1 -#define Purify_Really_Pure 2 -#define Purify_N_Slots 2 - -Pointer Purify(Object, Purify_Object) -Pointer Object, Purify_Object; -{ long Length; - Pointer *Heap_Start, *Result, Answer; - -/* Pass 1 -- Copy object to new heap, then GC into that heap */ - - GCFlip(); - Heap_Start = Free; - *Free++ = Object; - Result = GCLoop(Heap_Start, &Free); - if (Free != Result) - { fprintf(stderr, "\Purify: Pure Scan ended too early.\n"); - Microcode_Termination(TERM_BROKEN_HEART); - } - Length = (Free-Heap_Start)-1; /* Length of object */ - GC(); - Free[Purify_Vector_Header] = - Make_Non_Pointer(TC_MANIFEST_VECTOR, Purify_N_Slots); - Free[Purify_Length] = Make_Unsigned_Fixnum(Length); - Free[Purify_Really_Pure] = Purify_Object; - Answer = Make_Pointer(TC_VECTOR, Free); - Free += Purify_N_Slots+1; - return Answer; -} - -Pointer Purify_Pass_2(Info) -Pointer Info; -{ long Length = Get_Integer(Fast_Vector_Ref(Info, Purify_Length)); - Boolean Purify_Object; - Pointer *New_Object, Relocated_Object, *Result, Answer; - long Pure_Length, Recomputed_Length; - - if (Fast_Vector_Ref(Info, Purify_Really_Pure) == NIL) - Purify_Object = false; - else Purify_Object = true; - Relocated_Object = *Heap_Bottom; - if (!Test_Pure_Space_Top(Free_Constant+Length+6)) - return NIL; - New_Object = Free_Constant; - GCFlip(); - *Free_Constant++ = NIL; /* Will hold pure space header */ - *Free_Constant++ = Relocated_Object; - if (Purify_Object) - { Result = PurifyLoop(New_Object+1, &Free_Constant, PURE_COPY); - if (Free_Constant != Result) - { fprintf(stderr, "\Purify: Pure Copy ended too early.\n"); - Microcode_Termination(TERM_BROKEN_HEART); - } - Pure_Length = (Free_Constant-New_Object) + 1; - } - else Pure_Length = 3; - *Free_Constant++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1); - *Free_Constant++ = Make_Non_Pointer(CONSTANT_PART, Pure_Length); - if (Purify_Object) - { Result = PurifyLoop(New_Object + 1, &Free_Constant, CONSTANT_COPY); - if (Result != Free_Constant) - { fprintf(stderr, "\Purify: Constant Copy ended too early.\n"); - Microcode_Termination(TERM_BROKEN_HEART); - } - } - -/* Purify_Pass_2 continues on the next page */ - -/* Purify_Pass_2, continued */ - - else - { Result = GCLoop(New_Object + 1, &Free_Constant); - if (Result != Free_Constant) - { fprintf(stderr, "\Purify: Constant Copy ended too early.\n"); - Microcode_Termination(TERM_BROKEN_HEART); - } - } - Recomputed_Length = (Free_Constant-New_Object)-4; - *Free_Constant++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1); - *Free_Constant++ = Make_Non_Pointer(END_OF_BLOCK, Recomputed_Length+5); - if (Length > Recomputed_Length) - { printf("Purify phase error %x, %x\n", Length, Recomputed_Length); - Microcode_Termination(TERM_EXIT); - } - *New_Object++ = - Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, Pure_Length); - *New_Object = Make_Non_Pointer(PURE_PART, Recomputed_Length+5); - GC(); - Set_Pure_Top(); - return TRUTH; -} - -/* (PRIMITIVE-PURIFY OBJECT PURE?) - Copy an object from the heap into constant space. This requires - a spare heap, and is tricky to use -- it should only be used - through the wrapper provided in the Scheme runtime system. - - To purify an object we just copy it into Pure Space in two - parts with the appropriate headers and footers. The actual - copying is done by PurifyLoop above. If we run out of room - SCHEME crashes. - - Once the copy is complete we run a full GC which handles the - broken hearts which now point into pure space. On a - multiprocessor, this primitive uses the master-gc-loop and it - should only be used as one would use master-gc-loop i.e. with - everyone else halted. - - This primitive does not return normally. It always escapes into - the interpreter because some of its cached registers (eg. History) - have changed. -*/ - -Built_In_Primitive(Prim_Primitive_Purify, 2, "PRIMITIVE-PURIFY", 0xB4) -{ - long Saved_Zone; - Pointer Object, Lost_Objects, Purify_Result, Daemon; - Primitive_2_Args(); - - Save_Time_Zone(Zone_Purify); - if ((Arg2 != TRUTH) && (Arg2 != NIL)) - Primitive_Error(ERR_ARG_2_WRONG_TYPE); - - /* Pass 1 (Purify, above) does a first copy. Then any GC daemons - run, and then Purify_Pass_2 is called to copy back. - */ - - Touch_In_Primitive(Arg1, Object); - Purify_Result = Purify(Object, Arg2); - Pop_Primitive_Frame(2); - Daemon = Get_Fixed_Obj_Slot(GC_Daemon); - if (Daemon == NIL) - { - Val = Purify_Pass_2(Purify_Result); - longjmp( *Back_To_Eval, PRIM_POP_RETURN); - /*NOTREACHED*/ - } - Store_Expression(Purify_Result); - Store_Return(RC_PURIFY_GC_1); - Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1); - Save_Cont(); - Push(Daemon); - Push(STACK_FRAME_HEADER); - Pushed(); - longjmp(*Back_To_Eval, PRIM_APPLY); /*NOTREACHED*/ -} diff --git a/v7/src/microcode/purutl.c b/v7/src/microcode/purutl.c deleted file mode 100644 index 4f1910422..000000000 --- a/v7/src/microcode/purutl.c +++ /dev/null @@ -1,301 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purutl.c,v 9.28 1987/04/16 02:28:06 jinx Exp $ */ - -/* Pure/Constant space utilities. */ - -#include "scheme.h" -#include "primitive.h" -#include "gccode.h" -#include "zones.h" - -void -Update(From, To, Was, Will_Be) - fast Pointer *From, *To, *Was, *Will_Be; -{ - for (; From < To; From++) - { - if (GC_Type_Special(*From)) - { - if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR) - From += Get_Integer(*From); - continue; - } - if (GC_Type_Non_Pointer(*From)) - continue; - if (Get_Pointer(*From) == Was) - *From = Make_Pointer(Type_Code(*From), Will_Be); - } - return; -} - -Pointer -Make_Impure(Object) - Pointer Object; -{ - Pointer *New_Address, *End_Of_Area; - fast Pointer *Obj_Address, *Constant_Address; - long Length, Block_Length; - fast long i; - - /* Calculate size of object to be "impurified". - Note that this depends on the fact that Compiled Entries CANNOT - be pure. - */ - - Switch_by_GC_Type(Object) - { - case TC_BROKEN_HEART: - case TC_MANIFEST_NM_VECTOR: - case TC_MANIFEST_SPECIAL_NM_VECTOR: - case_Non_Pointer: - fprintf(stderr, "\nImpurify Non-Pointer.\n"); - Microcode_Termination(TERM_NON_POINTER_RELOCATION); - - case TC_BIG_FLONUM: - case TC_FUTURE: - case_Vector: - Length = Vector_Length(Object) + 1; - break; - - case_Quadruple: - Length = 4; - break; - - case TC_VARIABLE: - case_Triple: - Length = 3; - break; - - case TC_WEAK_CONS: - case_Pair: - Length = 2; - break; - - case_Cell: - Length = 1; - break; - - default: - fprintf(stderr, "\nImpurify: Bad type code = 0x%02x\n", - Type_Code(Object)); - Invalid_Type_Code(); - } - - /* Add a copy of the object to the last constant block in memory. - */ - - Constant_Address = Free_Constant; - - Obj_Address = Get_Pointer(Object); - if (!Test_Pure_Space_Top(Constant_Address + Length)) - return NIL; - Block_Length = Get_Integer(*(Constant_Address-1)); - Constant_Address -= 2; - New_Address = Constant_Address; - -#ifdef FLOATING_ALIGNMENT - /* This should be done more cleanly, always align before doing a - block, or something like it. -- JINX - */ - - if (Type_Code(Object) == TC_BIG_FLONUM) - { - Pointer *Start; - - Start = Constant_Address; - Align_Float(Constant_Address); - for (i = 0; i < Length; i++) - *Constant_Address++ = *Obj_Address++; - Length = Constant_Address - Start; - } - else -#endif - for (i = Length; --i >= 0; ) - { - *Constant_Address++ = *Obj_Address; - *Obj_Address++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, i); - } - *Constant_Address++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1); - *Constant_Address++ = Make_Non_Pointer(END_OF_BLOCK, Block_Length + Length); - *(New_Address + 2 - Block_Length) = - Make_Non_Pointer(PURE_PART, Block_Length + Length); - Obj_Address -= Length; - Free_Constant = Constant_Address; - - /* Run through memory relocating pointers to this object, including - * those in pure areas. - */ - - Set_Pure_Top(); - Terminate_Old_Stacklet(); - Terminate_Constant_Space(End_Of_Area); - Update(Heap_Bottom, Free, Obj_Address, New_Address); - Update(Constant_Space, End_Of_Area, Obj_Address, New_Address); - return Make_Pointer(Type_Code(Object), New_Address); -} - -/* (PRIMITIVE-IMPURIFY OBJECT) - Remove an object from pure space so it can be side effected. - The object is placed in constant space instead. -*/ -Built_In_Primitive(Prim_Impurify, 1, "PRIMITIVE-IMPURIFY", 0xBD) -{ - Pointer Result; - Primitive_1_Arg(); - - Touch_In_Primitive(Arg1, Arg1); - Result = Make_Impure(Arg1); - if (Result != NIL) - return Result; - Primitive_Error(ERR_IMPURIFY_OUT_OF_SPACE); - /*NOTREACHED*/ -} - -Boolean -Pure_Test(Obj_Address) - fast Pointer *Obj_Address; -{ - fast Pointer *Where; -#ifdef FLOATING_ALIGNMENT - fast Pointer Float_Align_Value; - - Float_Align_Value = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0); -#endif - - Where = Free_Constant-1; - while (Where >= Constant_Space) - { -#ifdef FLOATING_ALIGNMENT - while (*Where == Float_Align_Value) - Where -= 1; -#endif - Where -= 1 + Get_Integer(*Where); - if (Where <= Obj_Address) - return - ((Boolean) (Obj_Address <= (Where + 1 + Get_Integer(*(Where + 1))))); - } - return ((Boolean) false); -} - -/* (PURE? OBJECT) - Returns #!TRUE if the object is pure (ie it doesn't point to any - other object, or it is in a pure section of the constant space). -*/ -Built_In_Primitive(Prim_Pure_P, 1, "PURE?", 0xBB) -{ - Primitive_1_Arg(); - - if ((GC_Type_Non_Pointer(Arg1)) || - (GC_Type_Special(Arg1))) - return TRUTH; - if (GC_Type_Compiled(Arg1)) - return NIL; - Touch_In_Primitive(Arg1, Arg1); - { - Pointer *Obj_Address; - - Obj_Address = Get_Pointer(Arg1); - if (Is_Pure(Obj_Address)) - return TRUTH; - } - return NIL; -} - -/* (CONSTANT? OBJECT) - Returns #!TRUE if the object is in constant space or isn't a - pointer. -*/ -Built_In_Primitive(Prim_Constant_P, 1, "CONSTANT?", 0xBA) -{ - Primitive_1_Arg(); - - Touch_In_Primitive(Arg1, Arg1); - return ((GC_Type_Non_Pointer(Arg1)) || - (GC_Type_Special(Arg1)) || - ((Get_Pointer(Arg1) >= Constant_Space) && - (Get_Pointer(Arg1) < Free_Constant))) ? - TRUTH : NIL; -} - -/* (GET-NEXT-CONSTANT) - Returns the next free address in constant space. -*/ -Built_In_Primitive(Prim_Get_Next_Constant, 0, "GET-NEXT-CONSTANT", 0xE4) -{ - Pointer *Next_Address; - - Next_Address = Free_Constant + 1; - Primitive_0_Args(); - return Make_Pointer(TC_ADDRESS, Next_Address); -} - -/* copy_to_constant_space is a microcode utility procedure. - It takes care of making legal constant space blocks. - The microcode kills itself if there is not enough constant - space left. - */ - -extern Pointer *copy_to_constant_space(); - -Pointer * -copy_to_constant_space(source, nobjects) - fast Pointer *source; - long nobjects; -{ - fast Pointer *dest; - fast long i; - Pointer *result; - - dest = Free_Constant; - if (!Test_Pure_Space_Top(dest + nobjects + 6)) - { - fprintf(stderr, - "copy_to_constant_space: Not enough constant space!\n"); - Microcode_Termination(TERM_NO_SPACE); - } - *dest++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 3); - *dest++ = Make_Non_Pointer(PURE_PART, nobjects + 5); - *dest++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1); - *dest++ = Make_Non_Pointer(CONSTANT_PART, 3); - result = dest; - for (i = nobjects; --i >= 0; ) - { - *dest++ = *source++; - } - *dest++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1); - *dest++ = Make_Non_Pointer(END_OF_BLOCK, nobjects + 5); - Free_Constant = dest; - - return result; -} diff --git a/v7/src/microcode/returns.h b/v7/src/microcode/returns.h deleted file mode 100644 index 8f23e3940..000000000 --- a/v7/src/microcode/returns.h +++ /dev/null @@ -1,118 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/returns.h,v 9.22 1987/04/16 02:28:30 jinx Exp $ - * - * Return codes. These are placed in Return when an - * interpreter operation needs to operate in several - * phases. This must correspond with UTABMD.SCM - * - */ - -/* These names are also in storage.c. - * Please maintain consistency. - */ - -#define RC_END_OF_COMPUTATION 0x00 -/* formerly RC_RESTORE_CONTROL_POINT 0x01 */ -#define RC_JOIN_STACKLETS 0x01 -#define RC_RESTORE_CONTINUATION 0x02 /* Used for 68000 */ -#define RC_INTERNAL_APPLY 0x03 -#define RC_BAD_INTERRUPT_CONTINUE 0x04 /* Used for 68000 */ -#define RC_RESTORE_HISTORY 0x05 -#define RC_INVOKE_STACK_THREAD 0x06 -#define RC_RESTART_EXECUTION 0x07 /* Used for 68000 */ -#define RC_EXECUTE_ASSIGNMENT_FINISH 0x08 -#define RC_EXECUTE_DEFINITION_FINISH 0x09 -#define RC_EXECUTE_ACCESS_FINISH 0x0A -#define RC_EXECUTE_IN_PACKAGE_CONTINUE 0x0B -#define RC_SEQ_2_DO_2 0x0C -#define RC_SEQ_3_DO_2 0x0D -#define RC_SEQ_3_DO_3 0x0E -#define RC_CONDITIONAL_DECIDE 0x0F -#define RC_DISJUNCTION_DECIDE 0x10 -#define RC_COMB_1_PROCEDURE 0x11 -#define RC_COMB_APPLY_FUNCTION 0x12 -#define RC_COMB_2_FIRST_OPERAND 0x13 -#define RC_COMB_2_PROCEDURE 0x14 -#define RC_COMB_SAVE_VALUE 0x15 -#define RC_PCOMB1_APPLY 0x16 -#define RC_PCOMB2_DO_1 0x17 -#define RC_PCOMB2_APPLY 0x18 -#define RC_PCOMB3_DO_2 0x19 -#define RC_PCOMB3_DO_1 0x1A -#define RC_PCOMB3_APPLY 0x1B - -#define RC_SNAP_NEED_THUNK 0x1C -#define RC_REENTER_COMPILED_CODE 0x1D -/* formerly RC_GET_CHAR_REPEAT 0x1E */ -#define RC_COMP_REFERENCE_RESTART 0x1F -#define RC_NORMAL_GC_DONE 0x20 -#define RC_COMPLETE_GC_DONE 0x21 /* Used for 68000 */ -#define RC_PURIFY_GC_1 0x22 -#define RC_PURIFY_GC_2 0x23 -#define RC_AFTER_MEMORY_UPDATE 0x24 /* Used for 68000 */ -#define RC_RESTARTABLE_EXIT 0x25 /* Used for 68000 */ -/* formerly RC_GET_CHAR 0x26 */ -/* formerly RC_GET_CHAR_IMMEDIATE 0x27 */ -#define RC_COMP_ASSIGNMENT_RESTART 0x28 -#define RC_POP_FROM_COMPILED_CODE 0x29 -#define RC_RETURN_TRAP_POINT 0x2A -#define RC_RESTORE_STEPPER 0x2B /* Used for 68000 */ -#define RC_RESTORE_TO_STATE_POINT 0x2C -#define RC_MOVE_TO_ADJACENT_POINT 0x2D -#define RC_RESTORE_VALUE 0x2E -#define RC_RESTORE_DONT_COPY_HISTORY 0x2F - -/* The following are not used in the 68000 implementation */ - -#define RC_POP_RETURN_ERROR 0x40 -#define RC_EVAL_ERROR 0x41 -#define RC_REPEAT_PRIMITIVE 0x42 -#define RC_COMP_INTERRUPT_RESTART 0x43 -/* formerly RC_COMP_RECURSION_GC 0x44 */ -#define RC_RESTORE_INT_MASK 0x45 -#define RC_HALT 0x46 -#define RC_FINISH_GLOBAL_INT 0x47 /* Multiprocessor */ -#define RC_REPEAT_DISPATCH 0x48 -#define RC_GC_CHECK 0x49 -#define RC_RESTORE_FLUIDS 0x4A -#define RC_COMP_LOOKUP_APPLY_RESTART 0x4B -#define RC_COMP_ACCESS_RESTART 0x4C -#define RC_COMP_UNASSIGNED_P_RESTART 0x4D -#define RC_COMP_UNBOUND_P_RESTART 0x4E -#define RC_COMP_DEFINITION_RESTART 0x4F -#define RC_COMP_LEXPR_INTERRUPT_RESTART 0x50 - -#define MAX_RETURN_CODE 0x50 - -/* When adding return codes, don't forget to update storage.c too. */ diff --git a/v7/src/microcode/sample.c b/v7/src/microcode/sample.c deleted file mode 100644 index 86ef18573..000000000 --- a/v7/src/microcode/sample.c +++ /dev/null @@ -1,215 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sample.c,v 9.21 1987/01/22 14:31:00 jinx Rel $ */ - -/* This file is intended to help you find out how to write primitives. - Many concepts needed to write primitives can be found by looking - at actual primitives in the system. Hence this file will often - ask you to look at other files that contain system primitives. -*/ - -/* Files that contain primitives must have the following includes - near the top of the file. -*/ -#include "scheme.h" -#include "primitive.h" - -/* Scheme.h supplies useful macros that are used throughout the - system, and primitive.h supplies macros that are used in defining - primitives. -*/ - -/* To make a primitive, you must use the macro Define_Primitive - with three arguments, followed by the body of C source code - that you want the primitive to execute. - The three arguments are: - 1. The name you want to give to this body of code (a C procedure - name). - 2. The number of arguments that this scheme primitive should - receive. Note: currently, this must be a number between - 0 and 3 inclusive. Hence primitives can currently take no more - than three arguments. - 3. A string representing the scheme name that you want to identify - this primitive with. - - The value returned by the body of code following the Define_Primitive - is the value of the scheme primitive. Note that this must be a - scheme Pointer object (with type tag and datum field), and not an - arbitrary C object. - - As an example, here is a primitive that takes no arguments and always - returns NIL (NIL is defined in scheme.h and identical to the scheme - object #!FALSE. TRUTH is identical to the scheme object #!TRUE -*/ - -Define_Primitive(Prim_Return_Nil, 0, "RETURN-NIL") -{ Primitive_0_Args(); - return NIL; -} - -/* This will create the primitive return-nil and when a new scheme is - made (with the Makefile properly edited to include this file), - evaluating (make-primitive-procedure 'return-nil) will return a - primitive procedure that when called with no arguments, will return - #!FALSE. -*/ - -/* Three macros are available for you to access the arguments to the - primitives. Primitive_N_Args(), where N is between 0 and 3 - inclusive binds Arg1 through ArgN to the arguments passed to the - primitive. They may also do some other initialization, so unless - you REALLY know what you are doing, you should use them in your - code. An important thing to note is that since Primitive_N_Args - may allocate variables, its use MUST come before any code in the - body of the C procedure. For example, here is a primitive that - takes one argument and returns it. -*/ - -Define_Primitive(Prim_Identity, 1, "IDENTITY") -{ Primitive_1_Arg(); - return Arg1; -} - -/* Some primitives may have to allocate space on the heap in order - to return lists or vectors. There are two things of importance to - note here. First, the primitive is responsible for making sure - that there is enough space on the heap for the new structure that - is being made. For instance, in making a PAIR, two words on the - heap are used, one to point to the CAR, one for CDR. The macro - Primitive_GC_If_Needed is supplied to let you check if there is - room on the heap. Primitive_GC_If_Needed takes one argument which - is the amount of space you would like to allocate. If there is not - enough space on the heap, a garbage collection happens and - afterwards the primitive is restarted with the same arguments. The - second thing to notice is that the primitive is responsible for - updating Free according to how many words of storage it has used - up. Note that the primitive is restarted, not continued, thus any - side effects must be done after the heap overflow check since - otherwise they would be done twice. - - A pair is object which has a type TC_LIST and points to the first - element of the pair. The macro Make_Pointer takes a type code and - an address or data and returns a scheme object with that type code - and that address or data. See scheme.h and the files included - there for the possible type codes. The following is the equivalent - of CONS and takes two arguments and returns the pair which contains - both arguments. For further examples on heap allocation, see the - primitives in list.c, hunk.c and vector.c. -*/ - -Define_Primitive(Prim_New_Cons, 2, "NEW-CONS") -{ Pointer *Temp; - Primitive_2_Args(); - /* Check to see if there is room in the heap for the pair */ - Primitive_GC_If_Needed(2); - /* Store the values in the heap, updating Free as we go along */ - Temp = Free; - Free += 2; - Temp[CONS_CAR] = Arg1; - Temp[CONS_CDR] = Arg2; - /* Return the pair, which points to the location of the car */ - return Make_Pointer(TC_LIST, Temp); -} - -/* The following primitive takes three arguments and returns a list - of them. Note how the CDR of the first two pairs points - to the next pair. Also, scheme objects are of type Pointer - (defined in object.h). Note that the result returned can be - held in a temporary variable even before the contents of the - object are stored in heap. -*/ - -Define_Primitive(Prim_Utterly_Random, 3, "WHY-SHOULDNT-THE-NAME-BE-RANDOM?") -{ /* Hold the end result in a temporary variable while we - fill in the list. - */ - Pointer *Result; - Primitive_3_Args(); - /* Check to see if there is enough space on the heap. */ - Primitive_GC_If_Needed(6); - Result = Free; - Free[CONS_CAR] = Arg1; - /* Make the CDR of the first pair point to the second pair. */ - Free[CONS_CDR] = Make_Pointer(TC_LIST, Free+2); - /* Bump it over to the second pair */ - Free += 2; - Free[CONS_CAR] = Arg2; - /* Make the CDR of the second pair point to the third pair. */ - Free[CONS_CDR] = Make_Pointer(TC_LIST, Free+2); - /* Bump it over to the third pair */ - Free += 2; - Free[CONS_CAR] = Arg3; - /* Make the last CDR a () to make a "proper" list */ - Free[CONS_CDR] = NIL; - /* Bump Free over to the first available location */ - Free += 2; - return Make_Pointer(TC_LIST, Result); -} - -/* Several Macros are supplied to do arithmetic with scheme numbers. - Scheme_Integer_To_C_Integer takes a scheme object and the address - of a long. If the scheme object is not of type TC_FIXNUM or - TC_BIG_FIXNUM, then the macro returns ERR_ARG_1_WRONG_TYPE. If the - scheme number doesn't fit into a long, the macro returns - ERR_ARG_1_BAD_RANGE. Otherwise the macro stores the integer - represented by the scheme object into the long. - C_Integer_To_Scheme_Integer takes a long and returns a scheme - object of type either TC_FIXNUM or TC_BIG_FIXNUM that represents - that long. Here is a primitive that tries to add 3 to it's - argument. Note how scheme errors are performed via - Primitive_Error({error-code}). See scheme.h and included files for - the possible error codes. -*/ - -Define_Primitive(Prim_Add_3, 1, "3+") -{ long value; - int flag; - Primitive_1_Arg(); - flag = Scheme_Integer_To_C_Integer(Arg1, &value); - if (flag == PRIM_DONE) - return C_Integer_To_Scheme_Integer(value + 3); - /* If flag is not equal to PRIM_DONE, then it is one of two - errors. We can signal either error by calling Primitive_Error - with that error code - */ - Primitive_Error(flag); -} - -/* See fixnum.c for more fixnum primitive examples. float.c - gives floating point examples and bignum.c gives bignum - examples (Warning: the bignum code is not trivial). generic.c - gives examples on arithmetic operations that work for - all scheme number types. For efficiency reasons, they do not - always use this convenient interface. - */ - diff --git a/v7/src/microcode/scheme.h b/v7/src/microcode/scheme.h deleted file mode 100644 index 35e9f040b..000000000 --- a/v7/src/microcode/scheme.h +++ /dev/null @@ -1,90 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/scheme.h,v 9.23 1987/04/16 02:28:57 jinx Exp $ - * - * General declarations for the SCode interpreter. This - * file is INCLUDED by others and contains declarations only. - */ - -/* Certain debuggers cannot really deal with variables in registers. - When debugging, NO_REGISTERS can be defined. -*/ - -#ifdef NO_REGISTERS -#define fast -#else -#define fast register -#endif - -#define quick fast - -#ifdef ENABLE_DEBUGGING_TOOLS -#define Consistency_Check true -#else -#define Consistency_Check false -#endif - -#ifdef COMPILE_STEPPER -#define Microcode_Does_Stepping true -#else -#define Microcode_Does_Stepping false -#endif - -#define forward extern /* For forward references */ - -#include -#include - -#include "config.h" /* Machine and OS configuration info */ -#include "types.h" /* Type code numbers */ -#include "const.h" /* Various named constants */ -#include "object.h" /* Scheme object representation */ -#include "gc.h" /* Garbage collector related macros */ -#include "scode.h" /* Scheme scode representation */ -#include "sdata.h" /* Scheme user data representation */ -#include "futures.h" /* Support macros, etc. for FUTURE */ -#include "errors.h" /* Error code numbers */ -#include "returns.h" /* Return code numbers */ -#include "fixobj.h" /* Format of fixed objects vector */ -#include "stack.h" /* Macros for stack (stacklet) manipulation */ -#include "history.h" /* History maintenance */ -#include "interpret.h" /* Macros for interpreter */ - -#ifdef butterfly -#include "butterfly.h" -#endif - -#include "bkpt.h" /* Shadows some defaults */ -#include "default.h" /* Defaults for various hooks. */ -#include "extern.h" /* External declarations */ -#include "prim.h" /* Declarations for external primitives. */ diff --git a/v7/src/microcode/scode.h b/v7/src/microcode/scode.h deleted file mode 100644 index 243fa65cb..000000000 --- a/v7/src/microcode/scode.h +++ /dev/null @@ -1,189 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/scode.h,v 9.22 1987/04/03 00:20:19 jinx Rel $ - * - * Format of the SCode representation of programs. Each of these - * is described in terms of the slots in the data structure. - * - */ - -/* Here are the definitions of the the executable operations for the - interpreter. This file should parallel the file SCODE.SCM in the - runtime system. The interpreter dispatches on the type code of a - pointer to determine what operation to perform. The format of the - storage block this points to is described below. Offsets are the - number of cells from the location pointed to by the operation. */ - -/* ALPHABETICALLY LISTED BY TYPE CODE NAME */ - -/* ACCESS operation: */ -#define ACCESS_ENVIRONMENT 0 -#define ACCESS_NAME 1 - -/* ASSIGNMENT operation: */ -#define ASSIGN_NAME 0 -#define ASSIGN_VALUE 1 - -/* COMBINATIONS come in several formats */ - -/* General combinations are vector-like: */ -#define COMB_VECTOR_HEADER 0 -#define COMB_FN_SLOT 1 -#define COMB_ARG_1_SLOT 2 - -/* Short non-primitive combinations: */ -#define COMB_1_FN 0 -#define COMB_1_ARG_1 1 - -#define COMB_2_FN 0 -#define COMB_2_ARG_1 1 -#define COMB_2_ARG_2 2 - -/* COMMENT operation: */ -#define COMMENT_EXPRESSION 0 -#define COMMENT_TEXT 1 - -/* CONDITIONAL operation (used for COND, IF, AND): */ -#define COND_PREDICATE 0 -#define COND_CONSEQUENT 1 -#define COND_ALTERNATIVE 2 - -/* DEFINITION operation: */ -#define DEFINE_NAME 0 -#define DEFINE_VALUE 1 - -/* DELAY operation: */ -#define DELAY_OBJECT 0 -#define DELAY_UNUSED 1 - -/* DISJUNCTION or OR operation: */ -#define OR_PREDICATE 0 -#define OR_ALTERNATIVE 1 - -/* EXTENDED_LAMBDA operation: - * Support for optional parameters and auxiliary local variables. The - * Extended Lambda is similar to LAMBDA, except that it has an extra - * word called the ARG_COUNT. This contains an 8-bit count of the - * number of optional arguments, an 8-bit count of the number of - * required (formal) parameters, and a bit to indicate that additional - * (rest) arguments are allowed. The vector of argument names - * contains, of course, a size count which allows the calculation of - * the number of auxiliary variables required. Auxiliary variables - * are created for any internal DEFINEs which are found at syntax time - * in the body of a LAMBDA-like special form. - */ - -#define ELAMBDA_SCODE 0 -#define ELAMBDA_NAMES 1 -#define ELAMBDA_ARG_COUNT 2 - -/* Masks. The infomation on the number of each type of argument is - * separated at byte boundaries for easy extraction in the 68000 code. - */ - -#define EL_OPTS_MASK 0xFF -#define EL_FORMALS_MASK 0xFF00 -#define EL_REST_MASK 0x10000 -#define EL_FORMALS_SHIFT 8 -#define EL_REST_SHIFT 16 - -/* Selectors */ - -#define Get_Body_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_SCODE)) -#define Get_Names_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_NAMES)) -#define Get_Count_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_ARG_COUNT)) -#define Elambda_Formals_Count(Addr) \ - ((((long) Addr) & EL_FORMALS_MASK) >> EL_FORMALS_SHIFT) -#define Elambda_Opts_Count(Addr) \ - (((long) Addr) & EL_OPTS_MASK) -#define Elambda_Rest_Flag(Addr) \ - ((((long) Addr) & EL_REST_MASK) >> EL_REST_SHIFT) - -/* IN-PACKAGE operation: */ -#define IN_PACKAGE_ENVIRONMENT 0 -#define IN_PACKAGE_EXPRESSION 1 - -/* LAMBDA operation: - * Object representing a LAMBDA expression with a fixed number of - * arguments. It consists of a list of the names of the arguments - * (the first is the name by which the procedure refers to itself) and - * the SCode for the procedure. - */ - -#define LAMBDA_SCODE 0 -#define LAMBDA_FORMALS 1 - -/* LEXPR - * Same as LAMBDA (q.v.) except additional arguments are permitted - * beyond those indicated in the LAMBDA_FORMALS list. - */ - -/* Primitive combinations with 0 arguments are not pointers */ - -/* Primitive combinations, 1 argument: */ -#define PCOMB1_FN_SLOT 0 -#define PCOMB1_ARG_SLOT 1 - -/* Primitive combinations, 2 arguments: */ -#define PCOMB2_FN_SLOT 0 -#define PCOMB2_ARG_1_SLOT 1 -#define PCOMB2_ARG_2_SLOT 2 - -/* Primitive combinations, 3 arguments are vector-like: */ -#define PCOMB3_FN_SLOT 1 -#define PCOMB3_ARG_1_SLOT 2 -#define PCOMB3_ARG_2_SLOT 3 -#define PCOMB3_ARG_3_SLOT 4 - -/* SCODE_QUOTE returns itself */ -#define SCODE_QUOTE_OBJECT 0 -#define SCODE_QUOTE_IGNORED 1 - -/* SEQUENCE operations (two forms: SEQUENCE_2 and SEQUENCE_3) */ -#define SEQUENCE_1 0 -#define SEQUENCE_2 1 -#define SEQUENCE_3 2 - -/* VARIABLE operation. - * Corresponds to a variable lookup or variable reference. Contains the - * symbol referenced, and (if it has been compiled) the frame and - * offset in the frame in which it was found. One of these cells is - * multiplexed by having its type code indicate one of several modes - * of reference: not yet compiled, local reference, formal reference, - * auxiliary reference, or global value reference. - * There are extra definitions in lookup.h. - */ -#define VARIABLE_SYMBOL 0 -#define VARIABLE_FRAME_NO 1 -#define VARIABLE_OFFSET 2 -#define VARIABLE_COMPILED_TYPE 1 diff --git a/v7/src/microcode/sdata.h b/v7/src/microcode/sdata.h deleted file mode 100644 index 03f0c0274..000000000 --- a/v7/src/microcode/sdata.h +++ /dev/null @@ -1,412 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sdata.h,v 9.23 1987/04/16 02:29:06 jinx Exp $ - * - * Description of the user data objects. This should parallel the - * file SDATA.SCM in the runtime system. - * - */ - -/* Alphabetical order. Every type of object is described either with a - comment or with offsets describing locations of various parts. */ - -/* ADDRESS - * is a FIXNUM. It represents a 24-bit address. Not a pointer type. - */ - -/* BIG_FIXNUM (bignum). - * See the file BIGNUM.C - */ - -/* BIG_FLONUM (flonum). - * Implementation dependent format (uses C data type "double"). Pointer - * to implemetation defined floating point format. - */ - -/* BROKEN_HEART. - * "Forwarding address" used by garbage collector to indicate that an - * object has been moved to a new location. These should never be - * encountered by the interpreter! - */ - -/* CELL. - * An object that points to one other object (extra indirection). - * Used by the compiler to share objects. - */ -#define CELL_CONTENTS 0 - -/* CHARACTER - * Not currently used. Intended ultimately to complete the abstraction - * of strings. This will probably be removed eventually. - */ - -/* CHARACTER_STRING - * Synonym for 8B_VECTOR. Used to store strings of characters. Format - * consists of the normal non-marked vector header (STRING_HEADER) - * followed by the number of characters in the string (as a FIXNUM), - * followed by the characters themselves. - */ -#define STRING_HEADER 0 -#define STRING_LENGTH 1 -#define STRING_CHARS 2 - -/* COMPILED_PROCEDURE */ -#define COMP_PROCEDURE_ADDRESS 0 -#define COMP_PROCEDURE_ENV 1 - -/* CONTINUATION - * Pushed on the control stack by the interpreter, each has two parts: - * the return address within the interpreter (represented as a type - * code RETURN_ADDRESS and address part RC_xxx), and an expression - * which was being evaluated at that time (sometimes just used as - * additional data needed at the return point). The offsets given - * here are with respect to the stack pointer as it is located - * immediately after pushing a continuation (or, of course, - * immediately before popping it back). - * - * HISTORY_SIZE is the size of a RESTORE_HISTORY (or - * RESTORE_DONT_COPY_HISTORY) continuation. - */ - -#define CONTINUATION_EXPRESSION 1 -#define CONTINUATION_RETURN_CODE 0 -#define CONTINUATION_SIZE 2 -#define HISTORY_SIZE (CONTINUATION_SIZE + 2) - -/* CONTROL_POINT - * Points to a copy of the control stack at the time a control point is - * created. This is the saved state of the interpreter, and can be - * restored later by APPLYing the control point to an argument (i.e. a - * throw). Format is that of an ordinary vector. They are linked - * together by using the return code RC_JOIN_STACKLETS. - */ - -/* If USE_STACKLETS is defined, then a stack (i.e. control point) is - actually made from smaller units allocated from the heap and linked - together. The format is: - - 0 memory address - - _______________________________________ - |MAN. VECT.| n | - _ _______________________________________ - / | NM VECT | m at GC or when full | - | _______________________________________ - | | ... |\ - | | not yet in use -- garbage | > m - n < _______________________________________/ - | | Top of Stack, useful contents | <---Stack_Pointer - | _______________________________________ - \ | ... | - \ | useful stuff | - \_ ________________________________________ - <---Stack_Top - infinite memory address - -*/ - -#define STACKLET_LENGTH 0 /* = VECTOR_LENGTH */ -#define STACKLET_HEADER_SIZE 2 -#define STACKLET_UNUSED_LENGTH 1 -#define STACKLET_FREE_LIST_LINK 1 /* If on free list */ - -/* DELAYED - * The object returned by a DELAY operation. Consists initially of a - * procedure to be APPLYed and environment. After the FORCE primitive - * is applied to the object, the result is stored in the DELAYED object - * and further FORCEs return this same result. I.e. FORCE memoizes the - * value of the DELAYED object. For historical reasons, such an object - * is called a 'thunk.' - */ -#define THUNK_SNAPPED 0 -#define THUNK_VALUE 1 -#define THUNK_ENVIRONMENT 0 -#define THUNK_PROCEDURE 1 - -/* ENVIRONMENT - * Associates identifiers with values. - * The identifiers are either from a lambda-binding (as in a procedure - * call) or a incremental (run-time) DEFINE (known as an 'auxilliary' - * binding). - * When an environment frame is created, it only contains lambda - * bindings. If incremental defines are performed in it or its - * children, it acquires an extension which contains a list of the - * auxiliary bindings. Some of these bindings are fictitious in that - * their only purpose is to make the real bindings (if and when they - * occur) become automatically dangerous. Bindings become dangerous - * when they are shadowed by incremental bindings in children frames. - * Besides the lambda bindings, an environment frame contains a - * pointer to the procedure which created it. It is through this - * procedure that the parent frame is found. - * - * An environment frame has three distinct stages in its formation: - * - A STACK_COMBINATION is the structure built on the stack to - * evaluate normal (long) combinations. It contains a slot for the - * finger and the combination whose operands are being evaluated. - * Only some of the argument slots in a stack-combination are - * meaningful: those which have already been evaluated (those not - * "hidden" by the finger). This is the first stage. - * - A STACK_ENVIRONMENT is the format used at Internal_Apply - * just as an application is about to occur. - * - An ENVIRONMENT is a real environment frame, containing - * associations between names and values. It is the final stage, and - * corresponds to the structure described above. - */ - -#define ENVIRONMENT_HEADER 0 -#define ENVIRONMENT_FUNCTION 1 -#define ENVIRONMENT_FIRST_ARG 2 - -#define STACK_ENV_EXTRA_SLOTS 1 -#define STACK_ENV_HEADER 0 -#define STACK_ENV_FUNCTION 1 -#define STACK_ENV_FIRST_ARG 2 - -#define STACK_COMB_FINGER 0 -#define STACK_COMB_FIRST_ARG 1 - -/* An environment chain always ends in a pointer with type code - of GLOBAL_ENV. This will contain an address part which - either indicates that the lookup should continue on to the - true global environment, or terminate at this frame. */ - -#define GO_TO_GLOBAL 0 -#define END_OF_CHAIN 1 - -/* Environment extension objects: - - These objects replace the procedure in environment frames when an - aux slot is desired. The parent frame is copied into the extension - so that the "compiled" lookup code does not have to check whether - the frame has been extended or not. - - Note that for the code to work, ENV_EXTENSION_PARENT_FRAME must be - equal to PROCEDURE_ENVIRONMENT. - - The following constants are implicitely hard-coded in lookup.c, - where a new extension object is consed in extend_frame. - */ - -#define ENV_EXTENSION_HEADER 0 -#define ENV_EXTENSION_PARENT_FRAME 1 -#define ENV_EXTENSION_PROCEDURE 2 -#define ENV_EXTENSION_COUNT 3 -#define ENV_EXTENSION_MIN_SIZE 4 - -/* EXTENDED_FIXNUM - * Not used in the C version. On the 68000 this is used for 24-bit - * integers, while FIXNUM is used for 16-bit integers. - */ - -/* EXTENDED_PROCEDURE - * Type of procedure created by evaluation of EXTENDED_LAMBDA. - * It's fields are the same as those for PROCEDURE. - */ - -/* FALSE - * Alternate name for NULL. This is the type code of objects which are - * considered as false for the value of predicates. - */ - -/* FIXNUM - * Small integer. Fits in the datum portion of a Scheme Pointer. - */ - -/* HUNK3 - * User object like a CONS, but with 3 slots rather than 2. - */ -#define HUNK_CXR0 0 -#define HUNK_CXR1 1 -#define HUNK_CXR2 2 - -/* INTERNED_SYMBOL - * A symbol, such as the result of evaluating (QUOTE A). Some - * important properties of symbols are that they have a print name, - * and may be 'interned' so that all instances of a symbol with the - * same name share a unique object. The storage pointed to by a - * symbol includes both the print name (a string) and the value cell - * associated with a variable of that name in the global environment. - */ -#define SYMBOL_NAME 0 -#define SYMBOL_GLOBAL_VALUE 1 - -/* LIST - * Ordinary CONS cell as supplied to a user. Perhaps this data type is - * misnamed ... CONS or PAIR would be better. - */ -#define CONS_CAR 0 -#define CONS_CDR 1 - -/* MANIFEST_NM_VECTOR - * Not a true object, this type code is used to indicate the start of a - * vector which contains objects other than Scheme pointers. The - * address portion indicates the number of cells of non-pointers - * which follow the header word. For use primarily in garbage - * collection to indicate the number of words to copy but not trace. - */ - -/* MANIFEST_SPECIAL_NM_VECTOR Similar to MANIFEST_NM_VECTOR but the - * contents are relocated when loaded by the FALOADer. This header - * occurs in pure and constant space to indicate the start of a region - * which contains Pointers to addresses which are known never to move in - * the operation of the system. - */ - -/* MANIFEST_VECTOR - * Synonym for NULL, used as first cell in a vector object to indicate - * how many cells it occupies. Usage is similar to MANIFEST_NM_VECTOR - */ - -/* NON_MARKED_VECTOR - * User-visible object containing arbitrary bits. Not currently used. - * The data portion will always point to a MANIFEST_NM_VECTOR or - * MANIFEST_SPECIAL_NM_VECTOR specifying the length of the vector. - */ -#define NM_VECTOR_HEADER 0 -#define NM_ENTRY_COUNT 1 -#define NM_DATA 2 -#define NM_HEADER_LENGTH 2 - -/* NULL - * The type code used by predicates to test for 'false' and by list - * operations for testing for the end of a list. - */ - -/* PRIMITIVE - * The data portion contains a number specifying a particular primitive - * operation to be performed. An object of type PRIMITIVE can be - * APPLYed in the same way an object of type PROCEDURE can be. - */ - -/* PRIMITIVE_EXTERNAL - * Functionally identical to PRIMITIVE. The distinctions are that a - * PRIMITIVE is constrained to take no more than 3 arguments, PRIMITIVEs - * can be formed into more efficient PRIMITIVE-COMBINATIONs by a - * compiler, and that PRIMITIVE_EXTERNALs are user supplied. - */ - -/* PROCEDURE (formerly CLOSURE) - * Consists of two parts: a LAMBDA expression and the environment - * in which the LAMBDA was evaluated to yield the PROCEDURE. - */ -#define PROCEDURE_LAMBDA_EXPR 0 -#define PROCEDURE_ENVIRONMENT 1 - -/* REFERENCE_TRAP - * Causes the variable lookup code to trap. - * Used to implement a variety of features. - * This type code is really the collection of two, done this way for efficiency. - * Traps whose datum is less than TRAP_MAX_IMMEDIATE are immediate (not pointers). - * The rest are pairs. The garbage collector deals with them specially. - */ - -#define TRAP_TAG 0 -#define TRAP_EXTRA 1 - -/* RETURN_CODE - * Represents an address where computation is to continue. These can be - * thought of as states in a finite state machine, labels in an assembly - * language program, or continuations in a formal semantics. When the - * interpretation of a single SCode item requires the EVALuation of a - * subproblem, a RETURN_CODE is left behind indicating where computation - * continues after the evaluation. - */ - -/* STATE_POINT and STATE_SPACE - * Data structures used to keep track of dynamic wind state. Both of - * these are actually ordinary vectors with a special tag in the first - * user accessible slot. A STATE_SPACE consists of just a pointer to - * the current point in that space. A STATE_POINT contains a - * procedure to be used when moving through the point (the forward - * thunk), an alternate procedure to undo the effects of the first - * (the backward thunk), and the point to which you can move directly - * from this point. - */ - -#define STATE_POINT_HEADER 0 -#define STATE_POINT_TAG 1 -#define STATE_POINT_BEFORE_THUNK 2 -#define STATE_POINT_AFTER_THUNK 3 -#define STATE_POINT_NEARER_POINT 4 -#define STATE_POINT_DISTANCE_TO_ROOT 5 -#define STATE_POINT_SIZE 6 - -#define STATE_SPACE_HEADER 0 -#define STATE_SPACE_TAG 1 -#define STATE_SPACE_NEAREST_POINT 2 -#define STATE_SPACE_SIZE 3 - -/* When in RC_MOVE_TO_ADJACENT_POINT in the interpreter, the following - information is available on the stack (placed there by - Translate_To_Point -*/ -#define TRANSLATE_FROM_POINT 0 -#define TRANSLATE_FROM_DISTANCE 1 -#define TRANSLATE_TO_POINT 2 -#define TRANSLATE_TO_DISTANCE 3 - -/* TRUE - * The initial binding of the variable T is to an object of this type. - * This type is the beginnings of a possible move toward a system where - * predicates check for TRUE / FALSE rather than not-NULL / NULL. - */ - -/* UNINTERNED_SYMBOL - * This indicates that the object is in the format of an INTERNED_SYMBOL - * but is not interned. - */ - -/* VECTOR - * A group of contiguous cells with a header (of type MANIFEST_VECTOR) - * indicating the length of the group. - */ -#define VECTOR_TYPE 0 -#define VECTOR_LENGTH 0 -#define VECTOR_DATA 1 - -/* VECTOR_16B - * Points to a MANIFEST_NM_VECTOR or MANIFEST_SPECIAL_NM_VECTOR header. - * The format is described under NON_MARKED_VECTOR. The contents are to - * be treated as an array of 16-bit signed or unsigned quantities. Not - * currently used, although this may be a useful way to allow users to - * inspect the internal representation of bignums. - */ - -/* VECTOR_1B - * Similar to VECTOR_16B, but used for a compact representation of an - * array of booleans. - */ - -/* VECTOR_8B - * An alternate name of CHARACTER_STRING. - */ diff --git a/v7/src/microcode/stack.h b/v7/src/microcode/stack.h deleted file mode 100644 index 5c6b44267..000000000 --- a/v7/src/microcode/stack.h +++ /dev/null @@ -1,335 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/stack.h,v 9.21 1987/04/16 02:29:23 jinx Exp $ */ - -/* This file contains macros for manipulating stacks and stacklets. */ - -#ifdef USE_STACKLETS -/* Stack is made up of linked small parts, each in the heap */ - -#define Initialize_Stack() \ -{ \ - if (GC_Check(Default_Stacklet_Size)) \ - Microcode_Termination(TERM_STACK_ALLOCATION_FAILED); \ - Stack_Guard = Free+STACKLET_HEADER_SIZE; \ - *Free = Make_Non_Pointer(TC_MANIFEST_VECTOR, Default_Stacklet_Size-1); \ - Free += Default_Stacklet_Size; \ - Stack_Pointer = Free; \ - Free_Stacklets = NULL; \ - Prev_Restore_History_Stacklet = NULL; \ - Prev_Restore_History_Offset = 0; \ -} - -#define Internal_Will_Push(N) \ -{ \ - if ((Stack_Pointer - (N)) < Stack_Guard) \ - { Export_Registers(); \ - Allocate_New_Stacklet((N)); \ - Import_Registers(); \ - } \ -} - -/* No space required independent of the heap for the stacklets */ - -#define Stack_Allocation_Size(Stack_Blocks) 0 - -#define Current_Stacklet (Stack_Guard-STACKLET_HEADER_SIZE) - -/* Make the unused portion of the old stacklet invisible to garbage - * collection. This also allows the stack pointer to be reconstructed. - */ - -#define Internal_Terminate_Old_Stacklet() \ -{ \ - Current_Stacklet[STACKLET_UNUSED_LENGTH] = \ - Make_Non_Pointer((DANGER_TYPE | TC_MANIFEST_NM_VECTOR), \ - Stack_Pointer-Stack_Guard); \ -} - -#ifdef ENABLE_DEBUGGING_TOOLS - -#define Terminate_Old_Stacklet() \ -{ \ - if (Stack_Pointer < Stack_Guard) \ - { \ - fprintf(stderr, "\nStack_Pointer: 0x%x, Guard: 0x%x\n", \ - Stack_Pointer, Stack_Guard); \ - Microcode_Termination(TERM_EXIT); \ - } \ - Internal_Terminate_Old_Stacklet(); \ -} - -#else - -#define Terminate_Old_Stacklet() Internal_Terminate_Old_Stacklet() - -#endif - -/* Used by garbage collector to detect the end of constant space */ -#define Terminate_Constant_Space(Where) \ - *Free_Constant = Make_Pointer(TC_BROKEN_HEART, Free_Constant); \ - Where = Free_Constant - -#define Get_Current_Stacklet() \ - Make_Pointer(TC_CONTROL_POINT, Current_Stacklet) - -#define Previous_Stack_Pointer(Where) \ - Nth_Vector_Loc(Where, \ - (STACKLET_HEADER_SIZE+ \ - Get_Integer(Vector_Ref(Where, \ - STACKLET_UNUSED_LENGTH)))) - -#define Set_Current_Stacklet(Where) \ -{ Pointer Our_Where = (Where); \ - Stack_Guard = Nth_Vector_Loc(Our_Where, STACKLET_HEADER_SIZE); \ - Stack_Pointer = Previous_Stack_Pointer(Our_Where); \ -} - -#define STACKLET_SLACK STACKLET_HEADER_SIZE + CONTINUATION_SIZE -#define Default_Stacklet_Size (Stack_Size+STACKLET_SLACK) -#define New_Stacklet_Size(N) \ - (STACKLET_SLACK + Stack_Size * (((N) + Stack_Size - 1)/Stack_Size)) - -#define Get_End_Of_Stacklet() \ - (&(Current_Stacklet[1+Get_Integer(*Current_Stacklet)])) - -#define Apply_Stacklet_Backout() \ -Will_Push(2*CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \ - Store_Expression(NIL); \ - Store_Return(RC_END_OF_COMPUTATION); \ - Save_Cont(); \ - Push(Val); \ - Push(Previous_Stacklet); \ - Push(STACK_FRAME_HEADER+1); \ - Store_Return(RC_INTERNAL_APPLY); \ - Save_Cont(); \ -Pushed() - -#define Join_Stacklet_Backout() Apply_Stacklet_Backout() - -/* This depends on the fact that Within_Control_Point is going to - * push an apply frame immediately after Return_To_Previous_Stacklet - * "returns". This apply will cause the GC, then the 2nd argument to - * Within_Control_Point will be invoked, and finally the control point - * will be entered. - */ - -#define Within_Stacklet_Backout() \ -{ Pointer Old_Expression = Fetch_Expression(); \ - Store_Expression(Previous_Stacklet); \ - Store_Return(RC_JOIN_STACKLETS); \ - Save_Cont(); \ - Store_Expression(Old_Expression); \ -} - -/* Our_Throw is used in chaining from one stacklet - * to another. In order to improve efficiency, the entire stack is - * copied neither on catch or throw, but is instead copied one - * stacklet at a time as needed. The need to copy a stacklet is - * signified by the danger bit being set in the header of a stacklet. - * If the danger bit is found to be set in a stacklet which is being - * returned into then that stacklet is copied and the danger bit is - * set in the stacklet into which the copied one will return. When a - * stacklet is returned from it is no longer needed for anything so it - * can be deallocated. A free list of deallocate stacklets is kept in - * order to improve the efficiencty of their use. - */ - -#define Our_Throw(From_Pop_Return, Stacklet) \ -{ Pointer Previous_Stacklet = (Stacklet); \ - Pointer *Stacklet_Top = Current_Stacklet; \ - Stacklet_Top[STACKLET_FREE_LIST_LINK] = \ - ((Pointer) Free_Stacklets); \ - Free_Stacklets = Stacklet_Top; \ - if (!(From_Pop_Return)) \ - { Prev_Restore_History_Stacklet = NULL; \ - Prev_Restore_History_Offset = 0; \ - } \ - if (!(Dangerous(Fast_Vector_Ref(Previous_Stacklet, \ - STACKLET_UNUSED_LENGTH)))) \ - { if (GC_Check(Vector_Length(Previous_Stacklet) + 1)) \ - { Free_Stacklets = \ - ((Pointer *) Free_Stacklets[STACKLET_FREE_LIST_LINK]); \ - Stack_Pointer = Get_End_Of_Stacklet(); \ - Prev_Restore_History_Stacklet = NULL; \ - Prev_Restore_History_Offset = 0; - - /* Backout code inserted here, SUN screw up! */ - - /* Backout code inserted here, SUN screw up! */ - -#define Our_Throw_Part_2() \ - Request_GC(Vector_Length(Previous_Stacklet) + 1); \ - } \ - else /* Space available for copy */ \ - { long Unused_Length, Used_Length; \ - fast Pointer *Old_Stacklet_Top = \ - Get_Pointer(Previous_Stacklet); \ - Pointer *First_Continuation = \ - Nth_Vector_Loc(Previous_Stacklet, \ - ((1 + Vector_Length(Previous_Stacklet)) - \ - CONTINUATION_SIZE)); \ - if (Old_Stacklet_Top == Prev_Restore_History_Stacklet) \ - Prev_Restore_History_Stacklet = NULL; \ - if (First_Continuation[CONTINUATION_RETURN_CODE] == \ - Make_Non_Pointer(TC_RETURN_CODE, RC_JOIN_STACKLETS)) \ - { Pointer *Even_Older_Stacklet = \ - Get_Pointer(First_Continuation[CONTINUATION_EXPRESSION]);\ - Clear_Danger_Bit(Even_Older_Stacklet[STACKLET_UNUSED_LENGTH]);\ - } \ - Stack_Guard = &(Free[STACKLET_HEADER_SIZE]); \ - Free[STACKLET_LENGTH] = Old_Stacklet_Top[STACKLET_LENGTH];\ - Unused_Length = \ - Get_Integer(Old_Stacklet_Top[STACKLET_UNUSED_LENGTH]) + \ - STACKLET_HEADER_SIZE; \ - Free += Unused_Length; \ - Stack_Pointer = Free; \ - Used_Length = \ - (Get_Integer(Old_Stacklet_Top[STACKLET_LENGTH]) - \ - Unused_Length) + 1; \ - Old_Stacklet_Top += Unused_Length; \ - while (--Used_Length >= 0) *Free++ = *Old_Stacklet_Top++; \ - } \ - } \ - else /* No need to copy the stacklet we are going into */ \ - { if (Get_Pointer(Previous_Stacklet)== \ - Prev_Restore_History_Stacklet) \ - Prev_Restore_History_Stacklet = NULL; \ - Set_Current_Stacklet(Previous_Stacklet); \ - } \ -} - -#else - -/* Full size stack in a statically allocated area */ - -#define Stack_Check(P) \ -{ \ - if ((P) <= Stack_Guard) \ - { if ((P) <= Absolute_Stack_Base) \ - Microcode_Termination (TERM_STACK_OVERFLOW); \ - Request_Interrupt (INT_Stack_Overflow); \ - } \ -} - -#define Internal_Will_Push(N) Stack_Check(Stack_Pointer - (N)) - -#define Stack_Allocation_Size(Stack_Blocks) (Stack_Blocks) - -#define Terminate_Old_Stacklet() - -/* Used by garbage collector to detect the end of constant space, and to - skip over the gap between constant space and the stack. */ - -#define Terminate_Constant_Space(Where) \ -{ \ - *Free_Constant = \ - Make_Non_Pointer (TC_MANIFEST_NM_VECTOR, \ - ((Stack_Pointer - Free_Constant) - 1)); \ - *Stack_Top = Make_Pointer (TC_BROKEN_HEART, Stack_Top); \ - Where = Stack_Top; \ -} - -#define Get_Current_Stacklet() NIL - -#define Set_Current_Stacklet(Where) {} - -#define Previous_Stack_Pointer(Where) \ -(Nth_Vector_Loc (Where, \ - (STACKLET_HEADER_SIZE + \ - Get_Integer (Vector_Ref (Where, \ - STACKLET_UNUSED_LENGTH))))) - -/* Never allocate more space */ -#define New_Stacklet_Size(N) 0 - -#define Get_End_Of_Stacklet() Stack_Top - -/* Not needed in this version */ - -#define Join_Stacklet_Backout() -#define Apply_Stacklet_Backout() -#define Within_Stacklet_Backout() - -/* This piece of code KNOWS which way the stack grows. - The assumption is that successive pushes modify decreasing addresses. */ - -/* Clear the stack and replace it with a copy of the contents of the - control point. Also disables the history collection mechanism, - since the saved history would be incorrect on the new stack. */ - -#define Our_Throw(From_Pop_Return, P) \ -{ \ - Pointer Control_Point; \ - long NCells, Offset; \ - fast Pointer *To_Where, *From_Where; \ - fast long len; \ - \ - Control_Point = (P); \ - if (Consistency_Check) \ - if (Type_Code (Control_Point) != TC_CONTROL_POINT) \ - Microcode_Termination (TERM_BAD_STACK); \ - len = Vector_Length (Control_Point); \ - NCells = ((len - 1) \ - - Get_Integer (Vector_Ref (Control_Point, \ - STACKLET_UNUSED_LENGTH))); \ - IntCode &= (~ INT_Stack_Overflow); \ - Stack_Check (Stack_Top - NCells); \ - From_Where = Nth_Vector_Loc (Control_Point, STACKLET_HEADER_SIZE); \ - From_Where = Nth_Vector_Loc (Control_Point, ((len + 1) - NCells)); \ - To_Where = (Stack_Top - NCells); \ - Stack_Pointer = To_Where; \ - for (len = 0; len < NCells; len++) \ - *To_Where++ = *From_Where++; \ - if (Consistency_Check) \ - if ((To_Where != Stack_Top) || \ - (From_Where != Nth_Vector_Loc (Control_Point, \ - (1 + Vector_Length (Control_Point))))) \ - Microcode_Termination (TERM_BAD_STACK); \ - if (!(From_Pop_Return)) \ - { \ - Prev_Restore_History_Stacklet = NULL; \ - Prev_Restore_History_Offset = 0; \ - if ((!Valid_Fixed_Obj_Vector ()) || \ - (Get_Fixed_Obj_Slot (Dummy_History) == NIL)) \ - History = Make_Dummy_History (); \ - else \ - History = Get_Pointer (Get_Fixed_Obj_Slot (Dummy_History)); \ - } \ - else if (Prev_Restore_History_Stacklet == Get_Pointer (Control_Point)) \ - Prev_Restore_History_Stacklet = NULL; \ -} - -#define Our_Throw_Part_2() - -#endif diff --git a/v7/src/microcode/step.c b/v7/src/microcode/step.c deleted file mode 100644 index 688207d26..000000000 --- a/v7/src/microcode/step.c +++ /dev/null @@ -1,155 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/step.c,v 9.22 1987/04/16 02:29:36 jinx Rel $ - * - * Support for the stepper - */ - -#include "scheme.h" -#include "primitive.h" - - /**********************************/ - /* Support of stepping primitives */ - /**********************************/ - -long Install_Traps(Hunk3, Return_Hook_Too) -/* UGLY ... this knows (a) that it is called with the primitive frame - already popped off the stack; and (b) the order in which Save_Cont - stores things on the stack. -*/ -Pointer Hunk3; -Boolean Return_Hook_Too; -{ Pointer Eval_Hook, Apply_Hook, Return_Hook; - Stop_Trapping(); - Eval_Hook = Vector_Ref(Hunk3, HUNK_CXR0); - Apply_Hook = Vector_Ref(Hunk3, HUNK_CXR1); - Return_Hook = Vector_Ref(Hunk3, HUNK_CXR2); - Set_Fixed_Obj_Slot(Stepper_State, Hunk3); - Trapping = (Eval_Hook != NIL) | (Apply_Hook != NIL); - if (Microcode_Does_Stepping && Return_Hook_Too && (Return_Hook != NIL)) - { /* Here it is ... gross and ugly. We know that the top of stack - has the existing return code to be clobbered, since it was put - there by Save_Cont. - */ - Return_Hook_Address = &Top_Of_Stack(); - Old_Return_Code = Top_Of_Stack(); - *Return_Hook_Address = Make_Non_Pointer(TC_RETURN_CODE, - RC_RETURN_TRAP_POINT); - } -} - -/* (PRIMITIVE-EVAL-STEP EXPRESSION ENV HUNK3) - Evaluates EXPRESSION in ENV and intalls the eval-trap, - apply-trap, and return-trap from HUNK3. If any - trap is '(), it is a null trap that does a normal EVAL, - APPLY or return. -*/ - -Built_In_Primitive(Prim_Eval_Step, 3, "PRIMITIVE-EVAL-STEP", 0xCA) -{ - Primitive_3_Args(); - - Install_Traps(Arg3, false); - Pop_Primitive_Frame(3); - Store_Expression(Arg1); - Store_Env(Arg2); - longjmp(*Back_To_Eval, PRIM_NO_TRAP_EVAL); - /*NOTREACHED*/ -} - -/* (PRIMITIVE-APPLY-STEP OPERATOR OPERANDS HUNK3) - Applies OPERATOR to OPERANDS and intalls the eval-trap, - apply-trap, and return-trap from HUNK3. If any - trap is '(), it is a null trap that does a normal EVAL, - APPLY or return. - - Mostly a copy of Prim_Apply, since this, too, must count the space - required before actually building a frame -*/ - -Built_In_Primitive(Prim_Apply_Step, 3, "PRIMITIVE-APPLY-STEP", 0xCB) -{ - Pointer Next_From_Slot, *Next_To_Slot; - long Number_Of_Args, i; - Primitive_3_Args(); - - Arg_3_Type(TC_HUNK3); - Number_Of_Args = 0; - Next_From_Slot = Arg2; - while (Type_Code(Next_From_Slot) == TC_LIST) - { - Number_Of_Args += 1; - Next_From_Slot = Vector_Ref(Next_From_Slot, CONS_CDR); - } - if (Next_From_Slot != NIL) - Primitive_Error(ERR_ARG_2_WRONG_TYPE); - Install_Traps(Arg3, true); - Pop_Primitive_Frame(3); - Next_From_Slot = Arg2; - Next_To_Slot = Stack_Pointer - Number_Of_Args; - Will_Push(Number_Of_Args + STACK_ENV_EXTRA_SLOTS + 1); - Stack_Pointer = Next_To_Slot; - - for (i = 0; i < Number_Of_Args; i++) - { - *Next_To_Slot++ = Vector_Ref(Next_From_Slot, CONS_CAR); - Next_From_Slot = Vector_Ref(Next_From_Slot, CONS_CDR); - } - Push(Arg1); /* The function */ - Push(STACK_FRAME_HEADER + Number_Of_Args); - Pushed(); - longjmp(*Back_To_Eval, PRIM_NO_TRAP_APPLY); - /*NOTREACHED*/ -} - -/* (PRIMITIVE-RETURN-STEP VALUE HUNK3) - Returns VALUE and intalls the eval-trap, apply-trap, and - return-trap from HUNK3. If any trap is '(), it is a null trap - that does a normal EVAL, APPLY or return. - - UGLY ... currently assumes that it is illegal to set a return trap - this way, so that we don't run into stack parsing problems. If - this is ever changed, be sure to check for COMPILE_STEPPER flag! -*/ - -Built_In_Primitive(Prim_Return_Step, 2, "PRIMITIVE-RETURN-STEP", 0xCC) -{ - Pointer Return_Hook; - Primitive_2_Args(); - - Return_Hook = Vector_Ref(Arg2, HUNK_CXR2); - if (Return_Hook != NIL) - Primitive_Error(ERR_ARG_2_BAD_RANGE); - Install_Traps(Arg2, false); - return Arg1; -} diff --git a/v7/src/microcode/storage.c b/v7/src/microcode/storage.c deleted file mode 100644 index 3b82f58fd..000000000 --- a/v7/src/microcode/storage.c +++ /dev/null @@ -1,241 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/storage.c,v 9.28 1987/04/16 02:29:45 jinx Exp $ - -This file defines the storage for global variables for -the Scheme Interpreter. */ - -#include "scheme.h" -#include "gctype.c" - - /*************/ - /* REGISTERS */ - /*************/ - -Pointer - *Ext_History, /* History register */ - *Free, /* Next free word in storage */ - *MemTop, /* Top of free space available */ - *Ext_Stack_Pointer, /* Next available slot in control stack */ - *Stack_Top, /* Top of control stack */ - *Stack_Guard, /* Guard area at end of stack */ - *Free_Stacklets, /* Free list of stacklets */ - *Constant_Space, /* Bottom of constant+pure space */ - *Free_Constant, /* Next free cell in constant+pure area */ - *Heap_Top, /* Top of current heap */ - *Heap_Bottom, /* Bottom of current heap */ - *Unused_Heap_Top, /* Top of other heap */ - *Unused_Heap, /* Bottom of other heap */ - *Local_Heap_Base, /* Per-processor CONSing area */ - *Heap, /* Bottom of entire heap */ - Current_State_Point = NIL, /* Used by dynamic winder */ - Fluid_Bindings = NIL, /* Fluid bindings AList */ - return_to_interpreter, /* Return address/code left by interpreter - when calling compiled code */ - *last_return_code, /* Address of the most recent return code in the stack. - This is only meaningful while in compiled code. - *** This must be changed when stacklets are used. *** - */ - Swap_Temp; /* Used by Swap_Pointers in default.h */ - -long IntCode, /* Interrupts requesting */ - IntEnb, /* Interrupts enabled */ - Lookup_Offset, /* Slot lookup result return */ - GC_Reserve = 4500, /* Scheme pointer overflow space in heap */ - GC_Space_Needed, /* Amount of space needed when GC triggered */ - /* Used to signal microcode errors from compiled code. */ - compiled_code_error_code; - -Declare_Fixed_Objects(); - -FILE *(Channels[FILE_CHANNELS]), *File_Handle, *Photo_File_Handle; - -int Saved_argc; -char **Saved_argv; -char *OS_Name, *OS_Variant; - -Boolean Photo_Open = false; /* Photo file open */ - -Boolean Trapping; - -Pointer Old_Return_Code, *Return_Hook_Address; - -Pointer *Prev_Restore_History_Stacklet; -long Prev_Restore_History_Offset; - -jmp_buf *Back_To_Eval; /* Buffer for set/longjmp */ - -long Heap_Size, Constant_Size, Stack_Size; -Pointer *Highest_Allocated_Address; - -#ifndef Heap_In_Low_Memory -Pointer *Memory_Base; -#endif - - /**********************/ - /* DEBUGGING SWITCHES */ - /**********************/ - -#ifdef ENABLE_DEBUGGING_TOOLS -Boolean Eval_Debug = false; -Boolean Hex_Input_Debug = false; -Boolean File_Load_Debug = false; -Boolean Reloc_Debug = false; -Boolean Intern_Debug = false; -Boolean Cont_Debug = false; -Boolean Primitive_Debug = false; -Boolean Lookup_Debug = false; -Boolean Define_Debug = false; -Boolean GC_Debug = false; -Boolean Upgrade_Debug = false; -Boolean Dump_Debug = false; -Boolean Trace_On_Error = false; -Boolean Bignum_Debug = false; -Boolean Per_File = true; -Boolean Fluids_Debug = false; -More_Debug_Flag_Allocs(); - -int debug_slotno = 0; -int debug_nslots = 0; -int local_slotno = 0; -int local_nslots = 0; -/* MHWU -int debug_circle[debug_maxslots]; -int local_circle[debug_maxslots]; -*/ -int debug_circle[100]; -int local_circle[100]; -#endif - - /****************************/ - /* Debugging Macro Messages */ - /****************************/ - -char *CONT_PRINT_RETURN_MESSAGE = "Save_Cont, return code"; -char *CONT_PRINT_EXPR_MESSAGE = "Save_Cont, expression"; -char *RESTORE_CONT_RETURN_MESSAGE = "Restore_Cont, return code"; -char *RESTORE_CONT_EXPR_MESSAGE = "Restore_Cont, expression"; - -static char No_Name[] = ""; - -char *Return_Names[] = { -/* 0x00 */ "END_OF_COMPUTATION", -/* 0x01 */ "JOIN_STACKLETS", -/* 0x02 */ "RESTORE_CONTINUATION", -/* 0x03 */ "INTERNAL_APPLY", -/* 0x04 */ "BAD_INTERRUPT_CONTINUE", -/* 0x05 */ "RESTORE_HISTORY", -/* 0x06 */ "INVOKE_STACK_THREAD", -/* 0x07 */ "RESTART_EXECUTION", -/* 0x08 */ "EXECUTE_ASSIGNMENT_FINISH", -/* 0x09 */ "EXECUTE_DEFINITION_FINISH", -/* 0x0A */ "EXECUTE_ACCESS_FINISH", -/* 0x0b */ "EXECUTE_IN_PACKAGE_CONTINUE", -/* 0x0C */ "SEQ_2_DO_2", -/* 0x0d */ "SEQ_3_DO_2", -/* 0x0E */ "SEQ_3_DO_3", -/* 0x0f */ "CONDITIONAL_DECIDE", -/* 0x10 */ "DISJUNCTION_DECIDE", -/* 0x11 */ "COMB_1_PROCEDURE", -/* 0x12 */ "COMB_APPLY_FUNCTION", -/* 0x13 */ "COMB_2_FIRST_OPERAND", -/* 0x14 */ "COMB_2_PROCEDURE", -/* 0x15 */ "COMB_SAVE_VALUE", -/* 0x16 */ "PCOMB1_APPLY", -/* 0x17 */ "PCOMB2_DO_1", -/* 0x18 */ "PCOMB2_APPLY", -/* 0x19 */ "PCOMB3_DO_2", -/* 0x1A */ "PCOMB3_DO_1", -/* 0x1B */ "PCOMB3_APPLY", -/* 0x1C */ "SNAP_NEED_THUNK", -/* 0x1D */ No_Name, -/* 0x1E */ No_Name, -/* 0x1F */ No_Name, -/* 0x20 */ "NORMAL_GC_DONE", -/* 0x21 */ "COMPLETE_GC_DONE", -/* 0x22 */ "PURIFY_GC_1", -/* 0x23 */ "PURIFY_GC_2", -/* 0x24 */ "AFTER_MEMORY_UPDATE", -/* 0x25 */ "RESTARTABLE_EXIT", -/* 0x26 */ No_Name, -/* 0x27 */ No_Name, - -/* 0x28 */ No_Name, -/* 0x29 */ No_Name, -/* 0x2A */ "RETURN_TRAP_POINT", -/* 0x2B */ "RESTORE_STEPPER", -/* 0x2C */ "RESTORE_TO_STATE_POINT", -/* 0x2D */ "MOVE_TO_ADJACENT_POINT", -/* 0x2E */ "RESTORE_VALUE", -/* 0x2F */ "RESTORE_DONT_COPY_HISTORY", -/* 0x30 */ No_Name, -/* 0x31 */ No_Name, -/* 0x32 */ No_Name, -/* 0x33 */ No_Name, -/* 0x34 */ No_Name, -/* 0x35 */ No_Name, -/* 0x36 */ No_Name, -/* 0x37 */ No_Name, -/* 0x38 */ No_Name, -/* 0x39 */ No_Name, -/* 0x3A */ No_Name, -/* 0x3B */ No_Name, -/* 0x3C */ No_Name, -/* 0x3D */ No_Name, -/* 0x3E */ No_Name, -/* 0x3F */ No_Name, -/* 0x40 */ "POP_RETURN_ERROR", -/* 0x41 */ "EVAL_ERROR", -/* 0x42 */ "REPEAT_PRIMITIVE", -/* 0x43 */ "COMPILER_INTERRUPT_RESTART", -/* 0x44 */ No_Name, -/* 0x45 */ "RESTORE_INT_MASK", -/* 0x46 */ "HALT", -/* 0x47 */ "FINISH_GLOBAL_INT", -/* 0x48 */ "REPEAT_DISPATCH", -/* 0x49 */ "GC_CHECK", -/* 0x4A */ "RESTORE_FLUIDS", -/* 0x4B */ "COMPILER_LOOKUP_APPLY_RESTART", -/* 0x4C */ "COMPILER_ACCESS_RESTART", -/* 0x4D */ "COMPILER_UNASSIGNED_P_RESTART", -/* 0x4E */ "COMPILER_UNBOUND_P_RESTART", -/* 0x4F */ "COMPILER_DEFINITION_RESTART", -/* 0x50 */ "COMPILER_LEXPR_GC_RESTART" -}; - -#if (MAX_RETURN_CODE != 0x50) -/* Cause an error */ -#include "Returns.h and storage.c are inconsistent -- Names Table" -#endif - -long MAX_RETURN = MAX_RETURN_CODE; diff --git a/v7/src/microcode/string.c b/v7/src/microcode/string.c deleted file mode 100644 index 594c10496..000000000 --- a/v7/src/microcode/string.c +++ /dev/null @@ -1,495 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/string.c,v 9.23 1987/04/16 02:30:34 jinx Exp $ */ - -/* String primitives. */ - -#include "scheme.h" -#include "primitive.h" -#include "character.h" -#include "stringprim.h" - -/* Currently the strings used in symbols have type codes in the length - field. They should be changed to have just longwords there. */ - -Built_In_Primitive (Prim_String_Allocate, 1, "STRING-ALLOCATE", 0x13E) -{ - long length, count; - Pointer result; - Primitive_1_Arg (); - - length = (guarantee_nonnegative_int_arg_1 (Arg1)); - /* Add 1 to length to account for '\0' at end of string. - Add 2 to count to account for string header words. */ - count = - ((((length + 1) + ((sizeof (Pointer)) - 1)) - / (sizeof (Pointer))) - + 2); - Primitive_GC_If_Needed (count); - result = Make_Pointer (TC_CHARACTER_STRING, Free); - Free[STRING_HEADER] = - (Make_Non_Pointer (TC_MANIFEST_NM_VECTOR, (count - 1))); - Free[STRING_LENGTH] = ((long) length); - *(string_pointer (result, length)) = '\0'; - Free += count; - return (result); -} - -Built_In_Primitive (Prim_String_P, 1, "STRING?", 0x138) -{ - Primitive_1_Arg (); - - return ((string_p (Arg1)) ? TRUTH : NIL); -} - -Built_In_Primitive (Prim_String_Length, 1, "STRING-LENGTH", 0x139) -{ - Primitive_1_Arg (); - - guarantee_string_arg_1 (); - return (Make_Unsigned_Fixnum (string_length (Arg1))); -} - -Built_In_Primitive (Prim_String_Maximum_Length, 1, - "STRING-MAXIMUM-LENGTH", 0x13F) -{ - Primitive_1_Arg (); - - guarantee_string_arg_1 (); - return (Make_Unsigned_Fixnum ((maximum_string_length (Arg1)) - 1)); -} - -Built_In_Primitive (Prim_Set_String_Length, 2, "SET-STRING-LENGTH!", 0x140) -{ - long length, result; - Primitive_2_Args (); - - guarantee_string_arg_1 (); - length = (guarantee_nonnegative_int_arg_2 (Arg2)); - if (length > (maximum_string_length (Arg1))) - error_bad_range_arg_2 (); - - result = (string_length (Arg1)); - set_string_length (Arg1, length); - return (Make_Unsigned_Fixnum (result)); -} - -long -substring_length_min (start1, end1, start2, end2) - long start1, end1, start2, end2; -{ - fast long length1, length2; - - length1 = (end1 - start1); - length2 = (end2 - start2); - return ((length1 < length2) ? length1 : length2); -} - -#define string_ref_body(process_result) \ -{ \ - long index; \ - long result; \ - Primitive_2_Args (); \ - \ - guarantee_string_arg_1 (); \ - index = (guarantee_index_arg_2 (Arg2, (string_length (Arg1)))); \ - \ - return (process_result (string_ref (Arg1, index))); \ -} - -Built_In_Primitive (Prim_String_Ref, 2, "STRING-REF", 0x13A) - string_ref_body (c_char_to_scheme_char) - -Built_In_Primitive (Prim_Vec_8b_Ref, 2, "VECTOR-8B-REF", 0xA5) - string_ref_body (Make_Unsigned_Fixnum) - -#define string_set_body(get_ascii, process_result) \ -{ \ - long index, ascii; \ - char *char_pointer; \ - Pointer result; \ - Primitive_3_Args (); \ - \ - guarantee_string_arg_1 (); \ - index = (guarantee_index_arg_2 (Arg2, (string_length (Arg1)))); \ - ascii = (get_ascii (Arg3)); \ - \ - char_pointer = (string_pointer (Arg1, index)); \ - result = (char_to_long (*char_pointer)); \ - *char_pointer = ascii; \ - return (process_result (result)); \ -} - -Built_In_Primitive (Prim_String_Set, 3, "STRING-SET!", 0x13B) - string_set_body (guarantee_ascii_char_arg_3, c_char_to_scheme_char) - -Built_In_Primitive (Prim_Vec_8b_Set, 3, "VECTOR-8B-SET!", 0xA6) - string_set_body (guarantee_ascii_integer_arg_3, Make_Unsigned_Fixnum) - -#define substring_move_prefix() \ - long start1, end1, start2, end2, length; \ - fast char *scan1, *scan2; \ - Primitive_5_Args (); \ - \ - guarantee_string_arg_1 (); \ - start1 = (guarantee_nonnegative_int_arg_2 (Arg2)); \ - end1 = (guarantee_nonnegative_int_arg_3 (Arg3)); \ - guarantee_string_arg_4 (); \ - start2 = (guarantee_nonnegative_int_arg_5 (Arg5)); \ - \ - if (end1 > (string_length (Arg1))) \ - error_bad_range_arg_2 (); \ - if (start1 > end1) \ - error_bad_range_arg_1 (); \ - length = (end1 - start1); \ - \ - end2 = (start2 + length); \ - if (end2 > (string_length (Arg4))) \ - error_bad_range_arg_3 (); - -Built_In_Primitive (Prim_Substring_Move_Right, 5, - "SUBSTRING-MOVE-RIGHT!", 0x13C) -{ - substring_move_prefix() - - scan1 = (string_pointer (Arg1, end1)); - scan2 = (string_pointer (Arg4, end2)); - while (length-- > 0) - *--scan2 = *--scan1; - return (NIL); -} - -Built_In_Primitive (Prim_Substring_Move_Left, 5, - "SUBSTRING-MOVE-LEFT!", 0x13D) -{ - substring_move_prefix() - - scan1 = (string_pointer (Arg1, start1)); - scan2 = (string_pointer (Arg4, start2)); - while (length-- > 0) - *scan2++ = *scan1++; - return (NIL); -} - -#define vector_8b_substring_prefix() \ - long start, end, ascii; \ - long length; \ - char *scan; \ - Primitive_4_Args (); \ - \ - guarantee_string_arg_1 (); \ - start = (guarantee_nonnegative_int_arg_2 (Arg2)); \ - end = (guarantee_nonnegative_int_arg_3 (Arg3)); \ - ascii = (guarantee_ascii_integer_arg_4 (Arg4)); \ - \ - if (end > (string_length (Arg1))) \ - error_bad_range_arg_3 (); \ - if (start > end) \ - error_bad_range_arg_2 (); - -Built_In_Primitive (Prim_Vec_8b_Fill, 4, "VECTOR-8B-FILL!", 0x141) -{ - vector_8b_substring_prefix (); - - length = (end - start); - scan = (string_pointer (Arg1, start)); - while (length-- > 0) - *scan++ = ascii; - return (NIL); -} - -Built_In_Primitive (Prim_Vec_8b_Find_Next_Char, 4, - "VECTOR-8B-FIND-NEXT-CHAR", 0x142) -{ - vector_8b_substring_prefix (); - - scan = (string_pointer (Arg1, start)); - while (start < end) - { - if ((char_to_long (*scan++)) == ascii) - return (Make_Unsigned_Fixnum (start)); - start += 1; - } - return (NIL); -} - -Built_In_Primitive (Prim_Vec_8b_Find_Prev_Char, 4, - "VECTOR-8B-FIND-PREVIOUS-CHAR", 0x143) -{ - vector_8b_substring_prefix (); - - scan = (string_pointer (Arg1, end)); - while (end-- > start) - if ((char_to_long (*--scan)) == ascii) - return (Make_Unsigned_Fixnum (end)); - return (NIL); -} - -Built_In_Primitive(Prim_Vec_8b_Find_Next_Char_Ci, 4, - "VECTOR-8B-FIND-NEXT-CHAR-CI", 0x144) -{ - char char1; - vector_8b_substring_prefix (); - - scan = (string_pointer (Arg1, start)); - char1 = (char_upcase (ascii)); - while (start < end) - { - if ((char_upcase (*scan++)) == char1) - return (Make_Unsigned_Fixnum( start)); - start += 1; - } - return (NIL); -} - -Built_In_Primitive(Prim_Vec_8b_Find_Prev_Char_Ci, 4, - "VECTOR-8B-FIND-PREVIOUS-CHAR-CI", 0x145) -{ - char char1; - vector_8b_substring_prefix (); - - scan = (string_pointer (Arg1, end)); - char1 = (char_upcase (ascii)); - while (end-- > start) - { - if ((char_upcase (*--scan)) == char1) - return (Make_Unsigned_Fixnum (end)); - } - return (NIL); -} - -#define substring_find_char_in_set_prefix() \ - long start, end, length; \ - char *char_set, *scan; \ - Primitive_4_Args (); \ - \ - guarantee_string_arg_1 (); \ - start = (guarantee_nonnegative_int_arg_2 (Arg2)); \ - end = (guarantee_nonnegative_int_arg_3 (Arg3)); \ - guarantee_string_arg_4 (); \ - \ - if (end > (string_length (Arg1))) \ - error_bad_range_arg_3 (); \ - if (start > end) \ - error_bad_range_arg_2 (); \ - if ((string_length (Arg4)) != MAX_ASCII) \ - error_bad_range_arg_4 (); - -Built_In_Primitive(Prim_Find_Next_Char_In_Set, 4, - "SUBSTRING-FIND-NEXT-CHAR-IN-SET", 0x146) -{ - substring_find_char_in_set_prefix (); - - char_set = (Scheme_String_To_C_String (Arg4)); - scan = (string_pointer (Arg1, start)); - while (start < end) - { - if (char_set[(char_to_long (*scan++))] != '\0') - return (Make_Unsigned_Fixnum (start)); - start += 1; - } - return (NIL); -} - -Built_In_Primitive(Prim_Find_Prev_Char_In_Set, 4, - "SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET", 0x147) -{ - substring_find_char_in_set_prefix (); - - char_set = Scheme_String_To_C_String(Arg4); - scan = (string_pointer (Arg1, end)); - while (end-- > start) - if (char_set[(char_to_long (*--scan))] != '\0') - return (Make_Unsigned_Fixnum (end)); - return (NIL); -} - -#define substring_compare_prefix(index1, index2) \ - long start1, end1, start2, end2; \ - char *scan1, *scan2; \ - Primitive_6_Args (); \ - \ - guarantee_string_arg_1 (); \ - start1 = (guarantee_nonnegative_int_arg_2 (Arg2)); \ - end1 = (guarantee_nonnegative_int_arg_3 (Arg3)); \ - guarantee_string_arg_4 (); \ - start2 = (guarantee_nonnegative_int_arg_5 (Arg5)); \ - end2 = (guarantee_nonnegative_int_arg_6 (Arg6)); \ - \ - if (end1 > (string_length (Arg1))) \ - error_bad_range_arg_3 (); \ - if (start1 > end1) \ - error_bad_range_arg_2 (); \ - \ - if (end2 > (string_length (Arg4))) \ - error_bad_range_arg_6 (); \ - if (start2 > end2) \ - error_bad_range_arg_5 (); \ - \ - scan1 = (string_pointer (Arg1, index1)); \ - scan2 = (string_pointer (Arg4, index2)); - -#define substring_equal_prefix() \ - long length; \ - substring_compare_prefix (start1, start2); \ - \ - length = (end1 - start1); \ - if (length != (end2 - start2)) \ - return (NIL); - -Built_In_Primitive(Prim_Substring_Equal, 6, "SUBSTRING=?", 0x148) -{ - substring_equal_prefix (); - - while (length-- > 0) - if ((*scan1++) != (*scan2++)) - return (NIL); - return (TRUTH); -} - -Built_In_Primitive(Prim_Substring_Ci_Equal, 6, "SUBSTRING-CI=?", 0x149) -{ - substring_equal_prefix (); - - while (length-- > 0) - if ((char_upcase (*scan1++)) != (char_upcase (*scan2++))) - return (NIL); - return (TRUTH); -} - -Built_In_Primitive (Prim_Substring_Less, 6, "SUBSTRING 0) - if ((*scan1++) != (*scan2++)) - return (((scan1[-1]) < (scan2[-1])) ? TRUTH : NIL); - - return ((length1 < length2) ? TRUTH : NIL); -} - -#define substring_modification_prefix() \ - long start, end; \ - fast long length; \ - fast char *scan, temp; \ - Primitive_3_Args (); \ - \ - guarantee_string_arg_1 (); \ - start = (guarantee_nonnegative_int_arg_2 (Arg2)); \ - end = (guarantee_nonnegative_int_arg_3 (Arg3)); \ - \ - if (end > (string_length (Arg1))) \ - error_bad_range_arg_3 (); \ - if (start > end) \ - error_bad_range_arg_2 (); \ - \ - length = (end - start); \ - scan = (string_pointer (Arg1, start)); - -Built_In_Primitive(Prim_Substring_Upcase, 3, "SUBSTRING-UPCASE!", 0x14B) -{ - substring_modification_prefix (); - - while (length-- > 0) - { temp = *scan; - *scan++ = (char_upcase (temp)); - } - return (NIL); -} - -Built_In_Primitive(Prim_Substring_Downcase, 3, "SUBSTRING-DOWNCASE!", 0x14C) -{ - substring_modification_prefix (); - - while (length-- > 0) - { temp = *scan; - *scan++ = (char_downcase (temp)); - } - return (NIL); -} - -#define substring_match_prefix(index1, index2) \ - long length, unmatched; \ - substring_compare_prefix (index1, index2); \ - \ - length = (substring_length_min (start1, end1, start2, end2)); \ - unmatched = length; - -Built_In_Primitive (Prim_Match_Forward, 6, - "SUBSTRING-MATCH-FORWARD", 0x14D) -{ - substring_match_prefix (start1, start2); - - while (unmatched-- > 0) - if ((*scan1++) != (*scan2++)) - return (Make_Unsigned_Fixnum (length - (unmatched + 1))); - return (Make_Unsigned_Fixnum (length)); -} - -Built_In_Primitive (Prim_Match_Forward_Ci, 6, - "SUBSTRING-MATCH-FORWARD-CI", 0x14F) -{ - substring_match_prefix (start1, start2); - - while (unmatched-- > 0) - if ((char_upcase (*scan1++)) != (char_upcase (*scan2++))) - return (Make_Unsigned_Fixnum (length - (unmatched + 1))); - return (Make_Unsigned_Fixnum (length)); -} - -Built_In_Primitive (Prim_Match_Backward, 6, - "SUBSTRING-MATCH-BACKWARD", 0x14E) -{ - substring_match_prefix (end1, end2); - - while (unmatched-- > 0) - if ((*--scan1) != (*--scan2)) - return (Make_Unsigned_Fixnum (length - (unmatched + 1))); - return (Make_Unsigned_Fixnum (length)); -} - -Built_In_Primitive(Prim_Match_Backward_Ci, 6, - "SUBSTRING-MATCH-BACKWARD-CI", 0x150) -{ - substring_match_prefix (end1, end2); - - while (unmatched-- > 0) - if ((char_upcase (*--scan1)) != (char_upcase (*--scan2))) - return (Make_Unsigned_Fixnum (length - (unmatched + 1))); - return (Make_Unsigned_Fixnum (length)); -} diff --git a/v7/src/microcode/sysprim.c b/v7/src/microcode/sysprim.c deleted file mode 100644 index f5e6a5417..000000000 --- a/v7/src/microcode/sysprim.c +++ /dev/null @@ -1,188 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sysprim.c,v 9.22 1987/04/16 12:21:36 jinx Rel $ - * - * Random system primitives. Most are implemented in terms of - * utilities in os.c - * - */ -#include "scheme.h" -#include "primitive.h" - -/* Interrupt primitives */ - -Built_In_Primitive(Prim_Chk_And_Cln_Input_Channel, 2, - "CHECK-AND-CLEAN-UP-INPUT-CHANNEL", 0x107) -{ - extern Boolean OS_Clean_Interrupt_Channel(); - Primitive_2_Args(); - - return (OS_Clean_Interrupt_Channel(Get_Integer(Arg1), - Get_Integer(Arg2)) ? - TRUTH : NIL); -} - -Built_In_Primitive(Prim_Get_Next_Interrupt_Char, 0, - "GET-NEXT-INTERRUPT-CHARACTER", 0x106) -{ - int result; - extern int OS_Get_Next_Interrupt_Character(); - Primitive_0_Args(); - - result = OS_Get_Next_Interrupt_Character(); - if (result == -1) - { - Primitive_Error(ERR_EXTERNAL_RETURN); - /*NOTREACHED*/ - } - IntCode &= ~INT_Character; - return Make_Unsigned_Fixnum(result); -} - -/* Time primitives */ - -Built_In_Primitive(Prim_System_Clock, 0, "SYSTEM-CLOCK", 0x109) -{ - Primitive_0_Args(); - - return Make_Unsigned_Fixnum(System_Clock()); -} - -Built_In_Primitive(Prim_Setup_Timer_Interrupt, 2, - "SETUP-TIMER-INTERRUPT", 0x153) -{ - extern void Clear_Int_Timer(), Set_Int_Timer(); - Primitive_2_Args(); - - if ((Arg1 == NIL) && (Arg2==NIL)) - Clear_Int_Timer(); - else - { - long Days, Centi_Seconds; - - Arg_1_Type(TC_FIXNUM); - Arg_2_Type(TC_FIXNUM); - Sign_Extend(Arg1, Days); - Sign_Extend(Arg2, Centi_Seconds); - Set_Int_Timer(Days, Centi_Seconds); - } - IntCode &= ~INT_Timer; - return NIL; -} - -/* Date and current time primitives */ - -#define Date_Primitive(OS_Name) \ -{ \ - int result; \ - extern int OS_Name(); \ - Primitive_0_Args(); \ - \ - result = OS_Name(); \ - if (result == -1) \ - return NIL; \ - return Make_Unsigned_Fixnum(result); \ -} - -Built_In_Primitive(Prim_Current_Year, 0, "CURRENT-YEAR", 0x126) -Date_Primitive(OS_Current_Year) - -Built_In_Primitive(Prim_Current_Month, 0, "CURRENT-MONTH", 0x127) -Date_Primitive(OS_Current_Month) - -Built_In_Primitive(Prim_Current_Day, 0, "CURRENT-DAY", 0x128) -Date_Primitive(OS_Current_Day) - -Built_In_Primitive(Prim_Current_Hour, 0, "CURRENT-HOUR", 0x129) -Date_Primitive(OS_Current_Hour) - -Built_In_Primitive(Prim_Current_Minute, 0, "CURRENT-MINUTE", 0x12A) -Date_Primitive(OS_Current_Minute) - -Built_In_Primitive(Prim_Current_Second, 0, "CURRENT-SECOND", 0x12B) -Date_Primitive(OS_Current_Second) - -/* Pretty random primitives */ - -/* (EXIT) - Halt SCHEME, with no intention of restarting. -*/ - -Built_In_Primitive(Prim_Non_Restartable_Exit, 0, "EXIT", 0x16) -{ - Primitive_0_Args(); - - Microcode_Termination(TERM_HALT); -} - -/* (HALT) - Halt Scheme in such a way that it can be restarted. - Not all operating systems support this. -*/ -Built_In_Primitive(Prim_Restartable_Exit, 0, "HALT", 0x1A) -{ - extern Boolean Restartable_Exit(); - Primitive_0_Args(); - - Restartable_Exit(); - return ((Restartable_Exit() ? TRUTH : NIL)); -} - -/* (SET-RUN-LIGHT! OBJECT) - On the HP Pascal workstation system, it allows the character - displayed in the lower right-hand part of the screen to be changed. - In CScheme, rings the bell. - Used by various things to indicate the state of the system. -*/ - -Built_In_Primitive(Prim_Set_Run_Light, 1, "SET-RUN-LIGHT!", 0xC0) -{ - Primitive_1_Arg(); -#ifdef RUN_LIGHT_IS_BEEP - extern void OS_tty_beep(); - - OS_tty_beep(); - OS_Flush_Output_Buffer(); - return TRUTH; -#else - return NIL; -#endif -} - -Built_In_Primitive( Prim_under_emacs_p, 0, "UNDER-EMACS?", 0x1A1) -{ - extern Boolean OS_Under_Emacs(); - Primitive_0_Args(); - - return (OS_Under_Emacs() ? TRUTH : NIL); -} diff --git a/v7/src/microcode/trap.h b/v7/src/microcode/trap.h deleted file mode 100644 index 1fe98def2..000000000 --- a/v7/src/microcode/trap.h +++ /dev/null @@ -1,97 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/trap.h,v 9.37 1987/04/16 02:30:49 jinx Exp $ */ - -/* Kinds of traps: - - Note that for every trap there is a dangerous version. - The danger bit is the bottom bit of the trap number, - thus all dangerous traps are odd and viceversa. - - For efficiency, some traps are immediate, while some are - pointer objects. The type code is multiplexed, and the - garbage collector handles it specially. - - */ - -/* The following are immediate traps: */ - -#define TRAP_UNASSIGNED 0 -#define TRAP_UNASSIGNED_DANGEROUS 1 -#define TRAP_UNBOUND 2 -#define TRAP_UNBOUND_DANGEROUS 3 -#define TRAP_ILLEGAL 4 -#define TRAP_ILLEGAL_DANGEROUS 5 /* Unused. */ - -/* TRAP_MAX_IMMEDIATE is defined in const.h */ - -/* The following are not: */ - -#define TRAP_NOP 10 /* Unused. */ -#define TRAP_DANGEROUS 11 -#define TRAP_FLUID 12 -#define TRAP_FLUID_DANGEROUS 13 - -/* Trap utilities */ - -#define get_trap_kind(variable, what) \ -{ \ - variable = Datum(what); \ - if (variable > TRAP_MAX_IMMEDIATE) \ - variable = Datum(Vector_Ref(what, TRAP_TAG)); \ -} - -/* Common constants */ - -#ifndef b32 -#define UNASSIGNED_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNASSIGNED) -#define DANGEROUS_UNASSIGNED_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNASSIGNED_DANGEROUS) -#define UNBOUND_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNBOUND) -#define DANGEROUS_UNBOUND_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNBOUND_DANGEROUS) -#define ILLEGAL_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_ILLEGAL) -#define DANGEROUS_ILLEGAL_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_ILLEGAL_DANGEROUS) -#else -#define UNASSIGNED_OBJECT 0x32000000 -#define DANGEROUS_UNASSIGNED_OBJECT 0x32000001 -#define UNBOUND_OBJECT 0x32000002 -#define DANGEROUS_UNBOUND_OBJECT 0x32000003 -#define ILLEGAL_OBJECT 0x32000004 -#define DANGEROUS_ILLEGAL_OBJECT 0x32000005 -#endif - -#define DANGEROUS_OBJECT Make_Unsigned_Fixnum(TRAP_DANGEROUS) - -#if (TC_REFERENCE_TRAP != 0x32) -#include "error: trap.h and types.h are inconsistent" -#endif - diff --git a/v7/src/microcode/types.h b/v7/src/microcode/types.h deleted file mode 100644 index d62337e32..000000000 --- a/v7/src/microcode/types.h +++ /dev/null @@ -1,111 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/types.h,v 9.22 1987/04/03 00:21:38 jinx Exp $ - * - * Type code definitions, numerical order - * - */ - -#define TC_NULL 0x00 -#define TC_LIST 0x01 -#define TC_CHARACTER 0x02 -#define TC_SCODE_QUOTE 0x03 -#define TC_PCOMB2 0x04 -#define TC_UNINTERNED_SYMBOL 0x05 -#define TC_BIG_FLONUM 0x06 -#define TC_COMBINATION_1 0x07 -#define TC_TRUE 0x08 -#define TC_EXTENDED_PROCEDURE 0x09 -#define TC_VECTOR 0x0A -#define TC_RETURN_CODE 0x0B -#define TC_COMBINATION_2 0x0C -#define TC_COMPILED_PROCEDURE 0x0D -#define TC_BIG_FIXNUM 0x0E -#define TC_PROCEDURE 0x0F -#define TC_PRIMITIVE_EXTERNAL 0x10 -#define TC_DELAY 0x11 -#define TC_ENVIRONMENT 0x12 -#define TC_DELAYED 0x13 -#define TC_EXTENDED_LAMBDA 0x14 -#define TC_COMMENT 0x15 -#define TC_NON_MARKED_VECTOR 0x16 -#define TC_LAMBDA 0x17 -#define TC_PRIMITIVE 0x18 -#define TC_SEQUENCE_2 0x19 - -#define TC_FIXNUM 0x1A -#define TC_PCOMB1 0x1B -#define TC_CONTROL_POINT 0x1C -#define TC_INTERNED_SYMBOL 0x1D -#define TC_CHARACTER_STRING 0x1E -#define TC_ACCESS 0x1F -/* UNUSED 0x20 */ /* Used to be EXTENDED_FIXNUM. */ -#define TC_DEFINITION 0x21 -#define TC_BROKEN_HEART 0x22 -#define TC_ASSIGNMENT 0x23 -#define TC_HUNK3 0x24 -#define TC_IN_PACKAGE 0x25 -#define TC_COMBINATION 0x26 -#define TC_MANIFEST_NM_VECTOR 0x27 -#define TC_COMPILED_EXPRESSION 0x28 -#define TC_LEXPR 0x29 -#define TC_PCOMB3 0x2A -#define TC_MANIFEST_SPECIAL_NM_VECTOR 0x2B -#define TC_VARIABLE 0x2C -#define TC_THE_ENVIRONMENT 0x2D -#define TC_FUTURE 0x2E -#define TC_VECTOR_1B 0x2F -#define TC_PCOMB0 0x30 -#define TC_VECTOR_16B 0x31 -#define TC_REFERENCE_TRAP 0x32 /* Used to be UNASSIGNED. */ -#define TC_SEQUENCE_3 0x33 -#define TC_CONDITIONAL 0x34 -#define TC_DISJUNCTION 0x35 -#define TC_CELL 0x36 -#define TC_WEAK_CONS 0x37 -#define TC_QUAD 0x38 /* Used to be TC_TRAP. */ -#define TC_RETURN_ADDRESS 0x39 -#define TC_COMPILER_LINK 0x3A -#define TC_STACK_ENVIRONMENT 0x3B -#define TC_COMPLEX 0x3C - -/* If you add a new type, don't forget to update gccode.h and gctype.c */ - -/* Aliases */ - -#define TC_FALSE TC_NULL -#define TC_MANIFEST_VECTOR TC_NULL -#define GLOBAL_ENV TC_NULL -#define TC_BIT_STRING TC_VECTOR_1B -#define TC_VECTOR_8B TC_CHARACTER_STRING -#define TC_ADDRESS TC_FIXNUM diff --git a/v7/src/microcode/unexec.c b/v7/src/microcode/unexec.c deleted file mode 100644 index a677017b0..000000000 --- a/v7/src/microcode/unexec.c +++ /dev/null @@ -1,1052 +0,0 @@ -/* Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. - -This file is part of GNU Emacs. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY. No author or distributor -accepts responsibility to anyone for the consequences of using it -or for whether it serves any particular purpose or works at all, -unless he says so in writing. Refer to the GNU Emacs General Public -License for full details. - -Everyone is granted permission to copy, modify and redistribute -GNU Emacs, but only under the conditions described in the -GNU Emacs General Public License. A copy of this license is -supposed to have been given to you along with GNU Emacs so you -can know your rights and responsibilities. It should be in a -file named COPYING. Among other things, the copyright notice -and this notice must be preserved on all copies. */ - - -/* - * unexec.c - Convert a running program into an a.out file. - * - * Author: Spencer W. Thomas - * Computer Science Dept. - * University of Utah - * Date: Tue Mar 2 1982 - * Modified heavily since then. - * - * Synopsis: - * unexec (new_name, a_name, data_start, bss_start, entry_address) - * char *new_name, *a_name; - * unsigned data_start, bss_start, entry_address; - * - * Takes a snapshot of the program and makes an a.out format file in the - * file named by the string argument new_name. - * If a_name is non-NULL, the symbol table will be taken from the given file. - * On some machines, an existing a_name file is required. - * - * The boundaries within the a.out file may be adjusted with the data_start - * and bss_start arguments. Either or both may be given as 0 for defaults. - * - * Data_start gives the boundary between the text segment and the data - * segment of the program. The text segment can contain shared, read-only - * program code and literal data, while the data segment is always unshared - * and unprotected. Data_start gives the lowest unprotected address. - * The value you specify may be rounded down to a suitable boundary - * as required by the machine you are using. - * - * Specifying zero for data_start means the boundary between text and data - * should not be the same as when the program was loaded. - * If NO_REMAP is defined, the argument data_start is ignored and the - * segment boundaries are never changed. - * - * Bss_start indicates how much of the data segment is to be saved in the - * a.out file and restored when the program is executed. It gives the lowest - * unsaved address, and is rounded up to a page boundary. The default when 0 - * is given assumes that the entire data segment is to be stored, including - * the previous data and bss as well as any additional storage allocated with - * break (2). - * - * The new file is set up to start at entry_address. - * - * If you make improvements I'd like to get them too. - * harpo!utah-cs!thomas, thomas@Utah-20 - * - */ - -/* There are several compilation parameters affecting unexec: - -* COFF - -Define this if your system uses COFF for executables. -Otherwise we assume you use Berkeley format. - -* NO_REMAP - -Define this if you do not want to try to save Emacs's pure data areas -as part of the text segment. - -Saving them as text is good because it allows users to share more. - -However, on machines that locate the text area far from the data area, -the boundary cannot feasibly be moved. Such machines require -NO_REMAP. - -Also, remapping can cause trouble with the built-in startup routine -/lib/crt0.o, which defines `environ' as an initialized variable. -Dumping `environ' as pure does not work! So, to use remapping, -you must write a startup routine for your machine in Emacs's crt0.c. -If NO_REMAP is defined, Emacs uses the system's crt0.o. - -* SECTION_ALIGNMENT - -Some machines that use COFF executables require that each section -start on a certain boundary *in the COFF file*. Such machines should -define SECTION_ALIGNMENT to a mask of the low-order bits that must be -zero on such a boundary. This mask is used to control padding between -segments in the COFF file. - -If SECTION_ALIGNMENT is not defined, the segments are written -consecutively with no attempt at alignment. This is right for -unmodified system V. - -* SEGMENT_MASK - -Some machines require that the beginnings and ends of segments -*in core* be on certain boundaries. For most machines, a page -boundary is sufficient. That is the default. When a larger -boundary is needed, define SEGMENT_MASK to a mask of -the bits that must be zero on such a boundary. - -* A_TEXT_OFFSET(HDR) - -Some machines count the a.out header as part of the size of the text -segment (a_text); they may actually load the header into core as the -first data in the text segment. Some have additional padding between -the header and the real text of the program that is counted in a_text. - -For these machines, define A_TEXT_OFFSET(HDR) to examine the header -structure HDR and return the number of bytes to add to `a_text' -before writing it (above and beyond the number of bytes of actual -program text). HDR's standard fields are already correct, except that -this adjustment to the `a_text' field has not yet been made; -thus, the amount of offset can depend on the data in the file. - -* A_TEXT_SEEK(HDR) - -If defined, this macro specifies the number of bytes to seek into the -a.out file before starting to write the text segment.a - -* EXEC_MAGIC - -For machines using COFF, this macro, if defined, is a value stored -into the magic number field of the output file. - -* ADJUST_EXEC_HEADER - -This macro can be used to generate statements to adjust or -initialize nonstandard fields in the file header - -* ADDR_CORRECT(ADDR) - -Macro to correct an int which is the bit pattern of a pointer to a byte -into an int which is the number of a byte. - -This macro has a default definition which is usually right. -This default definition is a no-op on most machines (where a -pointer looks like an int) but not on all machines. - -*/ - -#ifndef mips /* mips machine requires completely separate code. */ - -#ifndef emacs -#define PERROR(arg) perror (arg); return -1 -#else -#include "config.h" -#define PERROR(file) report_error (file, new) -#endif - -#ifndef CANNOT_DUMP /* all rest of file! */ - -#include -/* Define getpagesize () if the system does not. - Note that this may depend on symbols defined in a.out.h - */ -#include "getpagesize.h" - -#ifndef makedev /* Try to detect types.h already loaded */ -#include -#endif -#include -#include -#include - -extern char *start_of_text (); /* Start of text */ -extern char *start_of_data (); /* Start of initialized data */ - -#ifdef COFF -#ifndef USG -#ifndef STRIDE -#ifndef UMAX -/* I have a suspicion that these are turned off on all systems - and can be deleted. Try it in version 19. */ -#include -#include -#include -#include -#endif /* not UMAX */ -#endif /* Not STRIDE */ -#endif /* not USG */ -static long block_copy_start; /* Old executable start point */ -static struct filehdr f_hdr; /* File header */ -static struct aouthdr f_ohdr; /* Optional file header (a.out) */ -long bias; /* Bias to add for growth */ -long lnnoptr; /* Pointer to line-number info within file */ -#define SYMS_START block_copy_start - -static long text_scnptr; -static long data_scnptr; - -#else /* not COFF */ - -extern char *sbrk (); - -#define SYMS_START ((long) N_SYMOFF (ohdr)) - -#ifdef HPUX -#ifdef HP9000S200_ID -#define MY_ID HP9000S200_ID -#else -#include -#define MY_ID MYSYS -#endif /* no HP9000S200_ID */ -static MAGIC OLDMAGIC = {MY_ID, SHARE_MAGIC}; -static MAGIC NEWMAGIC = {MY_ID, DEMAND_MAGIC}; -#define N_TXTOFF(x) TEXT_OFFSET(x) -#define N_SYMOFF(x) LESYM_OFFSET(x) -static struct exec hdr, ohdr; - -#else /* not HPUX */ - -#ifdef USG -static struct bhdr hdr, ohdr; -#define a_magic fmagic -#define a_text tsize -#define a_data dsize -#define a_bss bsize -#define a_syms ssize -#define a_trsize rtsize -#define a_drsize rdsize -#define a_entry entry -#define N_BADMAG(x) \ - (((x).fmagic)!=OMAGIC && ((x).fmagic)!=NMAGIC &&\ - ((x).fmagic)!=FMAGIC && ((x).fmagic)!=IMAGIC) -#define NEWMAGIC FMAGIC -#else /* not USG */ -static struct exec hdr, ohdr; -#define NEWMAGIC ZMAGIC -#endif /* not USG */ -#endif /* not HPUX */ - -static int unexec_text_start; -static int unexec_data_start; - -#endif /* not COFF */ - -static int pagemask; - -/* Correct an int which is the bit pattern of a pointer to a byte - into an int which is the number of a byte. - This is a no-op on ordinary machines, but not on all. */ - -#ifndef ADDR_CORRECT /* Let m-*.h files override this definition */ -#define ADDR_CORRECT(x) ((char *)(x) - (char*)0) -#endif - -#ifdef emacs - -static -report_error (file, fd) - char *file; - int fd; -{ - if (fd) - close (fd); - error ("Failure operating on %s", file); -} -#endif /* emacs */ - -#define ERROR0(msg) report_error_1 (new, msg, 0, 0); return -1 -#define ERROR1(msg,x) report_error_1 (new, msg, x, 0); return -1 -#define ERROR2(msg,x,y) report_error_1 (new, msg, x, y); return -1 - -static -report_error_1 (fd, msg, a1, a2) - int fd; - char *msg; - int a1, a2; -{ - close (fd); -#ifdef emacs - error (msg, a1, a2); -#else - fprintf (stderr, msg, a1, a2); - fprintf (stderr, "\n"); -#endif -} - -/* **************************************************************** - * unexec - * - * driving logic. - */ -unexec (new_name, a_name, data_start, bss_start, entry_address) - char *new_name, *a_name; - unsigned data_start, bss_start, entry_address; -{ - int new, a_out = -1; - - if (a_name && (a_out = open (a_name, 0)) < 0) - { - PERROR (a_name); - } - if ((new = creat (new_name, 0666)) < 0) - { - PERROR (new_name); - } - - if (make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) < 0 - || copy_text_and_data (new) < 0 - || copy_sym (new, a_out, a_name, new_name) < 0 -#ifdef COFF - || adjust_lnnoptrs (new, a_out, new_name) < 0 -#endif - ) - { - close (new); - /* unlink (new_name); /* Failed, unlink new a.out */ - return -1; - } - - close (new); - if (a_out >= 0) - close (a_out); - mark_x (new_name); - return 0; -} - -/* **************************************************************** - * make_hdr - * - * Make the header in the new a.out from the header in core. - * Modify the text and data sizes. - */ -static int -make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) - int new, a_out; - unsigned data_start, bss_start, entry_address; - char *a_name; - char *new_name; -{ - int tem; -#ifdef COFF - auto struct scnhdr f_thdr; /* Text section header */ - auto struct scnhdr f_dhdr; /* Data section header */ - auto struct scnhdr f_bhdr; /* Bss section header */ - auto struct scnhdr scntemp; /* Temporary section header */ - register int scns; -#endif /* COFF */ - unsigned int bss_end; - - pagemask = getpagesize () - 1; - - /* Adjust text/data boundary. */ -#ifdef NO_REMAP - data_start = (int) start_of_data (); -#else /* not NO_REMAP */ - if (!data_start) - data_start = (int) start_of_data (); -#endif /* not NO_REMAP */ - data_start = ADDR_CORRECT (data_start); - -#ifdef SEGMENT_MASK - data_start = data_start & ~SEGMENT_MASK; /* (Down) to segment boundary. */ -#else - data_start = data_start & ~pagemask; /* (Down) to page boundary. */ -#endif - - bss_end = (ADDR_CORRECT (sbrk (0)) + pagemask) & ~pagemask; - - /* Adjust data/bss boundary. */ - if (bss_start != 0) - { - bss_start = (ADDR_CORRECT (bss_start) + pagemask) & ~pagemask; /* (Up) to page bdry. */ - if (bss_start > bss_end) - { - ERROR1 ("unexec: Specified bss_start (%u) is past end of program", - bss_start); - } - } - else - bss_start = bss_end; - - if (data_start > bss_start) /* Can't have negative data size. */ - { - ERROR2 ("unexec: data_start (%u) can't be greater than bss_start (%u)", - data_start, bss_start); - } - -#ifdef COFF - /* Salvage as much info from the existing file as possible */ - if (a_out >= 0) - { - if (read (a_out, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) - { - PERROR (a_name); - } - block_copy_start += sizeof (f_hdr); - if (f_hdr.f_opthdr > 0) - { - if (read (a_out, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) - { - PERROR (a_name); - } - block_copy_start += sizeof (f_ohdr); - } - /* Loop through section headers, copying them in */ - for (scns = f_hdr.f_nscns; scns > 0; scns--) { - if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) - { - PERROR (a_name); - } - if (scntemp.s_scnptr > 0L) - { - if (block_copy_start < scntemp.s_scnptr + scntemp.s_size) - block_copy_start = scntemp.s_scnptr + scntemp.s_size; - } - if (strcmp (scntemp.s_name, ".text") == 0) - { - f_thdr = scntemp; - } - else if (strcmp (scntemp.s_name, ".data") == 0) - { - f_dhdr = scntemp; - } - else if (strcmp (scntemp.s_name, ".bss") == 0) - { - f_bhdr = scntemp; - } - } - } - else - { - ERROR0 ("can't build a COFF file from scratch yet"); - } - - /* Now we alter the contents of all the f_*hdr variables - to correspond to what we want to dump. */ - - f_hdr.f_flags |= (F_RELFLG | F_EXEC); -#ifdef EXEC_MAGIC - f_ohdr.magic = EXEC_MAGIC; -#endif -#ifndef NO_REMAP - f_ohdr.text_start = (long) start_of_text (); - f_ohdr.tsize = data_start - f_ohdr.text_start; - f_ohdr.data_start = data_start; -#endif /* NO_REMAP */ - f_ohdr.dsize = bss_start - f_ohdr.data_start; - f_ohdr.bsize = bss_end - bss_start; - f_thdr.s_size = f_ohdr.tsize; - f_thdr.s_scnptr = sizeof (f_hdr) + sizeof (f_ohdr); - f_thdr.s_scnptr += (f_hdr.f_nscns) * (sizeof (f_thdr)); - lnnoptr = f_thdr.s_lnnoptr; -#ifdef SECTION_ALIGNMENT - /* Some systems require special alignment - of the sections in the file itself. */ - f_thdr.s_scnptr - = (f_thdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT; -#endif /* SECTION_ALIGNMENT */ - text_scnptr = f_thdr.s_scnptr; - f_dhdr.s_paddr = f_ohdr.data_start; - f_dhdr.s_vaddr = f_ohdr.data_start; - f_dhdr.s_size = f_ohdr.dsize; - f_dhdr.s_scnptr = f_thdr.s_scnptr + f_thdr.s_size; -#ifdef SECTION_ALIGNMENT - /* Some systems require special alignment - of the sections in the file itself. */ - f_dhdr.s_scnptr - = (f_dhdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT; -#endif /* SECTION_ALIGNMENT */ - data_scnptr = f_dhdr.s_scnptr; - f_bhdr.s_paddr = f_ohdr.data_start + f_ohdr.dsize; - f_bhdr.s_vaddr = f_ohdr.data_start + f_ohdr.dsize; - f_bhdr.s_size = f_ohdr.bsize; - f_bhdr.s_scnptr = 0L; - bias = f_dhdr.s_scnptr + f_dhdr.s_size - block_copy_start; - - if (f_hdr.f_symptr > 0L) - { - f_hdr.f_symptr += bias; - } - - if (f_thdr.s_lnnoptr > 0L) - { - f_thdr.s_lnnoptr += bias; - } - -#ifdef ADJUST_EXEC_HEADER - ADJUST_EXEC_HEADER -#endif /* ADJUST_EXEC_HEADER */ - - if (write (new, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) - { - PERROR (new_name); - } - - if (write (new, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) - { - PERROR (new_name); - } - - if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr)) - { - PERROR (new_name); - } - - if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr)) - { - PERROR (new_name); - } - - if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr)) - { - PERROR (new_name); - } - return (0); - -#else /* if not COFF */ - - /* Get symbol table info from header of a.out file if given one. */ - if (a_out >= 0) - { - if (read (a_out, &ohdr, sizeof hdr) != sizeof hdr) - { - PERROR (a_name); - } - - if N_BADMAG (ohdr) - { - ERROR1 ("invalid magic number in %s", a_name); - } - hdr = ohdr; - } - else - { - bzero (hdr, sizeof hdr); - } - - unexec_text_start = (long) start_of_text (); - unexec_data_start = data_start; - - /* Machine-dependent fixup for header, or maybe for unexec_text_start */ -#ifdef ADJUST_EXEC_HEADER - ADJUST_EXEC_HEADER; -#endif /* ADJUST_EXEC_HEADER */ - - hdr.a_trsize = 0; - hdr.a_drsize = 0; - if (entry_address != 0) - hdr.a_entry = entry_address; - - hdr.a_bss = bss_end - bss_start; - hdr.a_data = bss_start - data_start; -#ifdef NO_REMAP - hdr.a_text = ohdr.a_text; -#else /* not NO_REMAP */ - hdr.a_text = data_start - unexec_text_start; -#endif /* not NO_REMAP */ - -#ifdef A_TEXT_OFFSET - hdr.a_text += A_TEXT_OFFSET (ohdr); -#endif - - if (write (new, &hdr, sizeof hdr) != sizeof hdr) - { - PERROR (new_name); - } - -#ifdef A_TEXT_OFFSET - hdr.a_text -= A_TEXT_OFFSET (ohdr); -#endif - - return 0; - -#endif /* not COFF */ -} - -/* **************************************************************** - * copy_text_and_data - * - * Copy the text and data segments from memory to the new a.out - */ -static int -copy_text_and_data (new) - int new; -{ - register char *end; - register char *ptr; - -#ifdef COFF - lseek (new, (long) text_scnptr, 0); - ptr = (char *) f_ohdr.text_start; - end = ptr + f_ohdr.tsize; - write_segment (new, ptr, end); - - lseek (new, (long) data_scnptr, 0); - ptr = (char *) f_ohdr.data_start; - end = ptr + f_ohdr.dsize; - write_segment (new, ptr, end); - -#else /* if not COFF */ - -/* Some machines count the header as part of the text segment. - That is to say, the header appears in core - just before the address that start_of_text () returns. - For them, N_TXTOFF is the place where the header goes. - We must adjust the seek to the place after the header. - Note that at this point hdr.a_text does *not* count - the extra A_TEXT_OFFSET bytes, only the actual bytes of code. */ - -#ifdef A_TEXT_SEEK - lseek (new, (long) A_TEXT_SEEK (hdr), 0); -#else -#ifdef A_TEXT_OFFSET - /* Note that on the Sequent machine A_TEXT_OFFSET != sizeof (hdr) - and sizeof (hdr) is the correct amount to add here. */ - /* In version 19, eliminate this case and use A_TEXT_SEEK whenever - N_TXTOFF is not right. */ - lseek (new, (long) N_TXTOFF (hdr) + sizeof (hdr), 0); -#else - lseek (new, (long) N_TXTOFF (hdr), 0); -#endif /* no A_TEXT_OFFSET */ -#endif /* no A_TEXT_SEEK */ - - ptr = (char *) unexec_text_start; - end = ptr + hdr.a_text; - write_segment (new, ptr, end); - - ptr = (char *) unexec_data_start; - end = ptr + hdr.a_data; -/* This lseek is certainly incorrect when A_TEXT_OFFSET - and I believe it is a no-op otherwise. - Let's see if its absence ever fails. */ -/* lseek (new, (long) N_TXTOFF (hdr) + hdr.a_text, 0); */ - write_segment (new, ptr, end); - -#endif /* not COFF */ - - return 0; -} - -write_segment (new, ptr, end) - int new; - register char *ptr, *end; -{ - register int i, nwrite, ret; - char buf[80]; - extern int errno; - char zeros[128]; - - bzero (zeros, sizeof zeros); - - for (i = 0; ptr < end;) - { - /* distance to next multiple of 128. */ - nwrite = (((int) ptr + 128) & -128) - (int) ptr; - /* But not beyond specified end. */ - if (nwrite > end - ptr) nwrite = end - ptr; - ret = write (new, ptr, nwrite); - /* If write gets a page fault, it means we reached - a gap between the old text segment and the old data segment. - This gap has probably been remapped into part of the text segment. - So write zeros for it. */ - if (ret == -1 && errno == EFAULT) - write (new, zeros, nwrite); - else if (nwrite != ret) - { - sprintf (buf, - "unexec write failure: addr 0x%x, fileno %d, size 0x%x, wrote 0x%x, errno %d", - ptr, new, nwrite, ret, errno); - PERROR (buf); - } - i += nwrite; - ptr += nwrite; - } -} - -/* **************************************************************** - * copy_sym - * - * Copy the relocation information and symbol table from the a.out to the new - */ -static int -copy_sym (new, a_out, a_name, new_name) - int new, a_out; - char *a_name, *new_name; -{ - char page[1024]; - int n; - - if (a_out < 0) - return 0; - -#ifdef COFF - if (SYMS_START == 0L) - return 0; -#endif /* COFF */ - -#ifdef COFF - if (lnnoptr) /* if there is line number info */ - lseek (a_out, lnnoptr, 0); /* start copying from there */ - else -#endif /* COFF */ - lseek (a_out, SYMS_START, 0); /* Position a.out to symtab. */ - - while ((n = read (a_out, page, sizeof page)) > 0) - { - if (write (new, page, n) != n) - { - PERROR (new_name); - } - } - if (n < 0) - { - PERROR (a_name); - } - return 0; -} - -/* **************************************************************** - * mark_x - * - * After succesfully building the new a.out, mark it executable - */ -static -mark_x (name) - char *name; -{ - struct stat sbuf; - int um; - int new = 0; /* for PERROR */ - - um = umask (777); - umask (um); - if (stat (name, &sbuf) == -1) - { - PERROR (name); - } - sbuf.st_mode |= 0111 & ~um; - if (chmod (name, sbuf.st_mode) == -1) - PERROR (name); -} - -/* - * If the COFF file contains a symbol table and a line number section, - * then any auxiliary entries that have values for x_lnnoptr must - * be adjusted by the amount that the line number section has moved - * in the file (bias computed in make_hdr). The #@$%&* designers of - * the auxiliary entry structures used the absolute file offsets for - * the line number entry rather than an offset from the start of the - * line number section! - * - * When I figure out how to scan through the symbol table and pick out - * the auxiliary entries that need adjustment, this routine will - * be fixed. As it is now, all such entries are wrong and sdb - * will complain. Fred Fish, UniSoft Systems Inc. - */ - -#ifdef COFF - -/* This function is probably very slow. Instead of reopening the new - file for input and output it should copy from the old to the new - using the two descriptors already open (WRITEDESC and READDESC). - Instead of reading one small structure at a time it should use - a reasonable size buffer. But I don't have time to work on such - things, so I am installing it as submitted to me. -- RMS. */ - -adjust_lnnoptrs (writedesc, readdesc, new_name) - int writedesc; - int readdesc; - char *new_name; -{ - register int nsyms; - register int new; -#ifdef amdahl_uts - SYMENT symentry; - AUXENT auxentry; -#else - struct syment symentry; - struct auxent auxentry; -#endif - - if (!lnnoptr || !f_hdr.f_symptr) - return 0; - - if ((new = open (new_name, 2)) < 0) - { - PERROR (new_name); - return -1; - } - - lseek (new, f_hdr.f_symptr, 0); - for (nsyms = 0; nsyms < f_hdr.f_nsyms; nsyms++) - { - read (new, &symentry, SYMESZ); - if (symentry.n_numaux) - { - read (new, &auxentry, AUXESZ); - nsyms++; - if (ISFCN (symentry.n_type)) { - auxentry.x_sym.x_fcnary.x_fcn.x_lnnoptr += bias; - lseek (new, -AUXESZ, 1); - write (new, &auxentry, AUXESZ); - } - } - } - close (new); -} - -#endif /* COFF */ - -#endif /* not CANNOT_DUMP */ - -#else /* mips */ - -/* Unexec for mips machines. - Note that I regard it as the responsibility of people at Mips - to tell me about any changes that need to be made in this code. - I won't take responsibility to think about it even if a change - I make elsewhere causes it to break. -- RMS. */ - -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include "m-mips.h" - -#define private static - -extern int errno; -extern int sys_nerr; -extern char *sys_errlist[]; -#define EEOF -1 - -private void -fatal(s, va_alist) - va_dcl -{ - va_list ap; - if (errno == EEOF) { - fputs("unexec: unexpected end of file, ", stderr); - } - else if (errno < sys_nerr) { - fprintf(stderr, "unexec: %s, ", sys_errlist[errno]); - } - else { - fprintf(stderr, "unexec: error code %d, ", errno); - } - va_start(ap); - _doprnt(s, ap, stderr); - fputs(".\n", stderr); - exit(1); -} - -#define READ(_fd, _buffer, _size, _error_message, _error_arg) \ - errno = EEOF; \ - if (read(_fd, _buffer, _size) != _size) \ - fatal(_error_message, _error_arg); - -#define WRITE(_fd, _buffer, _size, _error_message, _error_arg) \ - if (write(_fd, _buffer, _size) != _size) \ - fatal(_error_message, _error_arg); - -#define SEEK(_fd, _position, _error_message, _error_arg) \ - errno = EEOF; \ - if (lseek(_fd, _position, L_SET) != _position) \ - fatal(_error_message, _error_arg); - -struct headers { - struct filehdr fhdr; - struct aouthdr aout; - struct scnhdr text_section; - struct scnhdr rdata_section; - struct scnhdr data_section; - struct scnhdr sdata_section; - struct scnhdr sbss_section; - struct scnhdr bss_section; -}; - -unexec (new_name, a_name, data_start, bss_start, entry_address) - char *new_name, *a_name; - unsigned data_start, bss_start, entry_address; -{ - int new, old; - int pagesize, brk; - int newsyms, symrel; - int nread; - struct headers hdr; -#define BUFSIZE 8192 - char buffer[BUFSIZE]; - - old = open (a_name, O_RDONLY, 0); - if (old < 0) fatal("openning %s", a_name); - - new = creat (new_name, 0666); - if (new < 0) fatal("creating %s", new_name); - - hdr = *((struct headers *)TEXT_START); - if (hdr.fhdr.f_magic != MIPSELMAGIC - && hdr.fhdr.f_magic != MIPSEBMAGIC) { - fprintf(stderr, "unexec: input file magic number is %x, not %x or %x.\n", - hdr.fhdr.f_magic, MIPSELMAGIC, MIPSEBMAGIC); - exit(1); - } - if (hdr.fhdr.f_opthdr != sizeof(hdr.aout)) { - fprintf(stderr, "unexec: input a.out header is %d bytes, not %d.\n", - hdr.fhdr.f_opthdr, sizeof(hdr.aout)); - exit(1); - } -#if 0 - if (hdr.aout.magic != ZMAGIC - && hdr.aout.magic != NMAGIC - && hdr.aout.magic != OMAGIC) { - fprintf(stderr, "unexec: input file a.out magic number is %o, not %o, %o, or %o.\n", - hdr.aout.magic, ZMAGIC, NMAGIC, OMAGIC); - exit(1); - } -#else - if (hdr.aout.magic != ZMAGIC) { - fprintf(stderr, "unexec: input file a.out magic number is %o, not %o.\n", - hdr.aout.magic, ZMAGIC); - exit(1); - } -#endif - if (hdr.fhdr.f_nscns != 6) { - fprintf(stderr, "unexec: %d sections instead of 6.\n", hdr.fhdr.f_nscns); - } -#define CHECK_SCNHDR(field, name, flags) \ - if (strcmp(hdr.field.s_name, name) != 0) { \ - fprintf(stderr, "unexec: %s section where %s expected.\n", \ - hdr.field.s_name, name); \ - exit(1); \ - } \ - else if (hdr.field.s_flags != flags) { \ - fprintf(stderr, "unexec: %x flags where %x expected in %s section.\n", \ - hdr.field.s_flags, flags, name); \ - } - CHECK_SCNHDR(text_section, _TEXT, STYP_TEXT); - CHECK_SCNHDR(rdata_section, _RDATA, STYP_RDATA); - CHECK_SCNHDR(data_section, _DATA, STYP_DATA); - CHECK_SCNHDR(sdata_section, _SDATA, STYP_SDATA); - CHECK_SCNHDR(sbss_section, _SBSS, STYP_SBSS); - CHECK_SCNHDR(bss_section, _BSS, STYP_BSS); - - pagesize = getpagesize(); - brk = (sbrk(0) + pagesize - 1) & (-pagesize); - hdr.aout.dsize = brk - DATA_START; - hdr.aout.bsize = 0; - if (entry_address == 0) { - extern __start(); - hdr.aout.entry = (unsigned)__start; - } - else { - hdr.aout.entry = entry_address; - } - hdr.aout.bss_start = hdr.aout.data_start + hdr.aout.dsize; - hdr.rdata_section.s_size = data_start - DATA_START; - hdr.data_section.s_vaddr = data_start; - hdr.data_section.s_paddr = data_start; - hdr.data_section.s_size = brk - DATA_START; - hdr.data_section.s_scnptr = hdr.rdata_section.s_scnptr - + hdr.rdata_section.s_size; - hdr.sdata_section.s_vaddr = hdr.data_section.s_vaddr - + hdr.data_section.s_size; - hdr.sdata_section.s_paddr = hdr.sdata_section.s_paddr; - hdr.sdata_section.s_size = 0; - hdr.sdata_section.s_scnptr = hdr.data_section.s_scnptr - + hdr.data_section.s_size; - hdr.sbss_section.s_vaddr = hdr.sdata_section.s_vaddr - + hdr.sdata_section.s_size; - hdr.sbss_section.s_paddr = hdr.sbss_section.s_vaddr; - hdr.sbss_section.s_size = 0; - hdr.sbss_section.s_scnptr = hdr.sdata_section.s_scnptr - + hdr.sdata_section.s_size; - hdr.bss_section.s_vaddr = hdr.sbss_section.s_vaddr - + hdr.sbss_section.s_size; - hdr.bss_section.s_paddr = hdr.bss_section.s_vaddr; - hdr.bss_section.s_size = 0; - hdr.bss_section.s_scnptr = hdr.sbss_section.s_scnptr - + hdr.sbss_section.s_size; - - WRITE(new, TEXT_START, hdr.aout.tsize, - "writing text section to %s", new_name); - WRITE(new, DATA_START, hdr.aout.dsize, - "writing text section to %s", new_name); - - SEEK(old, hdr.fhdr.f_symptr, "seeking to start of symbols in %s", a_name); - errno = EEOF; - nread = read(old, buffer, BUFSIZE); - if (nread < sizeof(HDRR)) fatal("reading symbols from %s", a_name); -#define symhdr ((pHDRR)buffer) - newsyms = hdr.aout.tsize + hdr.aout.dsize; - symrel = newsyms - hdr.fhdr.f_symptr; - hdr.fhdr.f_symptr = newsyms; - symhdr->cbLineOffset += symrel; - symhdr->cbDnOffset += symrel; - symhdr->cbPdOffset += symrel; - symhdr->cbSymOffset += symrel; - symhdr->cbOptOffset += symrel; - symhdr->cbAuxOffset += symrel; - symhdr->cbSsOffset += symrel; - symhdr->cbSsExtOffset += symrel; - symhdr->cbFdOffset += symrel; - symhdr->cbRfdOffset += symrel; - symhdr->cbExtOffset += symrel; -#undef symhdr - do { - if (write(new, buffer, nread) != nread) - fatal("writing symbols to %s", new_name); - nread = read(old, buffer, BUFSIZE); - if (nread < 0) fatal("reading symbols from %s", a_name); -#undef BUFSIZE - } while (nread != 0); - - SEEK(new, 0, "seeking to start of header in %s", new_name); - WRITE(new, &hdr, sizeof(hdr), - "writing header of %s", new_name); - - close(old); - close(new); - mark_x(new_name); -} - -/* - * mark_x - * - * After succesfully building the new a.out, mark it executable - */ -static -mark_x (name) - char *name; -{ - struct stat sbuf; - int um = umask (777); - umask (um); - if (stat(name, &sbuf) < 0) - fatal("getting protection on %s", name); - sbuf.st_mode |= 0111 & ~um; - if (chmod(name, sbuf.st_mode) < 0) - fatal("setting protection on %s", name); -} - -#endif /* mips */ diff --git a/v7/src/microcode/usrdef.h b/v7/src/microcode/usrdef.h deleted file mode 100644 index bc53cad04..000000000 --- a/v7/src/microcode/usrdef.h +++ /dev/null @@ -1,45 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/usrdef.h,v 9.36 1987/04/16 02:31:57 jinx Rel $ */ - -/* Macros and header for usrdef.c and variants. */ - -#include "config.h" -#include "object.h" -#include "errors.h" -#include "prim.h" -#include "primitive.h" - -extern void - Microcode_Termination(), - signal_error_from_primitive(); diff --git a/v7/src/microcode/utabmd.scm b/v7/src/microcode/utabmd.scm deleted file mode 100644 index f0b7e05d7..000000000 --- a/v7/src/microcode/utabmd.scm +++ /dev/null @@ -1,857 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Machine Dependent Type Tables - -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.25 1987/04/16 02:32:05 jinx Exp $ - -(declare (usual-integrations)) - -;;; For quick access to any given table, -;;; search for the following strings: -;;; -;;; [] Fixed -;;; [] Types -;;; [] Returns -;;; [] Primitives -;;; [] External -;;; [] Errors -;;; [] Identification - -;;; [] Fixed - -(vector-set! (get-fixed-objects-vector) - #x0F ;(fixed-objects-vector-slot 'MICROCODE-FIXED-OBJECTS-SLOTS) - #(NON-OBJECT ;00 - SYSTEM-INTERRUPT-VECTOR ;01 - SYSTEM-ERROR-VECTOR ;02 - OBARRAY ;03 - MICROCODE-TYPES-VECTOR ;04 - MICROCODE-RETURNS-VECTOR ;05 - MICROCODE-PRIMITIVES-VECTOR ;06 - MICROCODE-ERRORS-VECTOR ;07 - MICROCODE-IDENTIFICATION-VECTOR ;08 - #F ;09 - #F ;0A - GC-DAEMON ;0B - TRAP-HANDLER ;0C - #F ;0D - STEPPER-STATE ;0E - MICROCODE-FIXED-OBJECTS-SLOTS ;0F - MICROCODE-EXTERNAL-PRIMITIVES ;10 - STATE-SPACE-TAG ;11 - STATE-POINT-TAG ;12 - DUMMY-HISTORY ;13 - BIGNUM-ONE ;14 - SCHEDULER ;15 - MICROCODE-TERMINATIONS-VECTOR ;16 - MICROCODE-TERMINATIONS-PROCEDURES ;17 - FIXED-OBJECTS-VECTOR ;18 - THE-WORK-QUEUE ;19 - FUTURE-READS-LOGGER ;1A - TOUCHED-FUTURES-VECTOR ;1B - PRECIOUS-OBJECTS ;1C - ERROR-PROCEDURE ;1D - UNSNAPPED-LINK ;1E - MICROCODE-UTILITIES-VECTOR ;1F - COMPILER-ERROR-PROCEDURE ;20 - LOST-OBJECT-BASE ;21 - STATE-SPACE-ROOT ;22 - MICROCODE-TABLE-IDENTIFICATION ;23 - )) - -;;; [] Types - -(vector-set! (get-fixed-objects-vector) - 4 ;(fixed-objects-vector-slot 'MICROCODE-TYPES-VECTOR) - #((NULL FALSE MANIFEST-VECTOR GLOBAL-ENVIRONMENT) ;00 - (PAIR LIST) ;01 - CHARACTER ;02 - QUOTATION ;03 - PRIMITIVE-COMBINATION-2 ;04 - UNINTERNED-SYMBOL ;05 - (FLONUM BIG-FLONUM) ;06 - COMBINATION-1 ;07 - TRUE ;08 - EXTENDED-PROCEDURE ;09 - VECTOR ;0A - RETURN-ADDRESS ;0B - COMBINATION-2 ;0C - COMPILED-PROCEDURE ;0D - (BIGNUM BIG-FIXNUM) ;0E - PROCEDURE ;0F - PRIMITIVE-EXTERNAL ;10 - DELAY ;11 - ENVIRONMENT ;12 - DELAYED ;13 - EXTENDED-LAMBDA ;14 - COMMENT ;15 - NON-MARKED-VECTOR ;16 - LAMBDA ;17 - PRIMITIVE ;18 - SEQUENCE-2 ;19 - (FIXNUM ADDRESS) ;1A - PRIMITIVE-COMBINATION-1 ;1B - CONTROL-POINT ;1C - INTERNED-SYMBOL ;1D - (STRING CHARACTER-STRING VECTOR-8B) ;1E - ACCESS ;1F - #F ;20 - DEFINITION ;21 - BROKEN-HEART ;22 - ASSIGNMENT ;23 - (TRIPLE HUNK3) ;24 - IN-PACKAGE ;25 - COMBINATION ;26 - MANIFEST-NM-VECTOR ;27 - COMPILED-EXPRESSION ;28 - LEXPR ;29 - PRIMITIVE-COMBINATION-3 ;2A - MANIFEST-SPECIAL-NM-VECTOR ;2B - VARIABLE ;2C - THE-ENVIRONMENT ;2D - FUTURE ;2E - VECTOR-1B ;2F - PRIMITIVE-COMBINATION-0 ;30 - VECTOR-16B ;31 - (REFERENCE-TRAP UNASSIGNED) ;32 - SEQUENCE-3 ;33 - CONDITIONAL ;34 - DISJUNCTION ;35 - CELL ;36 - WEAK-CONS ;37 - QUAD ;38 - COMPILER-RETURN-ADDRESS ;39 - COMPILER-LINK ;3A - STACK-ENVIRONMENT ;3B - COMPLEX ;3C - #F ;3D - #F ;3E - #F ;3F - #F ;40 - #F ;41 - #F ;42 - #F ;43 - #F ;44 - #F ;45 - #F ;46 - #F ;47 - #F ;48 - #F ;49 - #F ;4A - #F ;4B - #F ;4C - #F ;4D - #F ;4E - #F ;4F - #F ;50 - #F ;51 - #F ;52 - #F ;53 - #F ;54 - #F ;55 - #F ;56 - #F ;57 - #F ;58 - #F ;59 - #F ;5A - #F ;5B - #F ;5C - #F ;5D - #F ;5E - #F ;5F - #F ;60 - #F ;61 - #F ;62 - #F ;63 - #F ;64 - #F ;65 - #F ;66 - #F ;67 - #F ;68 - #F ;69 - #F ;6A - #F ;6B - #F ;6C - #F ;6D - #F ;6E - #F ;6F - #F ;70 - #F ;71 - #F ;72 - #F ;73 - #F ;74 - #F ;75 - #F ;76 - #F ;77 - #F ;78 - #F ;79 - #F ;7A - #F ;7B - #F ;7C - #F ;7D - #F ;7E - #F ;7F - )) - -;;; [] Returns - -(vector-set! (get-fixed-objects-vector) - 5 ;(fixed-objects-vector-slot 'MICROCODE-RETURNS-VECTOR) - #(NON-EXISTENT-CONTINUATION ;00 - JOIN-STACKLETS ;01 - RESTORE-CONTINUATION ;02 - INTERNAL-APPLY ;03 - BAD-INTERRUPT-CONTINUE ;04 - RESTORE-HISTORY ;05 - INVOKE-STACK-THREAD ;06 - RESTART-EXECUTION ;07 - ASSIGNMENT-CONTINUE ;08 - DEFINITION-CONTINUE ;09 - ACCESS-CONTINUE ;0A - IN-PACKAGE-CONTINUE ;0B - SEQUENCE-2-SECOND ;0C - SEQUENCE-3-SECOND ;0D - SEQUENCE-3-THIRD ;0E - CONDITIONAL-DECIDE ;0F - DISJUNCTION-DECIDE ;10 - COMBINATION-1-PROCEDURE ;11 - COMBINATION-APPLY ;12 - COMBINATION-2-FIRST-OPERAND ;13 - COMBINATION-2-PROCEDURE ;14 - COMBINATION-SAVE-VALUE ;15 - PRIMITIVE-COMBINATION-1-APPLY ;16 - PRIMITIVE-COMBINATION-2-FIRST-OPERAND ;17 - PRIMITIVE-COMBINATION-2-APPLY ;18 - PRIMITIVE-COMBINATION-3-SECOND-OPERAND ;19 - PRIMITIVE-COMBINATION-3-FIRST-OPERAND ;1A - PRIMITIVE-COMBINATION-3-APPLY ;1B - FORCE-SNAP-THUNK ;1C - REENTER-COMPILED-CODE ;1D - #F ;1E - COMPILER-REFERENCE-RESTART ;1F - NORMAL-GARBAGE-COLLECT-DONE ;20 - COMPLETE-GARBAGE-COLLECT-DONE ;21 - PURIFY-AFTER-FIRST-GC ;22 - PURIFY-AFTER-SECOND-GC ;23 - AFTER-MEMORY-UPDATE ;24 - RETRY-MICROCODE-TERMINATION-RESTARTABLE ;25 - #F ;26 - #F ;27 - COMPILER-ASSIGNMENT-RESTART ;28 - POP-FROM-COMPILED-CODE ;29 - RETURN-TRAP-POINT ;2A - RESTORE-STEPPER ;2B - RESTORE-TO-STATE-POINT ;2C - MOVE-TO-ADJACENT-POINT ;2D - RESTORE-VALUE ;2E - RESTORE-DONT-COPY-HISTORY ;2F - #F ;30 - #F ;31 - #F ;32 - #F ;33 - #F ;34 - #F ;35 - #F ;36 - #F ;37 - #F ;38 - #F ;39 - #F ;3A - #F ;3B - #F ;3C - #F ;3D - #F ;3E - #F ;3F - POP-RETURN-ERROR ;40 - EVAL-ERROR ;41 - REPEAT-PRIMITIVE ;42 - COMPILER-INTERRUPT-RESTART ;43 - #F ;44 - RESTORE-INTERRUPT-MASK ;45 - HALT ;46 - FINISH-GLOBAL-INTERRUPT ;47 - REPEAT-DISPATCH ;48 - GC-CHECK ;49 - RESTORE-FLUIDS ;4A - COMPILER-LOOKUP-APPLY-RESTART ;4B - COMPILER-ACCESS-RESTART ;4C - COMPILER-UNASSIGNED?-RESTART ;4D - COMPILER-UNBOUND?-RESTART ;4E - COMPILER-DEFINITION-RESTART ;4F - COMPILER-LEXPR-INTERRUPT-RESTART ;50 - )) - -;;; [] Primitives - -(vector-set! (get-fixed-objects-vector) - 6 ;(fixed-objects-vector-slot 'MICROCODE-PRIMITIVES-VECTOR) - #(LEXICAL-ASSIGNMENT ;$00 - LOCAL-REFERENCE ;$01 - LOCAL-ASSIGNMENT ;$02 - CALL-WITH-CURRENT-CONTINUATION ;$03 - SCODE-EVAL ;$04 - APPLY ;$05 - SET-INTERRUPT-ENABLES! ;$06 - STRING->SYMBOL ;$07 - GET-WORK ;$08 - NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION ;$09 - CURRENT-DYNAMIC-STATE ;$0A - SET-CURRENT-DYNAMIC-STATE! ;$0B - (NULL? NOT FALSE?) ;$0C - EQ? ;$0D - STRING-EQUAL? ;$0E - PRIMITIVE-TYPE? ;$0F - PRIMITIVE-TYPE ;$10 - PRIMITIVE-SET-TYPE ;$11 - LEXICAL-REFERENCE ;$12 - LEXICAL-UNREFERENCEABLE? ;$13 - MAKE-CHAR ;$14 - CHAR-BITS ;$15 - EXIT ;$16 - CHAR-CODE ;$17 - LEXICAL-UNASSIGNED? ;$18 - INSERT-NON-MARKED-VECTOR! ;$19 - HALT ;$1A - CHAR->INTEGER ;$1B - MEMQ ;$1C - INSERT-STRING ;$1D - ENABLE-INTERRUPTS! ;$1E - MAKE-EMPTY-STRING ;$1F - CONS ;$20 - (CAR FIRST) ;$21 - (CDR FIRST-TAIL) ;$22 - (SET-CAR! SET-FIRST!) ;$23 - (SET-CDR! SET-FIRST-TAIL!) ;$24 - #F ;$25 - TTY-GET-CURSOR ;$26 - GENERAL-CAR-CDR ;$27 - HUNK3-CONS ;$28 - HUNK3-CXR ;$29 - HUNK3-SET-CXR! ;$2A - INSERT-STRING! ;$2B - VECTOR-CONS ;$2C - (VECTOR-LENGTH VECTOR-SIZE) ;$2D - VECTOR-REF ;$2E - SET-CURRENT-HISTORY! ;$2F - VECTOR-SET! ;$30 - NON-MARKED-VECTOR-CONS ;$31 - #F ;$32 - LEXICAL-UNBOUND? ;$33 - INTEGER->CHAR ;$34 - CHAR-DOWNCASE ;$35 - CHAR-UPCASE ;$36 - ASCII->CHAR ;$37 - CHAR-ASCII? ;$38 - CHAR->ASCII ;$39 - GARBAGE-COLLECT ;$3A - PLUS-FIXNUM ;$3B - MINUS-FIXNUM ;$3C - MULTIPLY-FIXNUM ;$3D - DIVIDE-FIXNUM ;$3E - EQUAL-FIXNUM? ;$3F - LESS-THAN-FIXNUM? ;$40 - POSITIVE-FIXNUM? ;$41 - ONE-PLUS-FIXNUM ;$42 - MINUS-ONE-PLUS-FIXNUM ;$43 - TRUNCATE-STRING! ;$44 - SUBSTRING ;$45 - ZERO-FIXNUM? ;$46 - MAKE-OBJECT-SAFE ;$47 - MAKE-OBJECT-DANGEROUS ;$48 - OBJECT-DANGEROUS? ;$49 - SUBSTRING->LIST ;$4A - MAKE-FILLED-STRING ;$4B - PLUS-BIGNUM ;$4C - MINUS-BIGNUM ;$4D - MULTIPLY-BIGNUM ;$4E - DIVIDE-BIGNUM ;$4F - LISTIFY-BIGNUM ;$50 - EQUAL-BIGNUM? ;$51 - LESS-THAN-BIGNUM? ;$52 - POSITIVE-BIGNUM? ;$53 - FILE-OPEN-CHANNEL ;$54 - FILE-CLOSE-CHANNEL ;$55 - PRIMITIVE-FASDUMP ;$56 - BINARY-FASLOAD ;$57 - STRING-POSITION ;$58 - STRING-LESS? ;$59 - #F ;$5A - #F ;$5B - REHASH ;$5C - LENGTH ;$5D - ASSQ ;$5E - LIST->STRING ;$5F - EQUAL-STRING-TO-LIST? ;$60 - MAKE-CELL ;$61 - CELL-CONTENTS ;$62 - CELL? ;$63 - CHARACTER-UPCASE ;$64 - CHARACTER-LIST-HASH ;$65 - GCD-FIXNUM ;$66 - COERCE-FIXNUM-TO-BIGNUM ;$67 - COERCE-BIGNUM-TO-FIXNUM ;$68 - PLUS-FLONUM ;$69 - MINUS-FLONUM ;$6A - MULTIPLY-FLONUM ;$6B - DIVIDE-FLONUM ;$6C - EQUAL-FLONUM? ;$6D - LESS-THAN-FLONUM? ;$6E - ZERO-BIGNUM? ;$6F - TRUNCATE-FLONUM ;$70 - ROUND-FLONUM ;$71 - COERCE-INTEGER-TO-FLONUM ;$72 - SINE-FLONUM ;$73 - COSINE-FLONUM ;$74 - ARCTAN-FLONUM ;$75 - EXP-FLONUM ;$76 - LN-FLONUM ;$77 - SQRT-FLONUM ;$78 - PRIMITIVE-FASLOAD ;$79 - GET-FIXED-OBJECTS-VECTOR ;$7A - SET-FIXED-OBJECTS-VECTOR! ;$7B - LIST->VECTOR ;$7C - SUBVECTOR->LIST ;$7D - PAIR? ;$7E - NEGATIVE-FIXNUM? ;$7F - NEGATIVE-BIGNUM? ;$80 - GREATER-THAN-FIXNUM? ;$81 - GREATER-THAN-BIGNUM? ;$82 - STRING-HASH ;$83 - SYSTEM-PAIR-CONS ;$84 - SYSTEM-PAIR? ;$85 - SYSTEM-PAIR-CAR ;$86 - SYSTEM-PAIR-CDR ;$87 - SYSTEM-PAIR-SET-CAR! ;$88 - SYSTEM-PAIR-SET-CDR! ;$89 - #F ;$8A - #F ;$8B - SET-CELL-CONTENTS! ;$8C - &MAKE-OBJECT ;$8D - SYSTEM-HUNK3-CXR0 ;$8E - SYSTEM-HUNK3-SET-CXR0! ;$8F - MAP-MACHINE-ADDRESS-TO-CODE ;$90 - SYSTEM-HUNK3-CXR1 ;$91 - SYSTEM-HUNK3-SET-CXR1! ;$92 - MAP-CODE-TO-MACHINE-ADDRESS ;$93 - SYSTEM-HUNK3-CXR2 ;$94 - SYSTEM-HUNK3-SET-CXR2! ;$95 - PRIMITIVE-PROCEDURE-ARITY ;$96 - SYSTEM-LIST-TO-VECTOR ;$97 - SYSTEM-SUBVECTOR-TO-LIST ;$98 - SYSTEM-VECTOR? ;$99 - SYSTEM-VECTOR-REF ;$9A - SYSTEM-VECTOR-SET! ;$9B - WITH-HISTORY-DISABLED ;$9C - #F ;$9D - #F ;$9E - #F ;$9F - #F ;$A0 - #F ;$A1 - #F ;$A2 - VECTOR-8B-CONS ;$A3 - VECTOR-8B? ;$A4 - VECTOR-8B-REF ;$A5 - VECTOR-8B-SET! ;$A6 - ZERO-FLONUM? ;$A7 - POSITIVE-FLONUM? ;$A8 - NEGATIVE-FLONUM? ;$A9 - GREATER-THAN-FLONUM? ;$AA - INTERN-CHARACTER-LIST ;$AB - #F ;$AC - (STRING-SIZE VECTOR-8B-SIZE) ;$AD - SYSTEM-VECTOR-SIZE ;$AE - FORCE ;$AF - PRIMITIVE-DATUM ;$B0 - MAKE-NON-POINTER-OBJECT ;$B1 - DEBUGGING-PRINTER ;$B2 - STRING-UPCASE ;$B3 - PRIMITIVE-PURIFY ;$B4 - #F ;$B5 - COMPLETE-GARBAGE-COLLECT ;$B6 - DUMP-BAND ;$B7 - SUBSTRING-SEARCH ;$B8 - LOAD-BAND ;$B9 - CONSTANT? ;$BA - PURE? ;$BB - PRIMITIVE-GC-TYPE ;$BC - PRIMITIVE-IMPURIFY ;$BD - WITH-THREADED-CONTINUATION ;$BE - WITHIN-CONTROL-POINT ;$BF - SET-RUN-LIGHT! ;$C0 - FILE-EOF? ;$C1 - FILE-READ-CHAR ;$C2 - FILE-FILL-INPUT-BUFFER ;$C3 - FILE-LENGTH ;$C4 - FILE-WRITE-CHAR ;$C5 - FILE-WRITE-STRING ;$C6 - CLOSE-LOST-OPEN-FILES ;$C7 - #F ;$C8 - WITH-INTERRUPTS-REDUCED ;$C9 - PRIMITIVE-EVAL-STEP ;$CA - PRIMITIVE-APPLY-STEP ;$CB - PRIMITIVE-RETURN-STEP ;$CC - TTY-READ-CHAR-READY? ;$CD - TTY-READ-CHAR ;$CE - TTY-READ-CHAR-IMMEDIATE ;$CF - TTY-READ-FINISH ;$D0 - BIT-STRING-ALLOCATE ;$D1 - MAKE-BIT-STRING ;$D2 - BIT-STRING? ;$D3 - BIT-STRING-LENGTH ;$D4 - BIT-STRING-REF ;$D5 - BIT-SUBSTRING-MOVE-RIGHT! ;$D6 - BIT-STRING-SET! ;$D7 - BIT-STRING-CLEAR! ;$D8 - BIT-STRING-ZERO? ;$D9 - #F ;$DA - #F ;$DB - UNSIGNED-INTEGER->BIT-STRING ;$DC - BIT-STRING->UNSIGNED-INTEGER ;$DD - #F ;$DE - READ-BITS! ;$DF - WRITE-BITS! ;$E0 - MAKE-STATE-SPACE ;$E1 - EXECUTE-AT-NEW-STATE-POINT ;$E2 - TRANSLATE-TO-STATE-POINT ;$E3 - GET-NEXT-CONSTANT ;$E4 - MICROCODE-IDENTIFY ;$E5 - ZERO? ;$E6 - POSITIVE? ;$E7 - NEGATIVE? ;$E8 - &= ;$E9 - &< ;$EA - &> ;$EB - &+ ;$EC - &- ;$ED - &* ;$EE - &/ ;$EF - INTEGER-DIVIDE ;$F0 - 1+ ;$F1 - -1+ ;$F2 - TRUNCATE ;$F3 - ROUND ;$F4 - FLOOR ;$F5 - CEILING ;$F6 - SQRT ;$F7 - EXP ;$F8 - LOG ;$F9 - SIN ;$FA - COS ;$FB - &ATAN ;$FC - TTY-WRITE-CHAR ;$FD - TTY-WRITE-STRING ;$FE - TTY-BEEP ;$FF - TTY-CLEAR ;$100 - GET-EXTERNAL-COUNTS ;$101 - GET-EXTERNAL-NAME ;$102 - GET-EXTERNAL-NUMBER ;$103 - #F ;$104 - #F ;$105 - GET-NEXT-INTERRUPT-CHARACTER ;$106 - CHECK-AND-CLEAN-UP-INPUT-CHANNEL ;$107 - #F ;$108 - SYSTEM-CLOCK ;$109 - FILE-EXISTS? ;$10A - #F ;$10B - TTY-MOVE-CURSOR ;$10C - #F ;$10D - CURRENT-DATE ;$10E - CURRENT-TIME ;$10F - TRANSLATE-FILE ;$110 - COPY-FILE ;$111 - RENAME-FILE ;$112 - REMOVE-FILE ;$113 - LINK-FILE ;$114 - MAKE-DIRECTORY ;$115 - VOLUME-NAME ;$116 - SET-WORKING-DIRECTORY-PATHNAME! ;$117 - OPEN-CATALOG ;$118 - CLOSE-CATALOG ;$119 - NEXT-FILE ;$11A - CAT-NAME ;$11B - CAT-KIND ;$11C - CAT-PSIZE ;$11D - CAT-LSIZE ;$11E - CAT-INFO ;$11F - CAT-BLOCK ;$120 - CAT-CREATE-DATE ;$121 - CAT-CREATE-TIME ;$122 - CAT-LAST-DATE ;$123 - CAT-LAST-TIME ;$124 - ERROR-MESSAGE ;$125 - CURRENT-YEAR ;$126 - CURRENT-MONTH ;$127 - CURRENT-DAY ;$128 - CURRENT-HOUR ;$129 - CURRENT-MINUTE ;$12A - CURRENT-SECOND ;$12B - INIT-FLOPPY ;$12C - ZERO-FLOPPY ;$12D - PACK-VOLUME ;$12E - LOAD-PICTURE ;$12F - STORE-PICTURE ;$130 - LOOKUP-SYSTEM-SYMBOL ;$131 - #F ;$132 - #F ;$133 - CLEAR-TO-END-OF-LINE ;$134 - #F ;$135 - #F ;$136 - WITH-INTERRUPT-MASK ;$137 - STRING? ;$138 - STRING-LENGTH ;$139 - STRING-REF ;$13A - STRING-SET! ;$13B - SUBSTRING-MOVE-RIGHT! ;$13C - SUBSTRING-MOVE-LEFT! ;$13D - STRING-ALLOCATE ;$13E - STRING-MAXIMUM-LENGTH ;$13F - SET-STRING-LENGTH! ;$140 - VECTOR-8B-FILL! ;$141 - VECTOR-8B-FIND-NEXT-CHAR ;$142 - VECTOR-8B-FIND-PREVIOUS-CHAR ;$143 - VECTOR-8B-FIND-NEXT-CHAR-CI ;$144 - VECTOR-8B-FIND-PREVIOUS-CHAR-CI ;$145 - SUBSTRING-FIND-NEXT-CHAR-IN-SET ;$146 - SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET ;$147 - SUBSTRING=? ;$148 - SUBSTRING-CI=? ;$149 - SUBSTRINGSYNTAX-ENTRY ;$176 - SCAN-WORD-FORWARD ;$177 - SCAN-WORD-BACKWARD ;$178 - SCAN-LIST-FORWARD ;$179 - SCAN-LIST-BACKWARD ;$17A - SCAN-SEXPS-FORWARD ;$17B - SCAN-FORWARD-TO-WORD ;$17C - SCAN-BACKWARD-PREFIX-CHARS ;$17D - CHAR->SYNTAX-CODE ;$17E - QUOTED-CHAR? ;$17F - MICROCODE-TABLES-FILENAME ;$180 - #F ;$181 - #F #| FIND-PASCAL-PROGRAM |# ;$182 - #F #| EXECUTE-PASCAL-PROGRAM |# ;$183 - #F #| GRAPHICS-MOVE |# ;$184 - #F #| GRAPHICS-LINE |# ;$185 - #F #| GRAPHICS-PIXEL |# ;$186 - #F #| GRAPHICS-SET-DRAWING-MODE |# ;$187 - #F #| ALPHA-RASTER? |# ;$188 - #F #| TOGGLE-ALPHA-RASTER |# ;$189 - #F #| GRAPHICS-RASTER? |# ;$18A - #F #| TOGGLE-GRAPHICS-RASTER |# ;$18B - #F #| GRAPHICS-CLEAR |# ;$18C - #F #| GRAPHICS-SET-LINE-STYLE |# ;$18D - ERROR-PROCEDURE ;$18E - VOLUME-EXISTS? ;$18F - RE-CHAR-SET-ADJOIN! ;$190 - RE-COMPILE-FASTMAP ;$191 - RE-MATCH ;$192 - RE-SEARCH-FORWARD ;$193 - RE-SEARCH-BACKWARD ;$194 - (SYSTEM-MEMORY-REF &OBJECT-REF) ;$195 - (SYSTEM-MEMORY-SET! &OBJECT-SET!) ;$196 - BIT-STRING-FILL! ;$197 - BIT-STRING-MOVE! ;$198 - BIT-STRING-MOVEC! ;$199 - BIT-STRING-OR! ;$19A - BIT-STRING-AND! ;$19B - BIT-STRING-ANDC! ;$19C - BIT-STRING=? ;$19D - WORKING-DIRECTORY-PATHNAME ;$19E - OPEN-DIRECTORY ;$19F - DIRECTORY-READ ;$1A0 - UNDER-EMACS? ;$1A1 - TTY-FLUSH-OUTPUT ;$1A2 - RELOAD-BAND-NAME ;$1A3 - )) - -;;; [] External - -(vector-set! (get-fixed-objects-vector) - 16 ;(fixed-objects-vector-slot 'MICROCODE-EXTERNAL-PRIMITIVES) - #()) - -;;; [] Errors - -(vector-set! (get-fixed-objects-vector) - 7 ;(fixed-objects-vector-slot 'MICROCODE-ERRORS-VECTOR) - #(BAD-ERROR-CODE ;00 - UNBOUND-VARIABLE ;01 - UNASSIGNED-VARIABLE ;02 - UNDEFINED-PROCEDURE ;03 - #F ;04 - #F ;05 - BAD-FRAME ;06 - BROKEN-CVARIABLE ;07 - UNDEFINED-USER-TYPE ;08 - UNDEFINED-PRIMITIVE-OPERATION ;09 - EXTERNAL-RETURN ;0A - EXECUTE-MANIFEST-VECTOR ;0B - WRONG-NUMBER-OF-ARGUMENTS ;0C - WRONG-TYPE-ARGUMENT-0 ;0D - WRONG-TYPE-ARGUMENT-1 ;0E - WRONG-TYPE-ARGUMENT-2 ;0F - BAD-RANGE-ARGUMENT-0 ;10 - BAD-RANGE-ARGUMENT-1 ;11 - BAD-RANGE-ARGUMENT-2 ;12 - #F ;13 - #F ;14 - BAD-INTERRUPT-CODE ;15 - #F ;16 - FASL-FILE-TOO-BIG ;17 - FASL-FILE-BAD-DATA ;18 - IMPURIFY-OBJECT-TOO-LARGE ;19 - WRITE-INTO-PURE-SPACE ;1A - #F ;1B - #F ;1C - #F ;1D - FAILED-ARG-1-COERCION ;1E - FAILED-ARG-2-COERCION ;1F - OUT-OF-FILE-HANDLES ;20 - #F ;21 - BAD-RANGE-ARGUMENT-3 ;22 - BAD-RANGE-ARGUMENT-4 ;23 - BAD-RANGE-ARGUMENT-5 ;24 - BAD-RANGE-ARGUMENT-6 ;25 - BAD-RANGE-ARGUMENT-7 ;26 - BAD-RANGE-ARGUMENT-8 ;27 - BAD-RANGE-ARGUMENT-9 ;28 - WRONG-TYPE-ARGUMENT-3 ;29 - WRONG-TYPE-ARGUMENT-4 ;2A - WRONG-TYPE-ARGUMENT-5 ;2B - WRONG-TYPE-ARGUMENT-6 ;2C - WRONG-TYPE-ARGUMENT-7 ;2D - WRONG-TYPE-ARGUMENT-8 ;2E - WRONG-TYPE-ARGUMENT-9 ;2F - INAPPLICABLE-CONTINUATION ;30 - COMPILED-CODE-ERROR ;31 - FLOATING-OVERFLOW ;32 - UNIMPLEMENTED-PRIMITIVE ;33 - )) - -;;; [] Terminations - -(vector-set! (get-fixed-objects-vector) - 22 ;(fixed-objects-vector-slot 'MICROCODE-TERMINATIONS-VECTOR) - #(HALT ;00 - DISK-RESTORE ;01 - BROKEN-HEART ;02 - NON-POINTER-RELOCATION ;03 - BAD-ROOT ;04 - NON-EXISTENT-CONTINUATION ;05 - BAD-STACK ;06 - STACK-OVERFLOW ;07 - STACK-ALLOCATION-FAILED ;08 - NO-ERROR-HANDLER ;09 - NO-INTERRUPT-HANDLER ;0A - UNIMPLEMENTED-CONTINUATION ;0B - EXIT ;0C - BAD-PRIMITIVE-DURING-ERROR ;0D - EOF ;0E - BAD-PRIMITIVE ;0F - TERMINATION-HANDLER ;10 - END-OF-CONTINUATION ;11 - INVALID-TYPE-CODE ;12 - COMPILER-DEATH ;13 - GC-OUT-OF-SPACE ;14 - )) - -(vector-set! (get-fixed-objects-vector) - 23 ;(fixed-objects-vector-slot 'MICROCODE-TERMINATION-PROCEDURES) - #()) - -;;; [] Identification - -(vector-set! (get-fixed-objects-vector) - 8 ;(fixed-objects-vector-slot 'MICROCODE-IDENTIFICATION-VECTOR) - #(SYSTEM-RELEASE-STRING ;00 - MICROCODE-VERSION ;01 - MICROCODE-MODIFICATION ;02 - CONSOLE-WIDTH ;03 - CONSOLE-HEIGHT ;04 - NEWLINE-CHAR ;05 - FLONUM-MANTISSA-LENGTH ;06 - FLONUM-EXPONENT-LENGTH ;07 - OS-NAME-STRING ;08 - OS-VARIANT-STRING ;09 - )) - -;;; This identification string is saved by the system. - -"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.25 1987/04/16 02:32:05 jinx Exp $" diff --git a/v7/src/microcode/utils.c b/v7/src/microcode/utils.c deleted file mode 100644 index 14c74571a..000000000 --- a/v7/src/microcode/utils.c +++ /dev/null @@ -1,1030 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utils.c,v 9.23 1987/04/16 02:32:25 jinx Exp $ */ - -/* This file contains utilities for interrupts, errors, etc. */ - -#include "scheme.h" -#include "primitive.h" -#include "flonum.h" -#include "winder.h" - -/* Set_Up_Interrupt is called from the Interrupt - * macro to do all of the setup for calling the user's - * interrupt routines. - */ - -void -Setup_Interrupt (Masked_Interrupts) - long Masked_Interrupts; -{ - Pointer Int_Vector, Handler; - long i, Int_Number, The_Int_Code = IntCode, New_Int_Enb; - long Save_Space; - - Int_Vector = Get_Fixed_Obj_Slot(System_Interrupt_Vector); - - for (Int_Number=0, i=1; - Int_Number < MAX_INTERRUPT_NUMBER; - i = i<<1, Int_Number++) - if ((Masked_Interrupts & i) != 0) - goto OK; - - fprintf(stderr, "\nInterrupts = 0x%x, Mask= 0x%x, Masked = 0x%x\n", - IntCode, IntEnb, Masked_Interrupts); - fprintf(stderr, "Int_Vector %x\n", Int_Vector); - Microcode_Termination(TERM_NO_INTERRUPT_HANDLER); - -OK: - New_Int_Enb = (1< Vector_Length(Int_Vector)) - { fprintf(stderr, - "\nInterrupt out of range: 0x%x (vector length = 0x%x)\n", - Int_Number, Vector_Length(Int_Vector)); - fprintf(stderr, - "Interrupts = 0x%x, Mask= 0x%x, Masked = 0x%x\n", - IntCode, IntEnb, Masked_Interrupts); - Microcode_Termination(TERM_NO_INTERRUPT_HANDLER); - } - else Handler = User_Vector_Ref(Int_Vector, Int_Number); - -/* Setup_Interrupt continues on the next page */ - -/* Setup_Interrupt, continued */ - -Passed_Checks: /* This label may be used in Global_Interrupt_Hook */ - Stop_History(); - Save_Space = CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS+3; - if (New_Int_Enb+1 == INT_GC) Save_Space += CONTINUATION_SIZE; - Will_Push(Save_Space); - /* Return from interrupt handler will re-enable interrupts */ - Store_Return(RC_RESTORE_INT_MASK); - Store_Expression(Make_Unsigned_Fixnum(IntEnb)); - Save_Cont(); - if (New_Int_Enb+1 == INT_GC) - { Store_Return(RC_GC_CHECK); - Store_Expression(Make_Unsigned_Fixnum(GC_Space_Needed)); - Save_Cont(); - } - -/* Now make an environment frame for use in calling the - * user supplied interrupt routine. It will be given - * two arguments: the UNmasked interrupt requests, and - * the currently enabled interrupts. - */ - - Push(Make_Unsigned_Fixnum(IntEnb)); - Push(Make_Unsigned_Fixnum(The_Int_Code)); - Push(Handler); - Push(STACK_FRAME_HEADER+2); - Pushed(); - IntEnb = New_Int_Enb; /* Turn off interrupts */ - New_Compiler_MemTop(); -} - - /******************/ - /* ERROR HANDLING */ - /******************/ - -/* It is assumed that any caller of the error code has already - * restored its state to a situation which will make it - * restartable if the error handler returns normally. As a - * result, the only work to be done on an error is to verify - * that there is an error handler, save the current continuation and - * create a new one if entered from Pop_Return rather than Eval, - * turn off interrupts, and call it with two arguments: Error-Code - * and Interrupt-Enables. - */ - -void -Err_Print (Micro_Error) - long Micro_Error; -{ switch (Micro_Error) - { -/* case ERR_BAD_ERROR_CODE: - printf("unknown error code.\n"); break; -*/ - case ERR_UNBOUND_VARIABLE: - printf("unbound variable.\n"); break; - case ERR_UNASSIGNED_VARIABLE: - printf("unassigned variable.\n"); break; - case ERR_INAPPLICABLE_OBJECT: - printf("Inapplicable operator.\n"); break; - case ERR_BAD_FRAME: - printf("bad environment frame.\n"); break; - case ERR_BROKEN_COMPILED_VARIABLE: - printf("compiled variable invalid.\n"); break; - case ERR_UNDEFINED_USER_TYPE: - printf("undefined type code.\n"); break; - case ERR_UNDEFINED_PRIMITIVE: - printf("undefined primitive.\n"); break; - case ERR_EXTERNAL_RETURN: - printf("error during 'external' primitive.\n"); break; - case ERR_EXECUTE_MANIFEST_VECTOR: - printf("attempt to EVAL a vector.\n"); break; - case ERR_WRONG_NUMBER_OF_ARGUMENTS: - printf("wrong number of arguments.\n"); break; - case ERR_ARG_1_WRONG_TYPE: - printf("type error argument 1.\n"); break; - case ERR_ARG_2_WRONG_TYPE: - printf("type error argument 2.\n"); break; - -/* Err_Print continues on the next page */ - -/* Err_Print, continued */ - - case ERR_ARG_3_WRONG_TYPE: - printf("type error argument 3.\n"); break; - case ERR_ARG_1_BAD_RANGE: - printf("range error argument 1.\n"); break; - case ERR_ARG_2_BAD_RANGE: - printf("range error, argument 2.\n"); break; - case ERR_ARG_3_BAD_RANGE: - printf("range error, argument 3.\n"); break; - case ERR_FASL_FILE_TOO_BIG: - printf("FASL file too large to load.\n"); break; - case ERR_FASL_FILE_BAD_DATA: - printf("No such file or not FASL format.\n"); break; - case ERR_IMPURIFY_OUT_OF_SPACE: - printf("Not enough room to impurify object.\n"); break; - case ERR_WRITE_INTO_PURE_SPACE: - printf("Write into pure area\n"); break; - case ERR_BAD_SET: - printf("Attempt to perform side-effect on 'self'.\n"); break; - case ERR_ARG_1_FAILED_COERCION: - printf("First argument couldn't be coerced.\n"); break; - case ERR_ARG_2_FAILED_COERCION: - printf("Second argument couldn't be coerced.\n"); break; - case ERR_OUT_OF_FILE_HANDLES: - printf("Too many open files.\n"); break; - default: - printf("Unknown error 0x%x occurred\n.", Micro_Error); - break; - } - return; -} - -void -Stack_Death () -{ fprintf(stderr, "\nWill_Push vs. Pushed inconsistency.\n"); - Microcode_Termination(TERM_BAD_STACK); -} - -/* Back_Out_Of_Primitive sets the registers up so that the backout - * mechanism in interpret.c will push the primitive number and - * an appropriate return code so that the primitive can be - * restarted. - */ - -#if (TC_PRIMITIVE == 0) || (TC_PRIMITIVE_EXTERNAL == 0) -#include "Error: Some primitive type is 0" -#endif - -void -Back_Out_Of_Primitive () -{ - long nargs; - Pointer expression = Fetch_Expression(); - - /* When primitives are called from compiled code, the type code may - * not be in the expression register. - */ - - if (Safe_Type_Code(expression) == 0) - { - expression = Make_Non_Pointer(TC_PRIMITIVE, expression); - Store_Expression(expression); - } - - /* Setup a continuation to return to compiled code if the primitive is - * restarted and completes successfully. - */ - - nargs = N_Args_Primitive(Get_Integer(expression)); - if (Type_Code(Stack_Ref(nargs)) == TC_RETURN_ADDRESS) - { - /* This clobbers the expression register. */ - compiler_apply_procedure(nargs); - Store_Expression(expression); - } - - /* When you come back to the primitive, the environment is - * irrelevant .... primitives run with no real environment. - * Similarly, the value register is meaningless. - */ - Store_Return(RC_REPEAT_PRIMITIVE); - Store_Env(Make_Non_Pointer(GLOBAL_ENV, END_OF_CHAIN)); - Val = NIL; -} - -/* Useful error procedures */ - -extern void - signal_error_from_primitive(), - signal_interrupt_from_primitive(), - error_wrong_type_arg_1(), - error_wrong_type_arg_2(), - error_wrong_type_arg_3(), - error_wrong_type_arg_4(), - error_wrong_type_arg_5(), - error_wrong_type_arg_6(), - error_wrong_type_arg_7(), - error_wrong_type_arg_8(), - error_wrong_type_arg_9(), - error_wrong_type_arg_10(), - error_bad_range_arg_1(), - error_bad_range_arg_2(), - error_bad_range_arg_3(), - error_bad_range_arg_4(), - error_bad_range_arg_5(), - error_bad_range_arg_6(), - error_bad_range_arg_7(), - error_bad_range_arg_8(), - error_bad_range_arg_9(), - error_bad_range_arg_10(), - error_external_return(); - -void -signal_error_from_primitive (error_code) - long error_code; -{ - Back_Out_Of_Primitive (); - longjmp (*Back_To_Eval, error_code); - /*NOTREACHED*/ -} - -void -signal_interrupt_from_primitive () -{ - Back_Out_Of_Primitive (); - longjmp (*Back_To_Eval, PRIM_INTERRUPT); - /*NOTREACHED*/ -} - -void -special_interrupt_from_primitive(local_mask) - int local_mask; -{ - Back_Out_Of_Primitive(); - Save_Cont(); - Store_Return(RC_RESTORE_INT_MASK); - Store_Expression(Make_Unsigned_Fixnum(IntEnb)); - IntEnb = (local_mask); - longjmp(*Back_To_Eval, PRIM_INTERRUPT); - /*NOTREACHED*/ -} - -void -error_wrong_type_arg_1 () -{ - signal_error_from_primitive (ERR_ARG_1_WRONG_TYPE); -} - -void -error_wrong_type_arg_2 () -{ - signal_error_from_primitive (ERR_ARG_2_WRONG_TYPE); -} - -void -error_wrong_type_arg_3 () -{ - signal_error_from_primitive (ERR_ARG_3_WRONG_TYPE); -} - -void -error_wrong_type_arg_4 () -{ - signal_error_from_primitive (ERR_ARG_4_WRONG_TYPE); -} - -void -error_wrong_type_arg_5 () -{ - signal_error_from_primitive (ERR_ARG_5_WRONG_TYPE); -} - -void -error_wrong_type_arg_6 () -{ - signal_error_from_primitive (ERR_ARG_6_WRONG_TYPE); -} - -void -error_wrong_type_arg_7 () -{ - signal_error_from_primitive (ERR_ARG_7_WRONG_TYPE); -} - -void -error_wrong_type_arg_8 () -{ - signal_error_from_primitive (ERR_ARG_8_WRONG_TYPE); -} - -void -error_wrong_type_arg_9 () -{ - signal_error_from_primitive (ERR_ARG_9_WRONG_TYPE); -} - -void -error_wrong_type_arg_10 () -{ - signal_error_from_primitive (ERR_ARG_10_WRONG_TYPE); -} - -void -error_bad_range_arg_1 () -{ - signal_error_from_primitive (ERR_ARG_1_BAD_RANGE); -} - -void -error_bad_range_arg_2 () -{ - signal_error_from_primitive (ERR_ARG_2_BAD_RANGE); -} - -void -error_bad_range_arg_3 () -{ - signal_error_from_primitive (ERR_ARG_3_BAD_RANGE); -} - -void -error_bad_range_arg_4 () -{ - signal_error_from_primitive (ERR_ARG_4_BAD_RANGE); -} - -void -error_bad_range_arg_5 () -{ - signal_error_from_primitive (ERR_ARG_5_BAD_RANGE); -} - -void -error_bad_range_arg_6 () -{ - signal_error_from_primitive (ERR_ARG_6_BAD_RANGE); -} - -void -error_bad_range_arg_7 () -{ - signal_error_from_primitive (ERR_ARG_7_BAD_RANGE); -} - -void -error_bad_range_arg_8 () -{ - signal_error_from_primitive (ERR_ARG_8_BAD_RANGE); -} - -void -error_bad_range_arg_9 () -{ - signal_error_from_primitive (ERR_ARG_9_BAD_RANGE); -} - -void -error_bad_range_arg_10 () -{ - signal_error_from_primitive (ERR_ARG_10_BAD_RANGE); -} - -void -error_external_return () -{ - signal_error_from_primitive (ERR_EXTERNAL_RETURN); -} - -#define define_integer_guarantee(procedure_name, wta, bra) \ -long \ -procedure_name (argument) \ - Pointer argument; \ -{ \ - if (! (fixnum_p (argument))) \ - wta (); \ - if (fixnum_negative_p (argument)) \ - bra (); \ - return (pointer_datum (argument)); \ -} - -define_integer_guarantee (guarantee_nonnegative_int_arg_1, - error_wrong_type_arg_1, - error_bad_range_arg_1) - -define_integer_guarantee (guarantee_nonnegative_int_arg_2, - error_wrong_type_arg_2, - error_bad_range_arg_2) - -define_integer_guarantee (guarantee_nonnegative_int_arg_3, - error_wrong_type_arg_3, - error_bad_range_arg_3) - -define_integer_guarantee (guarantee_nonnegative_int_arg_4, - error_wrong_type_arg_4, - error_bad_range_arg_4) - -define_integer_guarantee (guarantee_nonnegative_int_arg_5, - error_wrong_type_arg_5, - error_bad_range_arg_5) - -define_integer_guarantee (guarantee_nonnegative_int_arg_6, - error_wrong_type_arg_6, - error_bad_range_arg_6) - -define_integer_guarantee (guarantee_nonnegative_int_arg_7, - error_wrong_type_arg_7, - error_bad_range_arg_7) - -define_integer_guarantee (guarantee_nonnegative_int_arg_8, - error_wrong_type_arg_8, - error_bad_range_arg_8) - -define_integer_guarantee (guarantee_nonnegative_int_arg_9, - error_wrong_type_arg_9, - error_bad_range_arg_9) - -define_integer_guarantee (guarantee_nonnegative_int_arg_10, - error_wrong_type_arg_10, - error_bad_range_arg_10) - -#define define_index_guarantee(procedure_name, wta, bra) \ -long \ -procedure_name (argument, upper_limit) \ - Pointer argument, upper_limit; \ -{ \ - fast long index; \ - \ - if (! (fixnum_p (argument))) \ - wta (); \ - if (fixnum_negative_p (argument)) \ - bra (); \ - index = (pointer_datum (argument)); \ - if (index >= upper_limit) \ - bra (); \ - return (index); \ -} - -define_index_guarantee (guarantee_index_arg_1, - error_wrong_type_arg_1, - error_bad_range_arg_1) - -define_index_guarantee (guarantee_index_arg_2, - error_wrong_type_arg_2, - error_bad_range_arg_2) - -define_index_guarantee (guarantee_index_arg_3, - error_wrong_type_arg_3, - error_bad_range_arg_3) - -define_index_guarantee (guarantee_index_arg_4, - error_wrong_type_arg_4, - error_bad_range_arg_4) - -define_index_guarantee (guarantee_index_arg_5, - error_wrong_type_arg_5, - error_bad_range_arg_5) - -define_index_guarantee (guarantee_index_arg_6, - error_wrong_type_arg_6, - error_bad_range_arg_6) - -define_index_guarantee (guarantee_index_arg_7, - error_wrong_type_arg_7, - error_bad_range_arg_7) - -define_index_guarantee (guarantee_index_arg_8, - error_wrong_type_arg_8, - error_bad_range_arg_8) - -define_index_guarantee (guarantee_index_arg_9, - error_wrong_type_arg_9, - error_bad_range_arg_9) - -define_index_guarantee (guarantee_index_arg_10, - error_wrong_type_arg_10, - error_bad_range_arg_10) - -void -Do_Micro_Error (Err, From_Pop_Return) - long Err; - Boolean From_Pop_Return; -{ - Pointer Error_Vector, Handler; - - if (Consistency_Check) - { Err_Print(Err); - Print_Expression(Fetch_Expression(), "Expression was"); - printf("\nEnvironment 0x%x (#%o).\n", Fetch_Env(), Fetch_Env()); - Print_Return("Return code"); - printf( "\n"); - } - - Error_Exit_Hook(); - - if (Trace_On_Error) - { - printf( "\n**** Stack Trace ****\n\n"); - Back_Trace(); - } - -#ifdef ENABLE_DEBUGGING_TOOLS - { - int *From = &(local_circle[0]), *To = &(debug_circle[0]), i; - - for (i=0; i < local_nslots; i++) *To++ = *From++; - debug_nslots = local_nslots; - debug_slotno = local_slotno; - } -#endif - -/* Do_Micro_Error continues on the next page. */ - -/* Do_Micro_Error, continued */ - - if ((!Valid_Fixed_Obj_Vector()) || - (Type_Code((Error_Vector = - Get_Fixed_Obj_Slot(System_Error_Vector))) != - TC_VECTOR)) - { - fprintf(stderr, - "\nMicrocode Error: code = 0x%x; Bad error handlers vector.\n", - Err); - printf("\n**** Stack Trace ****\n\n"); - Back_Trace(); - Microcode_Termination(TERM_NO_ERROR_HANDLER, Err); - } - - if (Err >= Vector_Length(Error_Vector)) - { - if (Vector_Length(Error_Vector) == 0) - { - fprintf(stderr, - "\nMicrocode Error: code = 0x%x; Empty error handlers vector.\n", - Err); - printf("\n**** Stack Trace ****\n\n"); - Back_Trace(); - Microcode_Termination(TERM_NO_ERROR_HANDLER, Err); - } - Handler = User_Vector_Ref(Error_Vector, ERR_BAD_ERROR_CODE); - } - else - Handler = User_Vector_Ref(Error_Vector, Err); - - /* This can NOT be folded into the Will_Push below since we cannot - afford to have the Will_Push put down its own continuation. - There is guaranteed to be enough space for this one - continuation; in fact, the Will_Push here is really unneeded! - */ - - if (From_Pop_Return) - { - Will_Push(CONTINUATION_SIZE); - Save_Cont(); - Pushed(); - } - Will_Push(STACK_ENV_EXTRA_SLOTS+3+2*CONTINUATION_SIZE+HISTORY_SIZE+ - (From_Pop_Return ? 0 : 1)); - - if (From_Pop_Return) - Store_Expression(Val); - else - Push(Fetch_Env()); - - Store_Return((From_Pop_Return) ? - RC_POP_RETURN_ERROR : - RC_EVAL_ERROR); - Save_Cont(); - - /* Return from error handler will re-enable interrupts & restore history */ - - Stop_History(); - Store_Return(RC_RESTORE_INT_MASK); - Store_Expression(Make_Unsigned_Fixnum(IntEnb)); - Save_Cont(); - Push(Make_Unsigned_Fixnum(IntEnb)); /* Arg 2: Int. mask */ - Push(Make_Unsigned_Fixnum(Err)); /* Arg 1: Err. No */ - Push(Handler); /* Procedure: Handler */ - Push(STACK_FRAME_HEADER+2); - Pushed(); - - IntEnb = 0; /* Turn off interrupts */ - New_Compiler_MemTop(); -} - -/* Make a Scheme string with the characters in C_String. */ - -Pointer -C_String_To_Scheme_String (C_String) - fast char *C_String; -{ - fast char *Next; - fast long Length, Max_Length; - Pointer Result; - - Result = Make_Pointer( TC_CHARACTER_STRING, Free); - Next = (char *) Nth_Vector_Loc( Result, STRING_CHARS); - Max_Length = ((Space_Before_GC() - STRING_CHARS) * - sizeof( Pointer)); - if (C_String == NULL) - Length = 0; - else - for (Length = 0; - (*C_String != '\0') && (Length < Max_Length); - Length += 1) - *Next++ = *C_String++; - if (Length >= Max_Length) - Primitive_GC( MemTop - Free); - *Next = '\0'; - Free += (2 + ((Length + sizeof( Pointer)) / sizeof( Pointer))); - Vector_Set(Result, STRING_LENGTH, Length); - Vector_Set(Result, STRING_HEADER, - Make_Non_Pointer( TC_MANIFEST_NM_VECTOR, - ((Free - Get_Pointer( Result)) - 1))); - return Result; -} - -Boolean -Open_File (Name, Mode_String, Handle) - Pointer Name; - char *Mode_String; - FILE **Handle; -{ - *Handle = - ((FILE *) - OS_file_open( Scheme_String_To_C_String( Name), (*Mode_String == 'w'))); - return ((Boolean) (*Handle != NULL)); -} - -void -Close_File (stream) - FILE *stream; -{ - extern Boolean OS_file_close(); - - if (!OS_file_close( stream)) - Primitive_Error( ERR_EXTERNAL_RETURN); - return; -} - -Pointer * -Make_Dummy_History () -{ - Pointer *History_Rib = Free; - Pointer *Result; - - Free[RIB_EXP] = NIL; - Free[RIB_ENV] = NIL; - Free[RIB_NEXT_REDUCTION] = - Make_Pointer(TC_HUNK3, History_Rib); - Free += 3; - Result = Free; - Free[HIST_RIB] = Make_Pointer(TC_HUNK3, History_Rib); - Free[HIST_NEXT_SUBPROBLEM] = - Make_Pointer(TC_HUNK3, Result); - Free[HIST_PREV_SUBPROBLEM] = - Make_Pointer(TC_HUNK3, Result); - Free += 3; - return Result; -} - -/* The entire trick to history is right here: it is either copied or - reused when restored. Initially, Stop_History marks the stack so - that the history will merely be popped and reused. On a catch, - however, the return code is changed to force the history to be - copied instead. Thus, histories saved as part of a control point - are not side-effected in the history collection process. -*/ - -void -Stop_History () -{ - Pointer Saved_Expression = Fetch_Expression(); - long Saved_Return_Code = Fetch_Return(); - -Will_Push(HISTORY_SIZE); - Save_History(RC_RESTORE_DONT_COPY_HISTORY); -Pushed(); - Prev_Restore_History_Stacklet = NULL; - Prev_Restore_History_Offset = ((Get_End_Of_Stacklet() - Stack_Pointer) + - CONTINUATION_RETURN_CODE); - Store_Expression(Saved_Expression); - Store_Return(Saved_Return_Code); - return; -} - -Pointer * -Copy_Rib (Orig_Rib) - Pointer *Orig_Rib; -{ - Pointer *Result, *This_Rib; - - for (This_Rib=NULL, Result=Free; - (This_Rib != Orig_Rib) && (!GC_Check(0)); - This_Rib = Get_Pointer(This_Rib[RIB_NEXT_REDUCTION])) - { if (This_Rib==NULL) This_Rib = Orig_Rib; - Free[RIB_EXP] = This_Rib[RIB_EXP]; - Free[RIB_ENV] = This_Rib[RIB_ENV]; - Free[RIB_NEXT_REDUCTION] = Make_Pointer(TC_HUNK3, Free+3); - if (Dangerous(This_Rib[RIB_MARK])) Free[RIB_MARK] |= DANGER_BIT; - Free += 3; - } - Store_Address((Free-3)[RIB_NEXT_REDUCTION], C_To_Scheme(Result)); - return Result; -} - -/* Restore_History pops a history object off the stack and - makes a COPY of it the current history collection object. - This is called only from the RC_RESTORE_HISTORY case in - interpret.c . -*/ - -Boolean -Restore_History (Hist_Obj) - Pointer Hist_Obj; -{ - Pointer *New_History, *Next_Vertebra, *Prev_Vertebra, - *Orig_Vertebra; - - if (Consistency_Check) - if (Type_Code(Hist_Obj) != TC_HUNK3) - { printf("Bad history to restore.\n"); - Microcode_Termination(TERM_EXIT); - } - Orig_Vertebra = Get_Pointer(Hist_Obj); - for (Next_Vertebra=NULL, Prev_Vertebra=NULL; - Next_Vertebra != Orig_Vertebra; - Next_Vertebra = - Get_Pointer(Next_Vertebra[HIST_NEXT_SUBPROBLEM])) - { Pointer *New_Rib; - if (Prev_Vertebra==NULL) Next_Vertebra = Orig_Vertebra; - New_Rib = Copy_Rib(Get_Pointer(Next_Vertebra[HIST_RIB])); - if (Prev_Vertebra==NULL) New_History = Free; - else Prev_Vertebra[HIST_NEXT_SUBPROBLEM] = - Make_Pointer(TC_HUNK3, Free); - Free[HIST_RIB] = Make_Pointer(TC_HUNK3, New_Rib); - Free[HIST_NEXT_SUBPROBLEM] = NIL; - Free[HIST_PREV_SUBPROBLEM] = - Make_Pointer(TC_HUNK3, Prev_Vertebra); - if (Dangerous(Next_Vertebra[HIST_MARK])) - Free[HIST_MARK] |= DANGER_BIT; - Prev_Vertebra = Free; - Free += 3; - if (GC_Check(0)) return false; - } - Store_Address(New_History[HIST_PREV_SUBPROBLEM], C_To_Scheme(Free-3)); - Prev_Vertebra[HIST_NEXT_SUBPROBLEM] = - Make_Pointer(TC_HUNK3, New_History); - if (Dangerous(Orig_Vertebra[HIST_MARK])) - Prev_Vertebra[HIST_MARK] |= DANGER_BIT; - History = New_History; - return true; -} - -CRLF () -{ - printf( "\n"); -} - -/* If a debugging version of the interpreter is made, then this - * procedure is called to actually invoke a primitive. When a - * 'production' version is made, all of the consistency checks are - * omitted and a macro from DEFAULT.H is used to directly code the - * call to the primitive function. This is only used in INTERPRET.C. - */ - -#ifdef ENABLE_DEBUGGING_TOOLS -Pointer -Apply_Primitive (Primitive_Number) - long Primitive_Number; -{ - Pointer Result, *Saved_Stack; - int NArgs; - - if (Primitive_Number > MAX_PRIMITIVE) - { - Primitive_Error(ERR_UNDEFINED_PRIMITIVE); - } - if (Primitive_Debug) - { - Print_Primitive(Primitive_Number); - } - NArgs = N_Args_Primitive(Primitive_Number); - Saved_Stack = Stack_Pointer; - Result = Internal_Apply_Primitive(Primitive_Number); - if (Saved_Stack != Stack_Pointer) - { - Print_Expression(Make_Non_Pointer(TC_PRIMITIVE, Primitive_Number), - "Stack bad after "); - fprintf(stderr, - "\nStack was 0x%x, now 0x%x, #args=%d.\n", - Saved_Stack, Stack_Pointer, NArgs); - Microcode_Termination(TERM_EXIT); - } - if (Primitive_Debug) - { - Print_Expression(Result, "Primitive Result"); - fprintf(stderr, "\n"); - } - return Result; -} -#endif - -Pointer -Allocate_Float (F) - double F; -{ - Pointer Result; - - Align_Float(Free); - Result = Make_Pointer(TC_BIG_FLONUM, Free); - *Free = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, FLONUM_SIZE); - Get_Float(C_To_Scheme(Free)) = F; - Primitive_GC_If_Needed(FLONUM_SIZE+1); - Free += FLONUM_SIZE+1; - return Result; -} - -#ifdef USE_STACKLETS - /******************/ - /* STACKLETS */ - /******************/ - -void -Allocate_New_Stacklet (N) - long N; -{ - Pointer Old_Expression, *Old_Stacklet, Old_Return; - - Old_Stacklet = Current_Stacklet; - Terminate_Old_Stacklet(); - if ((Free_Stacklets == NULL) || - ((N+STACKLET_SLACK) > Get_Integer(Free_Stacklets[STACKLET_LENGTH]))) - { long size = New_Stacklet_Size(N); - /* Room is set aside for the two header bytes of a stacklet plus - * the two bytes required for the RC_JOIN_STACKLETS frame. - */ - if (GC_Check(size)) - { Request_GC(size); - if (Free+size >= Heap_Top) - Microcode_Termination(TERM_STACK_OVERFLOW); - } - Free[STACKLET_LENGTH] = Make_Non_Pointer(TC_MANIFEST_VECTOR, size-1); - Stack_Guard = &(Free[STACKLET_HEADER_SIZE]); - Free += size; - Stack_Pointer = Free; - } - else /* Grab first one on the free list */ - { Pointer *New_Stacklet = Free_Stacklets; - Free_Stacklets = ((Pointer *) Free_Stacklets[STACKLET_FREE_LIST_LINK]); - Stack_Pointer = - &New_Stacklet[1 + Get_Integer(New_Stacklet[STACKLET_LENGTH])]; - Stack_Guard = &New_Stacklet[STACKLET_HEADER_SIZE]; - } - Old_Expression = Fetch_Expression(); - Old_Return = Fetch_Return(); - Store_Expression(Make_Pointer(TC_CONTROL_POINT, Old_Stacklet)); - Store_Return(RC_JOIN_STACKLETS); -/* Will_Push omitted because size calculation includes enough room. */ - Save_Cont(); - Store_Expression(Old_Expression); - Store_Return(Old_Return); - return; -} -#endif - -/* Dynamic Winder support code */ - -Pointer -Find_State_Space (State_Point) - Pointer State_Point; -{ - long How_Far = Get_Integer(Fast_Vector_Ref(State_Point, - STATE_POINT_DISTANCE_TO_ROOT)); - long i; - fast Pointer Point = State_Point; - - for (i=0; i <= How_Far; i++) - { -#ifdef ENABLE_DEBUGGING_TOOLS - if (Point == NIL) - { printf("\nState_Point 0x%x wrong: count was %d, NIL at %d\n", - State_Point, How_Far, i); - Microcode_Termination(TERM_EXIT); - } -#endif - Point = Fast_Vector_Ref(Point, STATE_POINT_NEARER_POINT); - } - return Point; -} - -/* ASSUMPTION: State points, which are created only by the interpreter, - never contain FUTUREs except possibly as the thunks (which are handled - by the apply code). - - Furthermore: - (1) On a single processor, things should work with multiple state - spaces. The microcode variable Current_State_Point tracks - the location in the "boot" space (i.e. the one whose space is - NIL) and the state spaces themselves (roots of the space - trees) track the other spaces. - (2) On multi-processors, multiple spaces DO NOT work. Only the - initial space (NIL) is tracked by the microcode (it is - swapped on every task switch), but no association with trees - is kept. This will work since the initial tree has no space - at the root, indicating that the microcode variable rather - than the state space contains the current state space - location. -*/ - -void -Translate_To_Point (Target) - Pointer Target; -{ - Pointer State_Space = Find_State_Space(Target); - Pointer Current_Location, *Path = Free; - fast Pointer Path_Point, *Path_Ptr; - long Distance, Merge_Depth, From_Depth, i; - - guarantee_state_point(); - Distance = - Get_Integer(Fast_Vector_Ref(Target, STATE_POINT_DISTANCE_TO_ROOT)); - if (State_Space == NIL) - Current_Location = Current_State_Point; - else - Current_Location = Vector_Ref(State_Space, STATE_SPACE_NEAREST_POINT); - if (Target == Current_Location) - longjmp(*Back_To_Eval, PRIM_POP_RETURN); - for (Path_Ptr=(&(Path[Distance])), Path_Point=Target, i=0; - i <= Distance; - i++, Path_Point=Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT)) - *Path_Ptr-- = Path_Point; - From_Depth = - Get_Integer(Fast_Vector_Ref(Current_Location, STATE_POINT_DISTANCE_TO_ROOT)); - for (Path_Point=Current_Location, Merge_Depth = From_Depth; - Merge_Depth > Distance; - Merge_Depth--) - Path_Point = Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT); - for (Path_Ptr=(&(Path[Merge_Depth])); Merge_Depth >= 0; - Merge_Depth--, Path_Ptr--, - Path_Point=Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT)) - if (*Path_Ptr == Path_Point) - break; -#ifdef ENABLE_DEBUGGING_TOOLS - if (Merge_Depth < 0) - { - fprintf(stderr, "\nMerge_Depth went negative: %d\n", Merge_Depth); - Microcode_Termination(TERM_EXIT); - } -#endif - Will_Push(2*CONTINUATION_SIZE + 4); - Store_Return(RC_RESTORE_INT_MASK); - Store_Expression(Make_Unsigned_Fixnum(IntEnb)); - Save_Cont(); - Push(Make_Unsigned_Fixnum((Distance-Merge_Depth))); - Push(Target); - Push(Make_Unsigned_Fixnum((From_Depth-Merge_Depth))); - Push(Current_Location); - Store_Expression(State_Space); - Store_Return(RC_MOVE_TO_ADJACENT_POINT); - Save_Cont(); - Pushed(); - IntEnb &= (INT_GC<<1) - 1; /* Disable lower than GC level */ - longjmp(*Back_To_Eval, PRIM_POP_RETURN); - /*NOTREACHED*/ -} diff --git a/v7/src/microcode/vector.c b/v7/src/microcode/vector.c deleted file mode 100644 index dec6b41b0..000000000 --- a/v7/src/microcode/vector.c +++ /dev/null @@ -1,280 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/vector.c,v 9.22 1987/04/16 02:32:44 jinx Exp $ - * - * This file contains procedures for handling vectors and conversion - * back and forth to lists. - */ - -#include "scheme.h" -#include "primitive.h" - - /*********************/ - /* VECTORS <-> LISTS */ - /*********************/ - -/* Subvector_To_List is a utility routine used by both - SUBVECTOR_TO_LIST and SYS_SUBVECTOR_TO_LIST. It copies the entries - in a vector (first argument) starting with the entry specified by - argument 2 and ending at the one specified by argument 3. The copy - includes the starting entry but does NOT include the ending entry. - Thus the entire vector is converted to a list by setting argument 2 - to 0 and argument 3 to the length of the vector. -*/ - -Pointer Subvector_To_List() -{ Pointer *From, Result; - long Length, Start, End, Count, i; - Primitive_3_Args(); - if (Type_Code(Arg2) != TC_FIXNUM) Primitive_Error(ERR_ARG_2_WRONG_TYPE); - if (Type_Code(Arg3) != TC_FIXNUM) Primitive_Error(ERR_ARG_3_WRONG_TYPE); - if (Type_Code(Vector_Ref(Arg1, VECTOR_TYPE)) != TC_MANIFEST_VECTOR) - Primitive_Error(ERR_ARG_1_WRONG_TYPE); - Length = Vector_Length(Arg1); - Start = Get_Integer(Arg2); - End = Get_Integer(Arg3); - if (End > Length) Primitive_Error(ERR_ARG_3_BAD_RANGE); - if (Start > End) Primitive_Error(ERR_ARG_3_BAD_RANGE); - if (Start == End) return NIL; - Primitive_GC_If_Needed(2*(End-Start)); - Result = Make_Pointer(TC_LIST, Free); - From = Nth_Vector_Loc(Arg1, Start+1); - Count = End-Start; - for (i=0; i < Count; i++) - { *Free++ = Fetch(*From++); - *Free = Make_Pointer(TC_LIST, Free+1); - Free += 1; - } - Free[-1] = NIL; - return Result; -} - -/* Called by the primitives LIST_TO_VECTOR and SYS_LIST_TO_VECTOR. - This utility routine converts a list into a vector. -*/ - -Pointer L_To_V(Result_Type, List) -long Result_Type; -fast Pointer List; -{ Pointer *Orig_Free; - long Count; - Touch_In_Primitive(List, List); - Count = 0; - Orig_Free = Free++; - while (Type_Code(List) == TC_LIST) - { Primitive_GC_If_Needed(0); - Count += 1; - *Free++ = Vector_Ref(List, CONS_CAR); - Touch_In_Primitive(Vector_Ref(List, CONS_CDR), List); - } - if (List != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE); - *Orig_Free = Make_Non_Pointer(TC_MANIFEST_VECTOR, Count); - return Make_Pointer(Result_Type, Orig_Free); -} - -/* (LIST->VECTOR LIST) - Returns a vector made from the items in LIST. -*/ - -Built_In_Primitive(Prim_List_To_Vector, 1, "LIST->VECTOR", 0x7C) -{ - Primitive_1_Arg(); - - return L_To_V(TC_VECTOR, Arg1); -} - -/* (SUBVECTOR->LIST VECTOR FROM TO) - Returns a list of the FROMth through TO-1st items in the vector. - Thus (SUBVECTOR_TO_LIST V 0 (VECTOR_LENGTH V)) returns a list of - all the items in V. -*/ -Built_In_Primitive(Prim_Subvector_To_List, 3, "SUBVECTOR->LIST", 0x7D) -{ - Primitive_3_Args(); - - Arg_1_Type(TC_VECTOR); - return Subvector_To_List(); -} - -/* (VECTOR_CONS LENGTH CONTENTS) - Create a new vector to hold LENGTH entries, all of which are - initialized to CONTENTS. -*/ -Built_In_Primitive(Prim_Vector_Cons, 2, "VECTOR-CONS", 0x2C) -{ - long Length, i; - Primitive_2_Args(); - - Arg_1_Type(TC_FIXNUM); - Length = Get_Integer(Arg1); - Primitive_GC_If_Needed(Length+1); - *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Length); - for (i = 0; i < Length; i++) - *Free++ = Arg2; - return Make_Pointer(TC_VECTOR, (Free - (Length + 1))); -} - -/* (VECTOR-REF VECTOR OFFSET) - Return the OFFSETth entry in VECTOR. Entries are numbered from 0. -*/ -Built_In_Primitive(Prim_Vector_Ref, 2, "VECTOR-REF", 0x2E) -{ - long Offset; - Primitive_2_Args(); - - Arg_1_Type(TC_VECTOR); - Arg_2_Type(TC_FIXNUM); - Range_Check(Offset, Arg2, - 0, (Vector_Length(Arg1) - 1), ERR_ARG_2_BAD_RANGE); - return User_Vector_Ref(Arg1, Offset); -} - -/* (VECTOR-SET! VECTOR OFFSET VALUE) - Store VALUE as the OFFSETth entry in VECTOR. Entries are - numbered from 0. Returns (bad style to rely on this) the - previous value of the entry. -*/ -Built_In_Primitive(Prim_Vector_Set, 3, "VECTOR-SET!", 0x30) -{ - long Offset; - Primitive_3_Args(); - - Arg_1_Type(TC_VECTOR); - Arg_2_Type(TC_FIXNUM); - Range_Check(Offset, Arg2, - 0, (Vector_Length(Arg1) - 1), ERR_ARG_2_BAD_RANGE); - Side_Effect_Impurify(Arg1, Arg3); - return Swap_Pointers(Nth_Vector_Loc(Arg1, (Offset + 1)), Arg3); -} - -/* (VECTOR-LENGTH VECTOR) - Returns the number of entries in VECTOR. -*/ -Built_In_Primitive(Prim_Vector_Size, 1, "VECTOR-LENGTH", 0x2D) -{ - Primitive_1_Arg(); - - Arg_1_Type(TC_VECTOR); - return Make_Unsigned_Fixnum(Vector_Length(Arg1)); -} - -/* (SYSTEM-LIST-TO-VECTOR GC-LIST) - Same as LIST_TO_VECTOR except that the resulting vector has the - specified type code. This can be used, for example, to create - an environment from a list of values. -*/ -Built_In_Primitive(Prim_Sys_List_To_Vector, 2, "SYSTEM-LIST-TO-VECTOR", 0x97) -{ - long Type; - Primitive_2_Args(); - - Arg_1_Type(TC_FIXNUM); - Range_Check(Type, Arg1, 0, MAX_TYPE_CODE, ERR_ARG_1_BAD_RANGE); - if (GC_Type_Code(Type) == GC_Vector) - return L_To_V(Type, Arg2); - else - Primitive_Error(ERR_ARG_1_BAD_RANGE); - /*NOTREACHED*/ -} - -/* (SYSTEM-SUBVECTOR-TO-LIST GC-VECTOR FROM TO) - Same as SUBVECTOR->LIST, but accepts anything with a GC type - of VECTOR. -*/ -Built_In_Primitive(Prim_Sys_Subvector_To_List, 3, - "SYSTEM-SUBVECTOR-TO-LIST", 0x98) -{ - Primitive_3_Args(); - Touch_In_Primitive(Arg1, Arg1); - - Arg_1_GC_Type(GC_Vector); - return Subvector_To_List(); -} - -/* (SYSTEM-VECTOR? OBJECT) - Returns #!TRUE if OBJECT is of GC type VECTOR. Otherwise - returns NIL. -*/ -Built_In_Primitive(Prim_Sys_Vector, 1, "SYSTEM-VECTOR?", 0x99) -{ - Primitive_1_Arg(); - - Touch_In_Primitive(Arg1, Arg1); - if (GC_Type_Vector(Arg1)) - return TRUTH; - else - return NIL; -} - -/* (SYSTEM-VECTOR-REF GC-VECTOR OFFSET) - Like VECTOR_REF, but for anything of GC type VECTOR. -*/ -Built_In_Primitive(Prim_Sys_Vector_Ref, 2, "SYSTEM-VECTOR-REF", 0x9A) -{ - long Offset; - Primitive_2_Args(); - - Touch_In_Primitive(Arg1, Arg1); - Arg_1_GC_Type(GC_Vector); - Range_Check(Offset, Arg2, 0, - (Vector_Length(Arg1) - 1), ERR_ARG_2_BAD_RANGE); - return User_Vector_Ref(Arg1, Offset); -} - -/* (SYSTEM-VECTOR-SET! GC-VECTOR OFFSET VALUE) - Like VECTOR_SET, but for anything of GC type VECTOR. -*/ -Built_In_Primitive(Prim_Sys_Vec_Set, 3, "SYSTEM-VECTOR-SET!", 0x9B) -{ - long Offset; - Primitive_3_Args(); - - Touch_In_Primitive(Arg1, Arg1); - Arg_1_GC_Type(GC_Vector); - Range_Check(Offset, Arg2, 0, - Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE); - Side_Effect_Impurify(Arg1, Arg3); - return Swap_Pointers(Nth_Vector_Loc(Arg1, (Offset + 1)), Arg3); -} - -/* (SYSTEM-VECTOR-SIZE GC-VECTOR) - Like VECTOR_SIZE, but for anything of GC type VECTOR. -*/ -Built_In_Primitive(Prim_Sys_Vec_Size, 1, "SYSTEM-VECTOR-SIZE", 0xAE) -{ - Primitive_1_Arg(); - - Touch_In_Primitive(Arg1, Arg1); - Arg_1_GC_Type(GC_Vector); - return Make_Unsigned_Fixnum(Vector_Length(Arg1)); -} diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h deleted file mode 100644 index b38883433..000000000 --- a/v7/src/microcode/version.h +++ /dev/null @@ -1,54 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 9.41 1987/04/17 04:03:23 cph Exp $ - -This file contains version information for the microcode. */ - -/* Scheme system release version */ - -#ifndef RELEASE -#define RELEASE "5.0.20" -#endif - -/* Microcode release version */ - -#ifndef VERSION -#define VERSION 9 -#endif -#ifndef SUBVERSION -#define SUBVERSION 41 -#endif - -#ifndef UCODE_TABLES_FILENAME -#define UCODE_TABLES_FILENAME "utabmd.bin" -#endif diff --git a/v7/src/microcode/winder.h b/v7/src/microcode/winder.h deleted file mode 100644 index 267ebf69a..000000000 --- a/v7/src/microcode/winder.h +++ /dev/null @@ -1,51 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/winder.h,v 9.22 1987/04/16 02:33:24 jinx Rel $ - - Header file for dynamic winder. - -*/ - -#ifdef butterfly - -#define guarantee_state_point() \ -{ \ - if (Current_State_Point == NIL) \ - Current_State_Point = Get_Fixed_Obj_Slot( State_Space_Root); \ -} - -#else - -#define guarantee_state_point() - -#endif diff --git a/v7/src/microcode/wsize.c b/v7/src/microcode/wsize.c deleted file mode 100644 index 4ea52a605..000000000 --- a/v7/src/microcode/wsize.c +++ /dev/null @@ -1,138 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/wsize.c,v 9.21 1987/01/22 14:14:27 jinx Exp $ */ - -#include -#include -#include - -extern int errno; -extern char *malloc(); -extern free(); - -/* Some machines do not set ERANGE by default. */ -/* This attempts to fix this. */ - -#ifdef celerity -#define hack_signal -#endif - -#ifdef hack_signal -#define setup_error() signal(SIGFPE, range_error) - -range_error() -{ setup_error(); - errno = ERANGE; -} -#else -#define setup_error() -#endif - - -#define ARR_SIZE 20000 -#define MEM_SIZE 400000 - -/* Force program data to be relatively large. */ - -static long dummy[ARR_SIZE]; - -/* Note: comments are printed in a weird way because some - C compilers eliminate them even from strings. -*/ - -main() -{ double accum, delta; - int count, expt_size, char_size, mant_size; - unsigned long to_be_shifted; - unsigned bogus; - char *temp; - - setup_error(); - for(bogus = ((unsigned) -1), count = 0; - bogus != 0; - count += 1) - bogus >>= 1; - - char_size = count/(sizeof(unsigned)); - temp = malloc(MEM_SIZE*sizeof(long)); - if (temp == NULL) - printf("/%c Cannot allocate %d Pointers. %c/\n", - '*', MEM_SIZE, '*'); - else count = free(temp); - - if (((unsigned long) temp) < (1 << ((char_size*sizeof(long))-8))) - printf("#define Heap_In_Low_Memory\n"); - else - printf("/%c Heap is not in Low Memory. %c/\n", '*', '*'); - - to_be_shifted = -1; - if ((to_be_shifted >> 1) != to_be_shifted) - printf("#define UNSIGNED_SHIFT\n"); - else - printf("/%c unsigned longs use arithmetic shifting. %c/\n", - '*', '*'); - - printf("#define CHAR_SIZE %d\n", - char_size); - - printf("#define USHORT_SIZE %d\n", - (sizeof(unsigned short) * char_size)); - - printf("#define ULONG_SIZE %d\n", - (sizeof(unsigned long) * char_size)); - - printf("/%c Flonum (double) size is %d bits. %c/\n", - '*', (char_size*sizeof(double)), '*'); - - for(mant_size = 0, accum = 1.0, delta = 0.5; - ((accum + delta) != accum); - accum = accum + delta, - delta /= 2.0, - mant_size += 1) ; - - for(errno = 0, expt_size = 0, bogus = 1; - errno != ERANGE; - expt_size += 1, bogus <<= 1) - accum = pow(2.0, ((double) bogus)); - - expt_size -= 1; - - printf("#define FLONUM_EXPT_SIZE %d\n", expt_size); - printf("#define FLONUM_MANTISSA_BITS %d\n", mant_size); - printf("#define MAX_FLONUM_EXPONENT %d\n", ((1 << expt_size) - 1)); - printf("/%c Representation %s hidden bit. %c/\n", '*', - (((2+expt_size+mant_size) > (char_size*sizeof(double))) ? - "uses" : - "does not use"), '*'); - return; -} diff --git a/v7/src/microcode/xdebug.c b/v7/src/microcode/xdebug.c deleted file mode 100644 index 1008513b3..000000000 --- a/v7/src/microcode/xdebug.c +++ /dev/null @@ -1,227 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/xdebug.c,v 9.21 1987/01/22 14:37:28 jinx Rel $ - * - * This file contains primitives to debug the memory management in the - * Scheme system. - * - */ - -#include "scheme.h" -#include "primitive.h" - -/* New debugging utilities */ - -#define FULL_EQ 0 -#define SAFE_EQ 1 -#define ADDRESS_EQ 2 -#define DATUM_EQ 3 - -#define SAFE_MASK (~DANGER_BIT) - -static Pointer *Find_Occurrence(From, To, What, Mode) -fast Pointer *From, *To; -Pointer What; -int Mode; -{ fast Pointer Obj; - switch (Mode) - { default: - case FULL_EQ: - { Obj = What; - for (; From < To; From++) - if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR) - From += Get_Integer(*From); - else if (*From == Obj) return From; - return To; - } - case SAFE_EQ: - { Obj = (What & SAFE_MASK); - for (; From < To; From++) - if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR) - From += Get_Integer(*From); - else if (((*From) & SAFE_MASK) == Obj) return From; - return To; - } - case ADDRESS_EQ: - { Obj = Datum(What); - for (; From < To; From++) - if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR) - From += Get_Integer(*From); - else if ((Datum(*From) == Obj) && - (!(GC_Type_Non_Pointer(*From)))) - return From; - return To; - } - case DATUM_EQ: - { Obj = Datum(What); - for (; From < To; From++) - if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR) - From += Get_Integer(*From); - else if (Datum(*From) == Obj) return From; - return To; - } - } -} - -static long Find_In_Area(Name, From, To, Obj, Mode, print_p, store_p) -char *Name; -Pointer *From, *To, Obj; -int Mode; -Boolean print_p, store_p; -{ fast Pointer *Where; - fast long occurrences = 0; - if (print_p) printf(" Looking in %s:\n", Name); - Where = From-1; - while ((Where = Find_Occurrence(Where+1, To, Obj, Mode)) < To) - { occurrences += 1; - if (print_p) -#ifndef b32 - printf("Location = 0x%x; Contents = 0x%x\n", - ((long) Where), ((long) (*Where))); -#else - printf("Location = 0x%08x; Contents = 0x%08x\n", - ((long) Where), ((long) (*Where))); -#endif - if (store_p) - /* Note that Make_Pointer (vs. Make_Non_Pointer) is correct here!! */ - *Free++ = Make_Pointer(TC_ADDRESS, Where); - } - return occurrences; -} - -#define PRINT_P 1 -#define STORE_P 2 - -Pointer Find_Who_Points(Obj, Find_Mode, Collect_Mode) -Pointer Obj; -int Find_Mode, Collect_Mode; -{ long n = 0; - Pointer *Saved_Free = Free; - Boolean print_p = (Collect_Mode & PRINT_P); - Boolean store_p = (Collect_Mode & STORE_P); - /* No overflow check done. Hopefully referenced few times, or invoked before - to find the count and insure that there is enough space. */ - if (store_p) Free += 1; - if (print_p) - { putchar('\n'); -#ifndef b32 - printf("*** Looking for Obj = 0x%x; Find_Mode = %2d ***\n", - Obj, Find_Mode); -#else - printf("*** Looking for Obj = 0x%08x; Find_Mode = %2d ***\n", - Obj, Find_Mode); -#endif - } - n += Find_In_Area("Constant Space", - Constant_Space, Free_Constant, Obj, - Find_Mode, print_p, store_p); - n += Find_In_Area("the Heap", - Heap_Bottom, Saved_Free, Obj, - Find_Mode, print_p, store_p); -#ifndef USE_STACKLETS - n += Find_In_Area("the Stack", - Stack_Pointer, Stack_Top, Obj, - Find_Mode, print_p, store_p); -#endif - if (print_p) printf("Done.\n"); - if (store_p) - { *Saved_Free = Make_Non_Pointer(TC_MANIFEST_VECTOR, n); - return Make_Pointer(TC_VECTOR, Saved_Free); - } - else return Make_Non_Pointer(TC_FIXNUM, n); -} - -Print_Memory(Where, How_Many) -Pointer *Where; -long How_Many; -{ fast Pointer *End = &Where[How_Many]; -#ifndef b32 - printf("\n*** Memory from 0x%x to 0x%x (excluded) ***\n", Where, End); - while (Where < End) printf("0x%x\n", *Where++); -#else - printf("\n*** Memory from 0x%08x to 0x%08x (excluded) ***\n", Where, End); - while (Where < End) printf("0x%08x\n", *Where++); -#endif - printf("Done.\n"); - return; -} - -/* Primitives to give scheme a handle on utilities from DEBUG.C */ - -Define_Primitive(Prim_Show_Pure, 0, "SHOW-PURE") -{ printf("\n*** Constant & Pure Space: ***\n"); - Show_Pure(); - return TRUTH; -} - -Define_Primitive(Prim_Show_Env, 1, "SHOW-ENV") -{ Primitive_1_Arg(); - printf("\n*** Environment = 0x%x ***\n", Arg1); - Show_Env(Arg1); - return TRUTH; -} - -Define_Primitive(Prim_Stack_Trace, 0, "STACK-TRACE") -{ Primitive_0_Args(); - printf("\n*** Back Trace: ***\n"); - Back_Trace(); - return TRUTH; -} - -Define_Primitive(Prim_Find_Symbol, 1, "FIND-SYMBOL") -{ Primitive_1_Arg(); - Find_Symbol(); - return TRUTH; -} - -/* Primitives to give scheme a handle on utilities on this file. */ - -Define_Primitive(Prim_Debug_Flags, 0, "DEBUG-FLAGS") -{ Handle_Debug_Flags(); - return TRUTH; -} - -Define_Primitive(Prim_Find_Who_Points, 3, "FIND-WHO-POINTS") -{ Primitive_3_Args(); - return Find_Who_Points(Arg1, Get_Integer(Arg2), Get_Integer(Arg3)); -} - -Define_Primitive(Prim_Print_Memory, 2, "PRINT-MEMORY") -{ Pointer *Base; - Primitive_2_Args(); - if (GC_Type_Non_Pointer(Arg1)) - Base = ((Pointer *) Datum(Arg1)); - else Base = Get_Pointer(Arg1); - Print_Memory(Base, Get_Integer(Arg2)); - return TRUTH; -} diff --git a/v7/src/microcode/zones.h b/v7/src/microcode/zones.h deleted file mode 100644 index b84708a08..000000000 --- a/v7/src/microcode/zones.h +++ /dev/null @@ -1,87 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/zones.h,v 9.21 1987/01/22 14:37:35 jinx Exp $ - * - * Metering stuff. - * We break all times into time zones suitable for external analysis. - * Primitives may be included for accessing this information if desired - * by supplying additional files. - */ - -#ifdef METERING -extern long New_Time, Old_Time, Time_Meters[], Current_Zone; - -#ifdef ENABLE_DEBUGGING_TOOLS -#define Set_Time_Zone(Zone) \ -{ New_Time = Sys_Clock();\ - Time_Meters[Current_Zone] += New_Time-Old_Time;\ - Old_Time = New_Time;\ - Current_Zone = Zone;\ -} -#else -#define Set_Time_Zone(Zone) Current_Zone = Zone; -#endif - -#define Save_Time_Zone(Zone) Saved_Zone = Current_Zone; Set_Time_Zone(Zone); -#define Restore_Time_Zone() Set_Time_Zone(Saved_Zone); -#else -#define Set_Time_Zone(Zone) -#define Save_Time_Zone(Zone) -#define Restore_Time_Zone() -#endif - -#define Zone_Working 0 -#define Zone_GetWork 1 -#define Zone_TTY_IO 2 -#define Zone_Disk_IO 3 -#define Zone_Purify 4 -#define Zone_GCLoop 5 -#define Zone_Global_Int 6 -#define Zone_Store_Lock 7 -#define Zone_Math 8 -#define Zone_GCIdle 9 -#define Zone_Lookup 10 - -/* For finding out about lock contention - 1/19/87 - sas */ - -#define Zone_Count_Locks 11 -#define Zone_Count_Lock_0 12 -#define Zone_Count_Lock_1 13 -#define Zone_Count_Lock_2 14 -#define Zone_Count_Lock_3 15 -#define Zone_Count_Lock_4 16 -#define Zone_Count_Lock_5 17 -#define Zone_Count_Lock_6 18 -#define Zone_Count_Lock_N 19 - -#define Max_Meters 20 diff --git a/v7/src/runtime/advice.scm b/v7/src/runtime/advice.scm deleted file mode 100644 index b700cbc83..000000000 --- a/v7/src/runtime/advice.scm +++ /dev/null @@ -1,469 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/advice.scm,v 13.42 1987/03/17 18:48:26 cph Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Advice package - -(declare (usual-integrations)) - -(define advice-package - (make-environment - -(define the-args) -(define the-procedure) -(define the-result) - -(define (*args*) - the-args) - -(define (*proc*) - the-procedure) - -(define (*result*) - the-result) - -(define entry-advice-population - (make-population)) - -(define exit-advice-population - (make-population)) - -;;;; Advice Wrappers - -(define (add-lambda-advice! lambda advice-transformation) - ((access lambda-wrap-body! lambda-package) lambda - (lambda (body state cont) - (if (null? state) - (cont (make-advice-hook) - (advice-transformation '() '() cons)) - (cont body - (advice-transformation (car state) (cdr state) cons)))))) - -(define (remove-lambda-advice! lambda advice-transformation) - (lambda-advice lambda - (lambda (entry-advice exit-advice) - (advice-transformation entry-advice exit-advice - (lambda (new-entry-advice new-exit-advice) - (if (and (null? new-entry-advice) - (null? new-exit-advice)) - ((access lambda-unwrap-body! lambda-package) lambda) - ((access lambda-wrap-body! lambda-package) lambda - (lambda (body state cont) - (cont body (cons new-entry-advice new-exit-advice)))))))))) - -(define (lambda-advice lambda cont) - ((access lambda-wrapper-components lambda-package) lambda - (lambda (original-body state) - (if (null? state) - (error "Procedure has no advice -- LAMBDA-ADVICE" lambda) - (cont (car state) - (cdr state)))))) - -(define (make-advice-hook) - (make-combination syntaxed-advice-procedure - (list (make-the-environment)))) - -(define syntaxed-advice-procedure - (scode-quote - (ACCESS ADVISED-PROCEDURE-WRAPPER ADVICE-PACKAGE '()))) - -;;;; The Advice Hook - -;;; This procedure is called with the newly-created environment as its -;;; argument. - -;;; Doing (PROCEED) from within entry or exit advice will cause that -;;; particular piece of advice to be terminated, but any remaining -;;; advice to be executed. Doing (PROCEED value), however, -;;; immediately terminates all advice and returns VALUE as if the -;;; procedure called had generated the value. Returning from a piece -;;; of exit advice is equivalent to doing (PROCEED value) from it. - -(define (advised-procedure-wrapper environment) - (let ((procedure (environment-procedure environment)) - (arguments (environment-arguments environment))) - ((access lambda-wrapper-components lambda-package) - (procedure-lambda procedure) - (lambda (original-body state) - (call-with-current-continuation - (lambda (continuation) - - (define ((catching-proceeds receiver) advice) - (with-proceed-point - (lambda (value) - (if (null? value) - '() - (continuation (car value)))) - (lambda () - (receiver advice)))) - - (for-each (catching-proceeds - (lambda (advice) - (advice procedure arguments environment))) - (car state)) - (let ((value (scode-eval original-body environment))) - (for-each (catching-proceeds - (lambda (advice) - (set! value - (advice procedure - arguments - value - environment)))) - (cdr state)) - value))))))) - -;;;; Primitive Advisors - -(define (primitive-advice lambda) - (lambda-advice lambda list)) - -(define (primitive-entry-advice lambda) - (lambda-advice lambda - (lambda (entry-advice exit-advice) - entry-advice))) - -(define (primitive-exit-advice lambda) - (lambda-advice lambda - (lambda (entry-advice exit-advice) - exit-advice))) - -(define (primitive-advise-entry lambda advice) - (add-lambda-advice! lambda - (lambda (entry-advice exit-advice cont) - (cont (if (memq advice entry-advice) - entry-advice - (cons advice entry-advice)) - exit-advice))) - (add-to-population! entry-advice-population lambda)) - -(define (primitive-advise-exit lambda advice) - (add-lambda-advice! lambda - (lambda (entry-advice exit-advice cont) - (cont entry-advice - (if (memq advice exit-advice) - exit-advice - (append! exit-advice (list advice)))))) - (add-to-population! exit-advice-population lambda)) - -(define ((primitive-advise-both new-entry-advice new-exit-advice) lambda) - (add-lambda-advice! lambda - (lambda (entry-advice exit-advice cont) - (cont (if (memq new-entry-advice entry-advice) - entry-advice - (cons new-entry-advice entry-advice)) - (if (memq new-exit-advice exit-advice) - exit-advice - (append! exit-advice (list new-exit-advice)))))) - (add-to-population! entry-advice-population lambda) - (add-to-population! exit-advice-population lambda)) - -(define (eq?-adjoin object list) - (if (memq object list) - list - (cons object list))) - -(define (primitive-unadvise-entire-entry lambda) - (remove-lambda-advice! lambda - (lambda (entry-advice exit-advice cont) - (cont '() exit-advice))) - (remove-from-population! entry-advice-population lambda)) - -(define (primitive-unadvise-entire-exit lambda) - (remove-lambda-advice! lambda - (lambda (entry-advice exit-advice cont) - (cont entry-advice '()))) - (remove-from-population! exit-advice-population lambda)) - -(define (primitive-unadvise-entire-lambda lambda) - ((access lambda-unwrap-body! lambda-package) lambda) - (remove-from-population! entry-advice-population lambda) - (remove-from-population! exit-advice-population lambda)) - -(define ((primitive-unadvise-entry advice) lambda) - (remove-lambda-advice! lambda - (lambda (entry-advice exit-advice cont) - (let ((new-entry-advice (delq! advice entry-advice))) - (if (null? new-entry-advice) - (remove-from-population! entry-advice-population lambda)) - (cont new-entry-advice exit-advice))))) - -(define ((primitive-unadvise-exit advice) lambda) - (remove-lambda-advice! lambda - (lambda (entry-advice exit-advice cont) - (let ((new-exit-advice (delq! advice exit-advice))) - (if (null? new-exit-advice) - (remove-from-population! exit-advice-population lambda)) - (cont entry-advice new-exit-advice))))) - -(define ((primitive-unadvise-both old-entry-advice old-exit-advice) lambda) - (remove-lambda-advice! lambda - (lambda (entry-advice exit-advice cont) - (let ((new-entry-advice (delq! old-entry-advice entry-advice)) - (new-exit-advice (delq! old-exit-advice exit-advice))) - (if (null? new-entry-advice) - (remove-from-population! entry-advice-population lambda)) - (if (null? new-exit-advice) - (remove-from-population! exit-advice-population lambda)) - (cont new-entry-advice new-exit-advice))))) - -(define (((particular-advisor advisor) advice) lambda) - (advisor lambda advice)) - -(define particular-entry-advisor (particular-advisor primitive-advise-entry)) -(define particular-exit-advisor (particular-advisor primitive-advise-exit)) -(define particular-both-advisor primitive-advise-both) -(define particular-entry-unadvisor primitive-unadvise-entry) -(define particular-exit-unadvisor primitive-unadvise-exit) -(define particular-both-unadvisor primitive-unadvise-both) - -;;;; Trace - -(define (trace-entry-advice proc args env) - (trace-display proc args)) - -(define (trace-exit-advice proc args result env) - (trace-display proc args result) - result) - -(define (trace-display proc args #!optional result) - (newline) - (let ((width (- (access printer-width implementation-dependencies) 3))) - (let ((output - (with-output-to-truncated-string - width - (lambda () - (if (unassigned? result) - (write-string "[Entering ") - (begin (write-string "[") - (write result) - (write-string " <== "))) - (write-string "<") - (write proc) - (for-each (lambda (arg) (write-char #\Space) (write arg)) - args))))) - (if (car output) ; Too long? - (begin - (write-string (substring (cdr output) 0 (- width 5))) - (write-string " ... ")) - (write-string (cdr output))))) - (write-string ">]")) - -(define primitive-trace-entry - (particular-entry-advisor trace-entry-advice)) - -(define primitive-trace-exit - (particular-exit-advisor trace-exit-advice)) - -(define primitive-trace-both - (particular-both-advisor trace-entry-advice trace-exit-advice)) - -(define primitive-untrace - (particular-both-unadvisor trace-entry-advice trace-exit-advice)) - -(define primitive-untrace-entry - (particular-entry-unadvisor trace-entry-advice)) - -(define primitive-untrace-exit - (particular-exit-unadvisor trace-exit-advice)) - -;;;; Break - -(define (break-rep env message . info) - (push-rep env - (lambda () - (apply trace-display info) - ((standard-rep-message message))) - (standard-rep-prompt breakpoint-prompt))) - -(define (break-entry-advice proc args env) - (fluid-let ((the-procedure proc) - (the-args args)) - (break-rep env "Breakpoint on entry" proc args))) - -(define (break-exit-advice proc args result env) - (fluid-let ((the-procedure proc) - (the-args args) - (the-result result)) - (break-rep env "Breakpoint on exit" proc args result)) - result) - -(define primitive-break-entry - (particular-entry-advisor break-entry-advice)) - -(define primitive-break-exit - (particular-exit-advisor break-exit-advice)) - -(define primitive-break-both - (particular-both-advisor break-entry-advice break-exit-advice)) - -(define primitive-unbreak - (particular-both-unadvisor break-entry-advice break-exit-advice)) - -(define primitive-unbreak-entry - (particular-entry-unadvisor break-entry-advice)) - -(define primitive-unbreak-exit - (particular-exit-unadvisor break-exit-advice)) - -;;;; Top Level Wrappers - -(define (find-internal-lambda procedure path) - (define (find-lambda lambda path) - (define (loop elements) - (cond ((null? elements) - (error "Couldn't find internal definition" path)) - ((definition? (car elements)) - (definition-components (car elements) - (lambda (name value) - (if (eq? name (car path)) - (if (lambda? value) - (find-lambda value (cdr path)) - (error "Internal definition not a procedure" path)) - (loop (cdr elements)))))) - (else - (loop (cdr elements))))) - - (if (null? path) - lambda - (lambda-components* lambda - (lambda (name required optional rest body) - (loop (sequence-actions body)))))) - - (if (null? path) - (procedure-lambda procedure) - (find-lambda (procedure-lambda procedure) (car path)))) - -;; The LIST-COPY will prevent any mutation problems. -(define ((wrap-advice-extractor extractor) procedure . path) - (list-copy (extractor (find-internal-lambda procedure path)))) - -(define advice (wrap-advice-extractor primitive-advice)) -(define entry-advice (wrap-advice-extractor primitive-entry-advice)) -(define exit-advice (wrap-advice-extractor primitive-exit-advice)) - -(define ((wrap-general-advisor advisor) procedure advice . path) - (advisor (find-internal-lambda procedure path) advice) - *the-non-printing-object*) - -(define advise-entry (wrap-general-advisor primitive-advise-entry)) -(define advise-exit (wrap-general-advisor primitive-advise-exit)) - -(define (((wrap-unadvisor map-over-population) unadvisor) . procedure&path) - (if (null? procedure&path) - (map-over-population unadvisor) - (unadvisor (find-internal-lambda (car procedure&path) - (cdr procedure&path)))) - *the-non-printing-object*) - -(define wrap-entry-unadvisor - (wrap-unadvisor - (lambda (operation) - (map-over-population entry-advice-population operation)))) - -(define wrap-exit-unadvisor - (wrap-unadvisor - (lambda (operation) - (map-over-population exit-advice-population operation)))) - -(define wrap-both-unadvisor - (wrap-unadvisor - (lambda (operation) - (map-over-population entry-advice-population operation) - (map-over-population exit-advice-population operation)))) - -(define unadvise (wrap-both-unadvisor primitive-unadvise-entire-lambda)) -(define unadvise-entry (wrap-entry-unadvisor primitive-unadvise-entire-entry)) -(define unadvise-exit (wrap-exit-unadvisor primitive-unadvise-entire-exit)) - -(define untrace (wrap-both-unadvisor primitive-untrace)) -(define untrace-entry (wrap-entry-unadvisor primitive-untrace-entry)) -(define untrace-exit (wrap-exit-unadvisor primitive-untrace-exit)) - -(define unbreak (wrap-both-unadvisor primitive-unbreak)) -(define unbreak-entry (wrap-entry-unadvisor primitive-unbreak-entry)) -(define unbreak-exit (wrap-exit-unadvisor primitive-unbreak-exit)) - -(define ((wrap-advisor advisor) procedure . path) - (advisor (find-internal-lambda procedure path)) - *the-non-printing-object*) - -(define trace-entry (wrap-advisor primitive-trace-entry)) -(define trace-exit (wrap-advisor primitive-trace-exit)) -(define trace-both (wrap-advisor primitive-trace-both)) - -(define break-entry (wrap-advisor primitive-break-entry)) -(define break-exit (wrap-advisor primitive-break-exit)) -(define break-both (wrap-advisor primitive-break-both)) - -;;; end of ADVICE-PACKAGE. -)) - -;;;; Exports - -(define advice (access advice advice-package)) -(define entry-advice (access entry-advice advice-package)) -(define exit-advice (access exit-advice advice-package)) - -(define advise-entry (access advise-entry advice-package)) -(define advise-exit (access advise-exit advice-package)) - -(define unadvise (access unadvise advice-package)) -(define unadvise-entry (access unadvise-entry advice-package)) -(define unadvise-exit (access unadvise-exit advice-package)) - -(define trace (access trace-both advice-package)) -(define trace-entry (access trace-entry advice-package)) -(define trace-exit (access trace-exit advice-package)) -(define trace-both (access trace-both advice-package)) - -(define untrace (access untrace advice-package)) -(define untrace-entry (access untrace-entry advice-package)) -(define untrace-exit (access untrace-exit advice-package)) - -(define break (access break-both advice-package)) -(define break-entry (access break-entry advice-package)) -(define break-exit (access break-exit advice-package)) -(define break-both (access break-both advice-package)) - -(define unbreak (access unbreak advice-package)) -(define unbreak-entry (access unbreak-entry advice-package)) -(define unbreak-exit (access unbreak-exit advice-package)) - -(define *args* (access *args* advice-package)) -(define *proc* (access *proc* advice-package)) -(define *result* (access *result* advice-package)) \ No newline at end of file diff --git a/v7/src/runtime/bitstr.scm b/v7/src/runtime/bitstr.scm deleted file mode 100644 index 932b9ecdc..000000000 --- a/v7/src/runtime/bitstr.scm +++ /dev/null @@ -1,86 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/bitstr.scm,v 13.41 1987/01/23 00:09:36 jinx Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Bit String Primitives - -(declare (usual-integrations)) - -(in-package system-global-environment -(let-syntax () - (define-macro (define-primitives . names) - `(BEGIN ,@(map (lambda (name) - `(DEFINE ,name - ,(make-primitive-procedure name))) - names))) - (define-primitives - bit-string-allocate make-bit-string bit-string? - bit-string-length bit-string-ref bit-string-clear! bit-string-set! - bit-string-zero? bit-string=? - bit-string-fill! bit-string-move! bit-string-movec! - bit-string-or! bit-string-and! bit-string-andc! - bit-substring-move-right! - bit-string->unsigned-integer unsigned-integer->bit-string - read-bits! write-bits!))) - -(define (bit-string-append x y) - (let ((x-length (bit-string-length x)) - (y-length (bit-string-length y))) - (let ((result (bit-string-allocate (+ x-length y-length)))) - (bit-substring-move-right! x 0 x-length result 0) - (bit-substring-move-right! y 0 y-length result x-length) - result))) - -(define (bit-substring bit-string start end) - (let ((result (bit-string-allocate (- end start)))) - (bit-substring-move-right! bit-string start end result 0) - result)) - -(define (signed-integer->bit-string nbits number) - (unsigned-integer->bit-string nbits - (if (negative? number) - (+ number (expt 2 nbits)) - number))) - -(define (bit-string->signed-integer bit-string) - (let ((unsigned-result (bit-string->unsigned-integer bit-string)) - (nbits (bit-string-length bit-string))) - (if (bit-string-ref bit-string (-1+ nbits)) ;Sign bit. - (- unsigned-result (expt 2 nbits)) - unsigned-result))) - unsigned-result))) \ No newline at end of file diff --git a/v7/src/runtime/boot.scm b/v7/src/runtime/boot.scm deleted file mode 100644 index f64819b4d..000000000 --- a/v7/src/runtime/boot.scm +++ /dev/null @@ -1,142 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/boot.scm,v 13.43 1987/04/17 00:58:33 cph Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Boot Utilities - -(declare (usual-integrations)) - -;;; The utilities in this file are the first thing loaded into the -;;; world after the type tables. They can't depend on anything else -;;; except those tables. - -;;;; Primitive Operators - -(let-syntax ((define-global-primitives - (macro names - `(BEGIN - ,@(map (lambda (name) - `(DEFINE ,name ,(make-primitive-procedure name))) - names))))) - (define-global-primitives - SCODE-EVAL FORCE WITH-THREADED-CONTINUATION - SET-INTERRUPT-ENABLES! WITH-INTERRUPTS-REDUCED - WITH-INTERRUPT-MASK - GET-FIXED-OBJECTS-VECTOR WITH-HISTORY-DISABLED - PRIMITIVE-PROCEDURE-ARITY NOT FALSE? - UNSNAP-LINKS! - - ;; Environment - LEXICAL-REFERENCE LEXICAL-ASSIGNMENT LOCAL-ASSIGNMENT - LEXICAL-UNASSIGNED? LEXICAL-UNBOUND? LEXICAL-UNREFERENCEABLE? - - ;; Pointers - EQ? - PRIMITIVE-SET-TYPE MAKE-NON-POINTER-OBJECT - PRIMITIVE-TYPE? PRIMITIVE-TYPE PRIMITIVE-DATUM - OBJECT-DANGEROUS? MAKE-OBJECT-SAFE MAKE-OBJECT-DANGEROUS - - ;; List Operations - ;; (these appear here for the time being because the compiler - ;; couldn't handle the `in-package' required to put them in - ;; `list.scm'. They should be moved back when that is fixed. - CONS PAIR? NULL? LENGTH CAR CDR SET-CAR! SET-CDR! - GENERAL-CAR-CDR MEMQ ASSQ - - ;; System Compound Datatypes - MAKE-CELL CELL? CELL-CONTENTS SET-CELL-CONTENTS! - - SYSTEM-PAIR-CONS SYSTEM-PAIR? - SYSTEM-PAIR-CAR SYSTEM-PAIR-SET-CAR! - SYSTEM-PAIR-CDR SYSTEM-PAIR-SET-CDR! - - SYSTEM-HUNK3-CXR0 SYSTEM-HUNK3-SET-CXR0! - SYSTEM-HUNK3-CXR1 SYSTEM-HUNK3-SET-CXR1! - SYSTEM-HUNK3-CXR2 SYSTEM-HUNK3-SET-CXR2! - - SYSTEM-LIST-TO-VECTOR SYSTEM-SUBVECTOR-TO-LIST SYSTEM-VECTOR? - SYSTEM-VECTOR-SIZE SYSTEM-VECTOR-REF SYSTEM-VECTOR-SET! - ) -;;; end of DEFINE-GLOBAL-PRIMITIVES scope. -) - -;;;; Potpourri - -(define *the-non-printing-object* '(*THE-NON-PRINTING-OBJECT*)) -(define (identity-procedure x) x) -(define false #F) -(define true #T) - -(define (null-procedure . args) '()) -(define (false-procedure . args) #F) -(define (true-procedure . args) #T) - -(define (without-interrupts thunk) - (with-interrupts-reduced interrupt-mask-gc-ok - (lambda (old-mask) - (thunk)))) - -(define apply - (let ((primitive (make-primitive-procedure 'APPLY))) - (named-lambda (apply f . args) - (primitive f - (if (null? args) - '() - (let loop - ((first-element (car args)) - (rest-elements (cdr args))) - (if (null? rest-elements) - first-element - (cons first-element - (loop (car rest-elements) - (cdr rest-elements)))))))))) - -(define system-hunk3-cons - (let ((hunk3-cons (make-primitive-procedure 'HUNK3-CONS))) - (named-lambda (system-hunk3-cons type cxr0 cxr1 cxr2) - (primitive-set-type type (hunk3-cons cxr0 cxr1 cxr2))))) - -(define (symbol-hash symbol) - (string-hash (symbol->string symbol))) - -(define (symbol-append . symbols) - (string->symbol (apply string-append (map symbol->string symbols)))) - -(define (boolean? object) - (or (eq? object #F) - (eq? object #T))) \ No newline at end of file diff --git a/v7/src/runtime/char.scm b/v7/src/runtime/char.scm deleted file mode 100644 index 8aa052e70..000000000 --- a/v7/src/runtime/char.scm +++ /dev/null @@ -1,378 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/char.scm,v 13.41 1987/01/23 00:09:52 jinx Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; New Character Abstraction - -(declare (usual-integrations)) - -(in-package system-global-environment -(let-syntax () - (define-macro (define-primitives . names) - `(BEGIN ,@(map (lambda (name) - `(DEFINE ,name ,(make-primitive-procedure name))) - names))) - (define-primitives - make-char char-code char-bits - char->integer integer->char char->ascii - char-ascii? ascii->char - char-upcase char-downcase))) - -(define char-code-limit #x80) -(define char-bits-limit #x20) -(define char-integer-limit (* char-code-limit char-bits-limit)) - -(define (chars->ascii chars) - (map char->ascii chars)) - -(define (code->char code) - (make-char code 0)) - -(define (char=? x y) - (= (char->integer x) (char->integer y))) - -(define (charinteger x) (char->integer y))) - -(define (char<=? x y) - (<= (char->integer x) (char->integer y))) - -(define (char>? x y) - (> (char->integer x) (char->integer y))) - -(define (char>=? x y) - (>= (char->integer x) (char->integer y))) - -(define (char-ci->integer char) - (char->integer (char-upcase char))) - -(define (char-ci=? x y) - (= (char-ci->integer x) (char-ci->integer y))) - -(define (char-ciinteger x) (char-ci->integer y))) - -(define (char-ci<=? x y) - (<= (char-ci->integer x) (char-ci->integer y))) - -(define (char-ci>? x y) - (> (char-ci->integer x) (char-ci->integer y))) - -(define (char-ci>=? x y) - (>= (char-ci->integer x) (char-ci->integer y))) - -(define char?) -(define digit->char) -(define char->digit) -(define name->char) -(define char->name) -(let () - -(define char-type - (microcode-type 'CHARACTER)) - -(define 0-code (char-code (ascii->char #x30))) -(define upper-a-code (char-code (ascii->char #x41))) -(define lower-a-code (char-code (ascii->char #x61))) -(define space-char (ascii->char #x20)) -(define hyphen-char (ascii->char #x2D)) -(define backslash-char (ascii->char #x5C)) - -(define named-codes - `(("Backspace" . #x08) - ("Tab" . #x09) - ("Linefeed" . #x0A) - ("VT" . #x0B) - ("Page" . #x0C) - ("Return" . #x0D) - ("Call" . #x1A) - ("Altmode" . #x1B) - ("Backnext" . #x1F) - ("Space" . #x20) - ("Rubout" . #x7F) - )) - -(define named-bits - `(("C" . #o01) - ("Control" . #o01) - ("M" . #o02) - ("Meta" . #o02) - ("S" . #o04) - ("Super" . #o04) - ("H" . #o10) - ("Hyper" . #o10) - ("T" . #o20) - ("Top" . #o20) - )) - -(define (-map-> alist string start end) - (define (loop entries) - (and (not (null? entries)) - (let ((key (caar entries))) - (if (substring-ci=? string start end - key 0 (string-length key)) - (cdar entries) - (loop (cdr entries)))))) - (loop alist)) - -(define (<-map- alist n) - (define (loop entries) - (and (not (null? entries)) - (if (= n (cdar entries)) - (caar entries) - (loop (cdr entries))))) - (loop alist)) - -(set! char? -(named-lambda (char? object) - (primitive-type? char-type object))) - -(set! digit->char -(named-lambda (digit->char digit #!optional radix) - (cond ((unassigned? radix) (set! radix 10)) - ((not (and (<= 2 radix) (<= radix 36))) - (error "DIGIT->CHAR: Bad radix" radix))) - (and (<= 0 digit) (< digit radix) - (code->char (if (< digit 10) - (+ digit 0-code) - (+ (- digit 10) upper-a-code)))))) - -(set! char->digit -(named-lambda (char->digit char #!optional radix) - (cond ((unassigned? radix) (set! radix 10)) - ((not (and (<= 2 radix) (<= radix 36))) - (error "CHAR->DIGIT: Bad radix" radix))) - (and (zero? (char-bits char)) - (let ((code (char-code char))) - (define (try base-digit base-code) - (let ((n (+ base-digit (- code base-code)))) - (and (<= base-digit n) - (< n radix) - n))) - (or (try 0 0-code) - (try 10 upper-a-code) - (try 10 lower-a-code)))))) - -(set! name->char -(named-lambda (name->char string) - (let ((end (string-length string)) - (bits '())) - (define (loop start) - (let ((left (- end start))) - (cond ((zero? left) - (error "Missing character name")) - ((= left 1) - (let ((char (string-ref string start))) - (if (char-graphic? char) - (char-code char) - (error "Non-graphic character" char)))) - (else - (let ((hyphen (substring-find-next-char string start end - hyphen-char))) - (if (not hyphen) - (name->code string start end) - (let ((bit (-map-> named-bits string start hyphen))) - (if (not bit) - (name->code string start end) - (begin (if (not (memv bit bits)) - (set! bits (cons bit bits))) - (loop (1+ hyphen))))))))))) - (let ((code (loop 0))) - (make-char code (apply + bits)))))) - -(define (name->code string start end) - (if (substring-ci=? string start end "Newline" 0 7) - (char-code char:newline) - (or (-map-> named-codes string start end) - (error "Unknown character name" (substring string start end))))) - -(set! char->name -(named-lambda (char->name char #!optional slashify?) - (if (unassigned? slashify?) (set! slashify? false)) - (define (loop weight bits) - (if (zero? bits) - (let ((code (char-code char))) - (let ((base-char (code->char code))) - (cond ((<-map- named-codes code)) - ((and slashify? - (not (zero? (char-bits char))) - (or (char=? base-char backslash-char) - (char-set-member? (access atom-delimiters - parser-package) - base-char))) - (string-append "\\" (char->string base-char))) - ((char-graphic? base-char) - (char->string base-char)) - (else - (string-append ""))))) - (let ((qr (integer-divide bits 2))) - (let ((rest (loop (* weight 2) (integer-divide-quotient qr)))) - (if (zero? (integer-divide-remainder qr)) - rest - (string-append (or (<-map- named-bits weight) - (string-append "")) - "-" - rest)))))) - (loop 1 (char-bits char)))) - -) - -;;;; Character Sets - -(define (char-set? object) - (and (string? object) (= (string-length object) 256))) - -(define (char-set . chars) - (let ((char-set (string-allocate 256))) - (vector-8b-fill! char-set 0 256 0) - (for-each (lambda (char) (vector-8b-set! char-set (char->ascii char) 1)) - chars) - char-set)) - -(define (predicate->char-set predicate) - (let ((char-set (string-allocate 256))) - (define (loop code) - (if (< code 256) - (begin (vector-8b-set! char-set code - (if (predicate (ascii->char code)) 1 0)) - (loop (1+ code))))) - (loop 0) - char-set)) - -(define (char-set-members char-set) - (define (loop code) - (cond ((>= code 256) '()) - ((zero? (vector-8b-ref char-set code)) (loop (1+ code))) - (else (cons (ascii->char code) (loop (1+ code)))))) - (loop 0)) - -(define (char-set-member? char-set char) - (let ((ascii (char-ascii? char))) - (and ascii (not (zero? (vector-8b-ref char-set ascii)))))) - -(define (char-set-invert char-set) - (predicate->char-set - (lambda (char) (not (char-set-member? char-set char))))) - -(define (char-set-union char-set-1 char-set-2) - (predicate->char-set - (lambda (char) - (or (char-set-member? char-set-1 char) - (char-set-member? char-set-2 char))))) - -(define (char-set-intersection char-set-1 char-set-2) - (predicate->char-set - (lambda (char) - (and (char-set-member? char-set-1 char) - (char-set-member? char-set-2 char))))) - -(define (char-set-difference char-set-1 char-set-2) - (predicate->char-set - (lambda (char) - (and (char-set-member? char-set-1 char) - (not (char-set-member? char-set-2 char)))))) - -;;;; System Character Sets - -(define char-set:upper-case - (predicate->char-set - (let ((lower (ascii->char #x41)) - (upper (ascii->char #x5A))) - (lambda (char) - (and (char<=? lower char) - (char<=? char upper)))))) - -(define char-set:lower-case - (predicate->char-set - (let ((lower (ascii->char #x61)) - (upper (ascii->char #x7A))) - (lambda (char) - (and (char<=? lower char) - (char<=? char upper)))))) - -(define char-set:numeric - (predicate->char-set - (let ((lower (ascii->char #x30)) - (upper (ascii->char #x39))) - (lambda (char) - (and (char<=? lower char) - (char<=? char upper)))))) - -(define char-set:alphabetic - (char-set-union char-set:upper-case char-set:lower-case)) - -(define char-set:alphanumeric - (char-set-union char-set:alphabetic char-set:numeric)) - -(define char-set:graphic - (predicate->char-set - (let ((lower (ascii->char #x20)) - (upper (ascii->char #x7E))) - (lambda (char) - (and (char<=? lower char) - (char<=? char upper)))))) - -(define char-set:standard - (char-set-union char-set:graphic (char-set (ascii->char #x0D)))) - -(define char-set:whitespace - (char-set (ascii->char #x09) ;Tab - (ascii->char #x0A) ;Linefeed - (ascii->char #x0C) ;Page - (ascii->char #x0D) ;Return - (ascii->char #x20) ;Space - )) - -(define char-set:not-whitespace - (char-set-invert char-set:whitespace)) - -(define ((char-set-predicate char-set) char) - (char-set-member? char-set char)) - -(define char-upper-case? (char-set-predicate char-set:upper-case)) -(define char-lower-case? (char-set-predicate char-set:lower-case)) -(define char-numeric? (char-set-predicate char-set:numeric)) -(define char-alphabetic? (char-set-predicate char-set:alphabetic)) -(define char-alphanumeric? (char-set-predicate char-set:alphanumeric)) -(define char-graphic? (char-set-predicate char-set:graphic)) -(define char-standard? (char-set-predicate char-set:standard)) -(define char-whitespace? (char-set-predicate char-set:whitespace)) diff --git a/v7/src/runtime/datime.scm b/v7/src/runtime/datime.scm deleted file mode 100644 index 5773e6587..000000000 --- a/v7/src/runtime/datime.scm +++ /dev/null @@ -1,120 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/datime.scm,v 13.41 1987/01/23 00:11:08 jinx Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Date and Time Routines - -(declare (usual-integrations)) - -;;;; Date and Time - -(define date - (let ((year (make-primitive-procedure 'CURRENT-YEAR)) - (month (make-primitive-procedure 'CURRENT-MONTH)) - (day (make-primitive-procedure 'CURRENT-DAY))) - (named-lambda (date #!optional receiver) - ((if (unassigned? receiver) list receiver) - (year) (month) (day))))) - -(define time - (let ((hour (make-primitive-procedure 'CURRENT-HOUR)) - (minute (make-primitive-procedure 'CURRENT-MINUTE)) - (second (make-primitive-procedure 'CURRENT-SECOND))) - (named-lambda (time #!optional receiver) - ((if (unassigned? receiver) list receiver) - (hour) (minute) (second))))) - -(define date->string) -(define time->string) -(let () - -(set! date->string -(named-lambda (date->string year month day) - (if year - (string-append - (vector-ref days-of-the-week - (let ((qr (integer-divide year 4))) - (remainder (+ (* year 365) - (if (and (zero? (integer-divide-remainder qr)) - (<= month 2)) - (integer-divide-quotient qr) - (1+ (integer-divide-quotient qr))) - (vector-ref days-through-month (-1+ month)) - day - 6) - 7))) - " " - (vector-ref months-of-the-year (-1+ month)) - " " - (write-to-string day) - ", 19" - (write-to-string year)) - "Date primitives not installed"))) - -(define months-of-the-year - #("January" "February" "March" "April" "May" "June" "July" - "August" "September" "October" "November" "December")) - -(define days-of-the-week - #("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday")) - -(define days-through-month - (let () - (define (month-loop months value) - (if (null? months) - '() - (cons value - (month-loop (cdr months) (+ value (car months)))))) - (list->vector (month-loop '(31 28 31 30 31 30 31 31 30 31 30 31) 0)))) - -(set! time->string -(named-lambda (time->string hour minute second) - (if hour - (string-append (write-to-string - (cond ((zero? hour) 12) - ((< hour 13) hour) - (else (- hour 12)))) - (if (< minute 10) ":0" ":") - (write-to-string minute) - (if (< second 10) ":0" ":") - (write-to-string second) - " " - (if (< hour 12) "AM" "PM")) - "Time primitives not installed"))) - -) diff --git a/v7/src/runtime/debug.scm b/v7/src/runtime/debug.scm deleted file mode 100644 index b7703a711..000000000 --- a/v7/src/runtime/debug.scm +++ /dev/null @@ -1,545 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 13.42 1987/03/17 18:49:00 cph Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Debugger - -(in-package debugger-package -(declare (usual-integrations)) - -(define debug-package - (make-environment - -(define current-continuation) -(define previous-continuations) -(define current-reduction-number) -(define current-number-of-reductions) -(define current-reduction) -(define current-environment) - -(define command-set - (make-command-set 'DEBUG-COMMANDS)) - -(define reduction-wrap-around-tag - 'WRAP-AROUND) - -(define print-user-friendly-name - (access print-user-friendly-name env-package)) - -(define print-expression - pp) - -(define student-walk? - false) - -(define print-return-values? - false) - -(define (define-debug-command letter function help-text) - (define-letter-command command-set letter function help-text)) - -;;; Basic Commands - -(define-debug-command #\? (standard-help-command command-set) - "Help, list command letters") - -(define-debug-command #\Q standard-exit-command "Quit (exit DEBUG)") - -(define (debug #!optional the-continuation) - (fluid-let ((current-continuation) - (previous-continuations '()) - (current-reduction-number) - (current-number-of-reductions) - (current-reduction false) - (current-environment '())) - (debug-abstract-continuation - (cond ((unassigned? the-continuation) (rep-continuation)) - ((raw-continuation? the-continuation); Must precede next test! - (raw-continuation->continuation the-continuation)) - ((continuation? the-continuation) the-continuation) - (else (error "DEBUG: Not a continuation" the-continuation)))))) - -(define (debug-abstract-continuation continuation) - (set-current-continuation! continuation initial-reduction-number) - (letter-commands command-set - (lambda () - (print-current-expression) - ((standard-rep-message "Debugger"))) - (standard-rep-prompt "Debug-->"))) - -(define (undefined-environment? environment) - (or (continuation-undefined-environment? environment) - (eq? environment system-global-environment) - (and (environment? environment) - ((access system-external-environment? environment-package) - environment)))) - -(define (print-undefined-environment) - (format "~%Undefined environment at this subproblem/reduction level")) - -(define (with-rep-alternative env receiver) - (if (undefined-environment? env) - (begin - (print-undefined-environment) - (format "~%Using the read-eval-print environment instead!") - (receiver (rep-environment))) - (receiver env))) - -(define (if-valid-environment env receiver) - (if (undefined-environment? env) - (print-undefined-environment) - (receiver env))) - -(define (current-expression) - (if current-reduction - (reduction-expression current-reduction) - (let ((exp (continuation-expression current-continuation))) - (if (or (not (continuation-undefined-expression? exp)) - (null? (continuation-annotation current-continuation))) - exp - (cons 'UNDEFINED-EXPRESSION - (continuation-annotation current-continuation)))))) - -;;;; Random display commands - -(define (pretty-print-current-expression) - (print-expression (current-expression))) - -(define-debug-command #\L pretty-print-current-expression - "(list expression) Pretty-print the current expression") - -(define (pretty-print-reduction-function) - (if-valid-environment (if current-reduction - (reduction-environment current-reduction) - current-environment) - (lambda (env) (pp (environment-procedure env))))) - -(define-debug-command #\P pretty-print-reduction-function - "Pretty print current procedure") - -(define (print-current-expression) - (define (print-current-reduction) - (format "~2xReduction Number:~x~o~%Expression:" current-reduction-number) - (print-expression (reduction-expression current-reduction))) - - (define (print-application-information env) - (define (do-it return?) - (if return? (format "~%within ") (format "within ")) - (print-user-friendly-name env) - (if return? - (format "~%applied to ~@68o" (environment-arguments env)) - (format " applied to ~@68o" (environment-arguments env)))) - - (let ((output (with-output-to-string (lambda () (do-it false))))) - (if (< (string-length output) - (access printer-width implementation-dependencies)) - (format "~%~s" output) - (do-it true)))) - - (if (null-continuation? current-continuation) - (format "~%Null continuation") - (begin - (format "~%Subproblem Level: ~o" (length previous-continuations)) - (if current-reduction - (print-current-reduction) - (begin - (format "~%Possibly Incomplete Expression:") - (print-expression (continuation-expression current-continuation)))) - (if-valid-environment current-environment - print-application-information)))) - -(define-debug-command #\S print-current-expression - "Print the current subproblem/reduction") - -(define (reductions-command) - (if (null-continuation? current-continuation) - (format "~%Null continuation") - (let loop ((r (continuation-reductions current-continuation))) - (cond ((pair? r) - (print-expression (reduction-expression (car r))) - (loop (cdr r))) - ((wrap-around-in-reductions? r) - (format "~%Wrap Around in the reductions at this level.")) - (else 'done))))) - -(define-debug-command #\R reductions-command - "Print the reductions of the current subproblem level") - -;;;; Short history display - -(define (summarize-history-command) - (define (print-continuations cont level) - (define (print-reductions reductions show-all?) - (define (print-reduction red number) - (terse-print-expression level - (reduction-expression red) - (reduction-environment red))) - - (let loop ((reductions reductions) (number 0)) - (if (pair? reductions) - (begin - (print-reduction (car reductions) number) - (if show-all? (loop (cdr reductions) (1+ number))))))) - - (if (null-continuation? cont) - *the-non-printing-object* - (begin - (let ((reductions (continuation-reductions cont))) - (if (not (pair? reductions)) - (terse-print-expression level - (continuation-expression cont) - (continuation-environment cont)) - (print-reductions reductions (= level 0)))) - (print-continuations (continuation-next-continuation cont) - (1+ level))))) - - (let ((top-continuation (if (null? previous-continuations) - current-continuation - (car (last-pair previous-continuations))))) - (if (null-continuation? top-continuation) - (format "~%No history available") - (begin - (format "~%Sub Prb. Procedure Name Expression~%") - (print-continuations top-continuation 0))))) - -(define (terse-print-expression level expression environment) - (format "~%~@3o~:20o~4x~@:52c" - level - ;; procedure name - (if (or (undefined-environment? environment) - (special-name? (environment-name environment))) - *the-non-printing-object* - (environment-name environment)) - expression)) - -(define-debug-command #\H summarize-history-command - "Prints a summary of the entire history") - -;;;; Motion to earlier expressions - -(define (earlier-reduction) - (define (up! message) - (format "~%~s~%Going to the previous (earlier) continuation!" message) - (earlier-continuation-command)) - - (cond ((and student-walk? - (> (length previous-continuations) 0) - (= current-reduction-number 0)) - (earlier-continuation-command)) - ((< current-reduction-number (-1+ current-number-of-reductions)) - (set-current-reduction! (1+ current-reduction-number)) - (print-current-expression)) - ((wrap-around-in-reductions? - (continuation-reductions current-continuation)) - (up! "Wrap around in reductions at this level!")) - (else (up! "No more reductions at this level!")))) - -(define-debug-command #\B earlier-reduction "Earlier reduction (Back in time)") - -(define (earlier-subproblem) - (let ((new (continuation-next-continuation current-continuation))) - (set! previous-continuations - (cons current-continuation previous-continuations)) - (set-current-continuation! new normal-reduction-number))) - -(define (earlier-continuation-command) - (if (not (null-continuation? (continuation-next-continuation - current-continuation))) - (earlier-subproblem) - (format "~%There are only ~o subproblem levels" - (length previous-continuations))) - (print-current-expression)) - -(define-debug-command #\U earlier-continuation-command - "Move (Up) to the previous (earlier) continuation") - -;;;; Motion to later expressions - -(define (later-reduction) - (cond ((> current-reduction-number 0) - (set-current-reduction! (-1+ current-reduction-number)) - (print-current-expression)) - ((or (not student-walk?) - (= (length previous-continuations) 1)) - (later-continuation-TO-LAST-REDUCTION)) - (else (later-continuation)))) - -(define-debug-command #\F later-reduction "Later reduction (Forward in time)") - -(define (later-continuation) - (if (null? previous-continuations) - (format "~%Already at lowest subproblem level") - (begin (later-subproblem) (print-current-expression)))) - -(define (later-continuation-TO-LAST-REDUCTION) - (define (later-subproblem-TO-LAST-REDUCTION) - (set-current-continuation! - (car (set! previous-continuations (cdr previous-continuations))) - last-reduction-number)) - - (if (null? previous-continuations) - (format "~%Already at lowest subproblem level") - (begin (later-subproblem-TO-LAST-REDUCTION) - (print-current-expression)))) - -(define (later-subproblem) - (set-current-continuation! - (car (set! previous-continuations (cdr previous-continuations))) - normal-reduction-number)) - -(define (later-continuation-command) - (if (null? previous-continuations) - (format "~%Already at oldest continuation") - (begin (later-subproblem) (print-current-expression)))) - -(define-debug-command #\D later-continuation-command - "Move (Down) to the next (later) continuation") - -;;;; General motion command - -(define (goto-command) - (define (get-reduction-number) - (format "~%Reduction Number (0 through ~o inclusive): " - (-1+ current-number-of-reductions)) - (let ((red (read))) - (cond ((not (number? red)) - (beep) - (format "~%Reduction number must be numeric!") - (get-reduction-number)) - ((not (and (>= red 0) - (< red current-number-of-reductions))) - (format "~%Reduction number out of range.!") - (get-reduction-number)) - (else (set-current-reduction! red))))) - - (define (choose-reduction) - (cond ((> current-number-of-reductions 1) (get-reduction-number)) - ((= current-number-of-reductions 1) - (format "~%There is only one reduction for this subproblem") - (set-current-reduction! 1)) - (else (format "~%There are no reductions for this subproblem.")))) - - (define (get-subproblem-number) - (format "~%Subproblem number: ") - (let ((len (length previous-continuations)) (sub (read))) - (cond ((not (number? sub)) - (beep) - (format "~%Subproblem level must be numeric!") - (get-subproblem-number)) - ((< sub len) (repeat later-subproblem (- len sub)) - (choose-reduction)) - (else - (let loop ((len len)) - (cond ((= sub len) (choose-reduction)) - ((null-continuation? - (continuation-next-continuation current-continuation)) - (format "~%There is no such subproblem.") - (format "~%Now at subproblem number: ~o" - (length previous-continuations)) - (choose-reduction)) - (else (earlier-subproblem) (loop (1+ len))))))))) - - (get-subproblem-number) - (print-current-expression)) - -(define-debug-command #\G goto-command - "Go to a particular Subproblem/Reduction level") - -;;;; Evaluation and frame display commands - -(define (enter-read-eval-print-loop) - (with-rep-alternative - current-environment - (lambda (env) - (read-eval-print env - "You are now in the desired environment" - "Eval-in-env-->")))) - -(define-debug-command #\E enter-read-eval-print-loop - "Enter a read-eval-print loop in the current environment") - -(define (eval-in-current-environment) - (with-rep-alternative current-environment - (lambda (env) - (environment-warning-hook env) - (format "~%Eval--> ") - (eval (read) env)))) - -(define-debug-command #\V eval-in-current-environment - "Evaluate expression in current environment") - -(define show-current-frame - (let ((show-frame (access show-frame env-package))) - (named-lambda (show-current-frame) - (if-valid-environment current-environment - (lambda (env) (show-frame env -1)))))) - -(define-debug-command #\C show-current-frame - "Show Bindings of identifiers in the current environment") - -(define (enter-where-command) - (with-rep-alternative current-environment where)) - -(define-debug-command #\W enter-where-command - "Enter WHERE on the current environment") - -(define (error-info-command) - (format "~% Message: ~s~%Irritant: ~o" (error-message) (error-irritant))) - -(define-debug-command #\I error-info-command "Redisplay the error message") - -;;;; Advanced hacking commands - -(define (return-command) ;command Z - (define (confirm) - (format "~%Confirm: [Y or N] ") - (let ((ans (read))) - (cond ((eq? ans 'Y) true) - ((eq? ans 'N) false) - (else (confirm))))) - - (define (return-read) - (let ((exp (read))) - (if (eq? exp '$) - (unsyntax (current-expression)) - exp))) - - (define (do-it environment next) - (environment-warning-hook environment) - (format "~%Expression to EVALUATE and CONTINUE with ($ to retry): ") - (if print-return-values? - (let ((eval-exp (eval (return-read) environment))) - (format "~%That evaluates to:~%~o" eval-exp) - (if (confirm) (next eval-exp))) - (next (eval (return-read) environment)))) - - (let ((next (continuation-next-continuation current-continuation))) - (if (null-continuation? next) - (begin (beep) (format "~%Can't continue!!!")) - (with-rep-alternative current-environment - (lambda (env) (do-it env next)))))) - -(define-debug-command #\Z return-command - "Return (continue with) an expression after evaluating it") - -(define user-debug-environment (make-environment)) - -(define (internal-command) - (read-eval-print user-debug-environment - "You are now in the debugger environment" - "Debugger-->")) - -(define-debug-command #\X internal-command - "Create a read eval print loop in the debugger environment") - -;;;; Reduction and continuation motion low-level - -(define reduction-expression car) -(define reduction-environment cadr) - -(define (last-reduction-number) - (-1+ current-number-of-reductions)) - -(define (normal-reduction-number) - (min (-1+ current-number-of-reductions) 0)) - -(define (initial-reduction-number) - (let ((environment (continuation-environment current-continuation))) - (if (and (environment? environment) - (let ((procedure (environment-procedure environment))) - (or (eq? procedure error-procedure) - (eq? procedure breakpoint-procedure)))) - 1 - 0))) - -(define (set-current-continuation! continuation hook) - (set! current-continuation continuation) - (set! current-number-of-reductions - (if (null-continuation? continuation) - 0 - (dotted-list-length - (continuation-reductions current-continuation)))) - (set-current-reduction! (hook))) - -(define (set-current-reduction! number) - (set! current-reduction-number number) - (if (and (not (= current-number-of-reductions 0)) (>= number 0)) - (set! current-reduction - (list-ref (continuation-reductions current-continuation) number)) - (set! current-reduction false)) - (set! current-environment - (if current-reduction - (reduction-environment current-reduction) - (continuation-environment current-continuation)))) - -(define (repeat f n) - (if (> n 0) - (begin (f) - (repeat f (-1+ n))))) - -(define (dotted-list-length l) - (let count ((n 0) (L L)) - (if (pair? l) - (count (1+ n) (CDR L)) - n))) - -(define (wrap-around-in-reductions? reductions) - (eq? (list-tail reductions (dotted-list-length reductions)) - reduction-wrap-around-tag)) - -;;; end DEBUG-PACKAGE. -)) - -;;; end IN-PACKAGE DEBUGGER-PACKAGE. -) - -(define debug - (access debug debug-package debugger-package)) - -(define special-name? - (let ((the-special-names - (list lambda-tag:unnamed - (access internal-lambda-tag lambda-package) - (access internal-lexpr-tag lambda-package) - lambda-tag:let - lambda-tag:shallow-fluid-let - lambda-tag:deep-fluid-let - lambda-tag:common-lisp-fluid-let - lambda-tag:make-environment))) - (named-lambda (special-name? symbol) - (memq symbol the-special-names)))) \ No newline at end of file diff --git a/v7/src/runtime/emacs.scm b/v7/src/runtime/emacs.scm deleted file mode 100644 index 4a85891ae..000000000 --- a/v7/src/runtime/emacs.scm +++ /dev/null @@ -1,170 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 13.42 1987/03/07 17:36:00 cph Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; GNU Emacs/Scheme Modeline Interface - -(declare (usual-integrations)) - -(define emacs-interface-package - (make-environment - -(define (transmit-signal type) - (write-char #\Altmode console-output-port) - (write-char type console-output-port)) - -(define (transmit-signal-without-gc type) - (with-interrupts-reduced interrupt-mask-none - (lambda (old-mask) - (transmit-signal type)))) - -(define (emacs-read-start) - (transmit-signal-without-gc #\s)) - -(define (emacs-read-finish) - (transmit-signal-without-gc #\f)) - -(define (emacs-start-gc) - (transmit-signal #\b)) - -(define (emacs-finish-gc state) - (transmit-signal #\e)) - -(define (transmit-signal-with-argument type string) - (with-interrupts-reduced interrupt-mask-none - (lambda (old-mask) - (transmit-signal type) - (write-string string console-output-port) - (write-char #\Altmode console-output-port)))) - -(define (emacs-rep-message string) - (transmit-signal-with-argument #\m string)) - -(define (emacs-rep-prompt level string) - (transmit-signal-with-argument #\p - (string-append (object->string level) - " " - string))) - -(define (emacs-rep-value object) - (transmit-signal-with-argument #\v (object->string object))) - -(define (object->string object) - (with-output-to-string - (lambda () - (write object)))) - -(define (emacs-read-char-immediate) - (define (loop) - (let ((char (primitive-read-char-immediate))) - (if (char=? char char:newline) - (loop) - (begin (emacs-read-finish) - char)))) - (emacs-read-start) - (if (not (primitive-read-char-ready? 0)) - (transmit-signal-without-gc #\c)) - (loop)) - -(define primitive-read-char-ready? - (make-primitive-procedure 'TTY-READ-CHAR-READY?)) - -(define primitive-read-char-immediate - (make-primitive-procedure 'TTY-READ-CHAR-IMMEDIATE)) - -(define paranoid-error-hook? - false) - -(define (emacs-error-hook) - (transmit-signal-without-gc #\z) - (beep) - (if paranoid-error-hook? - (begin - (transmit-signal-with-argument #\P -"Error! Type ctl-E to enter error loop, anything else to return to top level.") - (if (not (char-ci=? (emacs-read-char-immediate) #\C-E)) - (abort-to-previous-driver "Quit!"))))) - -(define normal-start-gc (access gc-start-hook gc-statistics-package)) -(define normal-finish-gc (access gc-finish-hook gc-statistics-package)) -(define normal-rep-message rep-message-hook) -(define normal-rep-prompt rep-prompt-hook) -(define normal-rep-value rep-value-hook) -(define normal-read-start (access read-start-hook console-input-port)) -(define normal-read-finish (access read-finish-hook console-input-port)) -(define normal-read-char-immediate - (access tty-read-char-immediate console-input-port)) -(define normal-error-hook (access *error-decision-hook* error-system)) - -(define (install-emacs-hooks!) - (set! (access gc-start-hook gc-statistics-package) emacs-start-gc) - (set! (access gc-finish-hook gc-statistics-package) emacs-finish-gc) - (set! rep-message-hook emacs-rep-message) - (set! rep-prompt-hook emacs-rep-prompt) - (set! rep-value-hook emacs-rep-value) - (set! (access read-start-hook console-input-port) emacs-read-start) - (set! (access read-finish-hook console-input-port) emacs-read-finish) - (set! (access tty-read-char-immediate console-input-port) - emacs-read-char-immediate) - (set! (access *error-decision-hook* error-system) emacs-error-hook)) - -(define (install-normal-hooks!) - (set! (access gc-start-hook gc-statistics-package) normal-start-gc) - (set! (access gc-finish-hook gc-statistics-package) normal-finish-gc) - (set! rep-message-hook normal-rep-message) - (set! rep-prompt-hook normal-rep-prompt) - (set! rep-value-hook normal-rep-value) - (set! (access read-start-hook console-input-port) normal-read-start) - (set! (access read-finish-hook console-input-port) normal-read-finish) - (set! (access tty-read-char-immediate console-input-port) - normal-read-char-immediate) - (set! (access *error-decision-hook* error-system) normal-error-hook)) - -(define under-emacs? - (make-primitive-procedure 'UNDER-EMACS?)) - -(define (install!) - ((if (under-emacs?) - install-emacs-hooks! - install-normal-hooks!))) - -(add-event-receiver! event:after-restore install!) -(install!) - -;;; end EMACS-INTERFACE-PACKAGE -)) \ No newline at end of file diff --git a/v7/src/runtime/equals.scm b/v7/src/runtime/equals.scm deleted file mode 100644 index 8ed005d02..000000000 --- a/v7/src/runtime/equals.scm +++ /dev/null @@ -1,92 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/equals.scm,v 13.42 1987/03/17 18:49:17 cph Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Equality - -(declare (usual-integrations)) - -(let-syntax ((type? - ;; Use PRIMITIVE-TYPE? for everything because the - ;; compiler can optimize it well. - (macro (name object) - `(PRIMITIVE-TYPE? ,(microcode-type name) ,object)))) - -(define (eqv? x y) - ;; EQV? is officially supposed to work on booleans, characters, and - ;; numbers specially, but it turns out that EQ? does the right thing - ;; for everything but numbers, so we take advantage of that. - (if (eq? x y) - true - (and (primitive-type? (primitive-type x) y) - (or (and (or (type? big-fixnum y) - (type? big-flonum y)) - (= x y)) - (and (type? vector y) - (zero? (vector-length x)) - (zero? (vector-length y))))))) - -(define (equal? x y) - (if (eq? x y) - true - (and (primitive-type? (primitive-type x) y) - (cond ((or (type? big-fixnum y) - (type? big-flonum y)) - (= x y)) - ((type? list y) - (and (equal? (car x) (car y)) - (equal? (cdr x) (cdr y)))) - ((type? vector y) - (let ((size (vector-length x))) - (define (loop index) - (if (= index size) - true - (and (equal? (vector-ref x index) - (vector-ref y index)) - (loop (1+ index))))) - (and (= size (vector-length y)) - (loop 0)))) - ((type? cell y) - (equal? (cell-contents x) (cell-contents y))) - ((type? character-string y) - (string=? x y)) - ((type? vector-1b y) - (bit-string=? x y)) - (else false))))) - -) diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm deleted file mode 100644 index d6792dfaa..000000000 --- a/v7/src/runtime/error.scm +++ /dev/null @@ -1,512 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 13.46 1987/04/13 18:42:53 cph Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Error System - -(declare (usual-integrations) - (integrate-primitive-procedures set-fixed-objects-vector!)) - -(define error-procedure - (make-primitive-procedure 'ERROR-PROCEDURE)) - -(define (error-from-compiled-code message . irritant-info) - (error-procedure message - (cond ((null? irritant-info) *the-non-printing-object*) - ((null? (cdr irritant-info)) (car irritant-info)) - (else irritant-info)) - (rep-environment))) - -(define (error-message) - (access error-message error-system)) - -(define (error-irritant) - (access error-irritant error-system)) - -(define error-prompt - "Error->") - -(define error-system - (make-environment - -(define *error-code*) -(define *error-hook*) -(define *error-decision-hook* false) - -(define error-message - "") - -(define error-irritant - *the-non-printing-object*) - -;;;; REP Interface - -(define (error-procedure-handler message irritant environment) - (with-proceed-point - proceed-value-filter - (lambda () - (fluid-let ((error-message message) - (error-irritant irritant)) - (*error-hook* environment message irritant false))))) - -(define ((error-handler-wrapper handler) error-code interrupt-enables) - (with-interrupts-reduced interrupt-mask-gc-ok - (lambda (old-mask) - (fluid-let ((*error-code* error-code)) - (with-proceed-point - proceed-value-filter - (lambda () - (set-interrupt-enables! interrupt-enables) - (handler (continuation-expression (rep-continuation))))))))) - -(define (wrapped-error-handler wrapper) - (access handler (procedure-environment wrapper))) - -;;; (PROCEED) means retry error expression, (PROCEED value) means -;;; return VALUE as the value of the error subproblem. - -(define (proceed-value-filter value) - (let ((continuation (rep-continuation))) - (if (or (null? value) (null-continuation? continuation)) - (continuation '()) - ((continuation-next-continuation continuation) (car value))))) - -(define (start-error-rep message irritant) - (fluid-let ((error-message message) - (error-irritant irritant)) - (let ((environment (continuation-environment (rep-continuation)))) - (if (continuation-undefined-environment? environment) - (*error-hook* (rep-environment) message irritant true) - (*error-hook* environment message irritant false))))) - -(define (standard-error-hook environment message irritant - substitute-environment?) - (push-rep environment - (let ((message (make-error-message message irritant))) - (if substitute-environment? - (lambda () - (message) - (write-string " -There is no environment available; -using the current read-eval-print environment.")) - message)) - (standard-rep-prompt error-prompt))) - -(define ((make-error-message message irritant)) - (newline) - (write-string message) - (if (not (eq? irritant *the-non-printing-object*)) - (let ((out (write-to-string irritant 40))) - (write-char #\Space) - (write-string (cdr out)) - (if (car out) (write-string "...")))) - (if *error-decision-hook* (*error-decision-hook*))) - -;;;; Error Handlers - -;;; All error handlers have the following form: - -(define ((make-error-handler direction-alist operator-alist - default-handler default-combination-handler) - expression) - ((let direction-loop ((alist direction-alist)) - (cond ((null? alist) - (cond ((combination? expression) - (let ((operator (combination-operator* expression))) - (let operator-loop ((alist operator-alist)) - (cond ((null? alist) default-combination-handler) - ((memq operator (caar alist)) (cdar alist)) - (else (operator-loop (cdr alist))))))) - (else default-handler))) - (((caar alist) expression) (cdar alist)) - (else (direction-loop (cdr alist))))) - expression)) - -;;; Then there are several methods for modifying the behavior of a -;;; given error handler. - -(define expression-specific-adder) -(define operation-specific-adder) - -(let () - (define (((alist-adder name) error-handler) filter receiver) - (let ((environment - (procedure-environment (wrapped-error-handler error-handler)))) - (lexical-assignment environment - name - (cons (cons filter receiver) - (lexical-reference environment name))))) - - (set! expression-specific-adder - (alist-adder 'DIRECTION-ALIST)) - (set! operation-specific-adder - (alist-adder 'OPERATOR-ALIST))) - -(define default-expression-setter) -(define default-combination-setter) - -(let () - (define (((set-default name) error-handler) receiver) - (lexical-assignment - (procedure-environment (wrapped-error-handler error-handler)) - name - receiver)) - - (set! default-expression-setter - (set-default 'DEFAULT-HANDLER)) - (set! default-combination-setter - (set-default 'DEFAULT-COMBINATION-HANDLER))) - -;;;; Error Vector - -;;; Initialize the error vector to the default state: - -(define (error-code-or-name code) - (let ((v (vector-ref (get-fixed-objects-vector) - (fixed-objects-vector-slot 'MICROCODE-ERRORS-VECTOR)))) - (if (or (>= code (vector-length v)) - (null? (vector-ref v code))) - code - (vector-ref v code)))) - -(define (default-error-handler expression) - (start-error-rep "Anomalous error -- get a wizard" - (error-code-or-name *error-code*))) - -(define system-error-vector - (make-initialized-vector number-of-microcode-errors - (lambda (error-code) - (error-handler-wrapper - (make-error-handler '() - '() - default-error-handler - default-error-handler))))) - -;;; Use this procedure to displace the default handler completely. - -(define (define-total-error-handler error-name handler) - (vector-set! system-error-vector - (microcode-error error-name) - (error-handler-wrapper handler))) - -;;; It will be installed later. - -(define (install) - (set! *error-hook* standard-error-hook) - (vector-set! (get-fixed-objects-vector) - (fixed-objects-vector-slot 'SYSTEM-ERROR-VECTOR) - system-error-vector) - (vector-set! (get-fixed-objects-vector) - (fixed-objects-vector-slot 'ERROR-PROCEDURE) - error-procedure-handler) - (vector-set! (get-fixed-objects-vector) - (fixed-objects-vector-slot 'COMPILER-ERROR-PROCEDURE) - error-from-compiled-code) - (set-fixed-objects-vector! (get-fixed-objects-vector))) - -;;;; Error Definers - -(define ((define-definer type definer) error-name . args) - (apply definer - (type (vector-ref system-error-vector (microcode-error error-name))) - args)) - -(define ((define-specific-error error-name message) filter selector) - ((cond ((pair? filter) define-operation-specific-error) - (else define-expression-specific-error)) - error-name filter message selector)) - -(define define-expression-specific-error - (define-definer expression-specific-adder - (lambda (adder filter message selector) - (adder filter (expression-error-rep message selector))))) - -(define define-operation-specific-error - (define-definer operation-specific-adder - (lambda (adder filter message selector) - (adder filter (combination-error-rep message selector))))) - -(define define-operand-error - (define-definer default-combination-setter - (lambda (setter message selector) - (setter (combination-error-rep message selector))))) - -(define define-operator-error - (define-definer default-combination-setter - (lambda (setter message) - (setter (expression-error-rep message combination-operator*))))) - -(define define-combination-error - (define-definer default-combination-setter - (lambda (setter message selector) - (setter (expression-error-rep message selector))))) - -(define define-default-error - (define-definer default-expression-setter - (lambda (setter message selector) - (setter (expression-error-rep message selector))))) - -(define ((expression-error-rep message selector) expression) - (start-error-rep message (selector expression))) - -(define ((combination-error-rep message selector) combination) - (start-error-rep - (string-append message " " - (let ((out (write-to-string (selector combination) 40))) - (if (car out) - (string-append (cdr out) "...") - (cdr out))) - "\nwithin procedure") - (combination-operator* combination))) - -;;;; Combination Operations - -;;; Combinations coming out of the continuation parser are either all -;;; unevaluated, or all evaluated, or all operands evaluated and the -;;; operator undefined. Thus we must be careful about unwrapping -;;; the components when necessary. In practice, it turns out that -;;; all but one of the interesting errors happen at the application -;;; point, at which all of the combination's components are evaluated. - -(define (combination-operator* combination) - (unwrap-evaluated-object (combination-operator combination))) - -(define ((combination-operand selector) combination) - (unwrap-evaluated-object (selector (combination-operands combination)))) - -(define combination-first-operand (combination-operand first)) -(define combination-second-operand (combination-operand second)) -(define combination-third-operand (combination-operand third)) - -(define (combination-operands* combination) - (map unwrap-evaluated-object (combination-operands combination))) - -(define (unwrap-evaluated-object object) - (if (continuation-evaluated-object? object) - (continuation-evaluated-object-value object) - (error "Not evaluated -- get a wizard" unwrap-evaluated-object object))) - -;;;; Environment Operation Errors - -(define define-unbound-variable-error - (define-specific-error 'UNBOUND-VARIABLE - "Unbound Variable")) - -(define-unbound-variable-error variable? variable-name) -(define-unbound-variable-error access? access-name) -(define-unbound-variable-error assignment? assignment-name) -(define-unbound-variable-error - (list (make-primitive-procedure 'LEXICAL-REFERENCE) - (make-primitive-procedure 'LEXICAL-ASSIGNMENT)) - combination-second-operand) - -(define-unbound-variable-error - (list (make-primitive-procedure 'ADD-FLUID-BINDING! true)) - (lambda (obj) - (let ((object (combination-second-operand obj))) - (cond ((variable? object) (variable-name object)) - ((symbol? object) object) - (else (error "Handler has bad object -- GET-A-WIZARD" object)))))) - -(define define-unassigned-variable-error - (define-specific-error 'UNASSIGNED-VARIABLE - "Unassigned Variable")) - -(define-unassigned-variable-error variable? variable-name) -(define-unassigned-variable-error access? access-name) -(define-unassigned-variable-error - (list (make-primitive-procedure 'LEXICAL-REFERENCE)) - combination-second-operand) - -(define define-bad-frame-error - (define-specific-error 'BAD-FRAME - "Illegal Environment Frame")) - -(define-bad-frame-error access? access-environment) -(define-bad-frame-error in-package? in-package-environment) - -#| -(define define-assignment-to-procedure-error - (define-specific-error 'ASSIGN-LAMBDA-NAME - "Attempt to assign procedure's name")) - -(define-assignment-to-procedure-error assignment? assignment-name) -(define-assignment-to-procedure-error definition? definition-name) -(define-assignment-to-procedure-error - (list (make-primitive-procedure 'LEXICAL-ASSIGNMENT) - (make-primitive-procedure 'LOCAL-ASSIGNMENT) - (make-primitive-procedure 'ADD-FLUID-BINDING! true) - (make-primitive-procedure 'MAKE-FLUID-BINDING! true)) - combination-second-operand) -|# - -;;;; Application Errors - -(define-operator-error 'UNDEFINED-PROCEDURE - "Application of Non-Procedure Object") - -(define-operator-error 'UNDEFINED-PRIMITIVE-OPERATION - "Undefined Primitive Procedure") - -(define-operator-error 'UNIMPLEMENTED-PRIMITIVE - "Unimplemented Primitive Procedure") - -(define-operand-error 'WRONG-NUMBER-OF-ARGUMENTS - "Wrong Number of Arguments" - (lambda (combination) - (length (combination-operands* combination)))) - -(let ((make - (lambda (wta-error-code bra-error-code position-string - position-selector) - (let ((ap-string (string-append position-string " argument position")) - (selector (combination-operand position-selector))) - (define-operand-error wta-error-code - (string-append "Illegal datum in " ap-string) - selector) - (define-operand-error bra-error-code - (string-append "Datum out of range in " ap-string) - selector))))) - (make 'WRONG-TYPE-ARGUMENT-0 'BAD-RANGE-ARGUMENT-0 "first" first) - (make 'WRONG-TYPE-ARGUMENT-1 'BAD-RANGE-ARGUMENT-1 "second" second) - (make 'WRONG-TYPE-ARGUMENT-2 'BAD-RANGE-ARGUMENT-2 "third" third) - (make 'WRONG-TYPE-ARGUMENT-3 'BAD-RANGE-ARGUMENT-3 "fourth" fourth) - (make 'WRONG-TYPE-ARGUMENT-4 'BAD-RANGE-ARGUMENT-4 "fifth" fifth) - (make 'WRONG-TYPE-ARGUMENT-5 'BAD-RANGE-ARGUMENT-5 "sixth" sixth) - (make 'WRONG-TYPE-ARGUMENT-6 'BAD-RANGE-ARGUMENT-6 "seventh" seventh) - (make 'WRONG-TYPE-ARGUMENT-7 'BAD-RANGE-ARGUMENT-7 "eighth" eighth) - (make 'WRONG-TYPE-ARGUMENT-8 'BAD-RANGE-ARGUMENT-8 - "ninth" (lambda (list) (general-car-cdr list #x1400))) - (make 'WRONG-TYPE-ARGUMENT-9 'BAD-RANGE-ARGUMENT-9 - "tenth" (lambda (list) (general-car-cdr list #x3000)))) - -(define-operand-error 'FAILED-ARG-1-COERCION - "Argument 1 cannot be coerced to floating point" - combination-first-operand) - -(define-operand-error 'FAILED-ARG-2-COERCION - "Argument 2 cannot be coerced to floating point" - combination-second-operand) - -;;;; Primitive Operator Errors - -(define-operation-specific-error 'FASL-FILE-TOO-BIG - (list (make-primitive-procedure 'BINARY-FASLOAD)) - "Not enough room to Fasload" - combination-first-operand) - -(define-operation-specific-error 'FASL-FILE-BAD-DATA - (list (make-primitive-procedure 'BINARY-FASLOAD)) - "Fasload file would not relocate correctly" - combination-first-operand) - -#| -(define-operation-specific-error 'RAN-OUT-OF-HASH-NUMBERS - (list (make-primitive-procedure 'OBJECT-HASH)) - "Hashed too many objects -- get a wizard" - combination-first-operand) -|# - -;;; This will trap any external-primitive errors that -;;; aren't caught by special handlers. - -(define-operator-error 'EXTERNAL-RETURN - "Error during External Application") - -(define-operation-specific-error 'EXTERNAL-RETURN - (list (make-primitive-procedure 'FILE-OPEN-CHANNEL)) - "Unable to open file" - combination-first-operand) - -(define-operation-specific-error 'OUT-OF-FILE-HANDLES - (list (make-primitive-procedure 'FILE-OPEN-CHANNEL)) - "Too many open files" - combination-first-operand) - -;;;; SCODE Syntax Errors - -;;; This error gets an unevaluated combination, but it doesn't ever -;;; look at the components, so it doesn't matter. - -(define define-broken-variable-error - (define-specific-error 'BROKEN-CVARIABLE - "Broken Compiled Variable -- get a wizard")) - -(define-broken-variable-error variable? variable-name) -(define-broken-variable-error assignment? assignment-name) - -;;;; System Errors - -(define-total-error-handler 'BAD-ERROR-CODE - (lambda (error-code) - (start-error-rep "Bad Error Code -- get a wizard" - (error-code-or-name error-code)))) - -(define-default-error 'BAD-INTERRUPT-CODE - "Illegal Interrupt Code -- get a wizard" - identity-procedure) - -(define-default-error 'EXECUTE-MANIFEST-VECTOR - "Attempt to execute Manifest Vector -- get a wizard" - identity-procedure) - -(define-total-error-handler 'WRITE-INTO-PURE-SPACE - (lambda (error-code) - (newline) - (write-string "Automagically IMPURIFYing an object....") - (impurify (combination-first-operand - (continuation-expression (rep-continuation)))))) - -(define-default-error 'UNDEFINED-USER-TYPE - "Undefined Type Code -- get a wizard" - identity-procedure) - -(define-default-error 'INAPPLICABLE-CONTINUATION - "Inapplicable continuation -- get a wizard" - identity-procedure) - -(define-default-error 'COMPILED-CODE-ERROR - "Compiled code error -- get a wizard" - identity-procedure) - -(define-default-error 'FLOATING-OVERFLOW - "Floating point overflow" - identity-procedure) - -;;; end ERROR-SYSTEM package. -)) \ No newline at end of file diff --git a/v7/src/runtime/events.scm b/v7/src/runtime/events.scm deleted file mode 100644 index e373644e5..000000000 --- a/v7/src/runtime/events.scm +++ /dev/null @@ -1,97 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/events.scm,v 13.42 1987/03/17 18:49:40 cph Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Event Distribution - -(declare (usual-integrations)) - -(define make-event-distributor) -(define event-distributor?) -(define add-event-receiver!) -(define remove-event-receiver!) - -(let ((:type (make-named-tag "EVENT-DISTRIBUTOR"))) - (set! make-event-distributor - (named-lambda (make-event-distributor) - (define receivers '()) - (define queue-head '()) - (define queue-tail '()) - (define event-in-progress? false) - (lambda arguments - (if (null? queue-head) - (begin (set! queue-head (list arguments)) - (set! queue-tail queue-head)) - (begin (set-cdr! queue-tail (list arguments)) - (set! queue-tail (cdr queue-tail)))) - (if (not (set! event-in-progress? true)) - (begin (let ((arguments (car queue-head))) - (set! queue-head (cdr queue-head)) - (let loop ((receivers receivers)) - (if (not (null? receivers)) - (begin (apply (car receivers) arguments) - (loop (cdr receivers)))))) - (set! event-in-progress? false)))))) - - (set! event-distributor? - (named-lambda (event-distributor? object) - (and (compound-procedure? object) - (let ((e (procedure-environment object))) - (and (not (lexical-unreferenceable? e ':TYPE)) - (eq? (access :type e) :type) - e))))) - - (define ((make-receiver-modifier name operation) - event-distributor event-receiver) - (let ((e (event-distributor? event-distributor))) - (if (not e) - (error "Not an event distributor" name event-distributor)) - (without-interrupts - (lambda () - (set! (access receivers e) - (operation event-receiver (access receivers e))))))) - - (set! add-event-receiver! - (make-receiver-modifier 'ADD-EVENT-RECEIVER! - (lambda (receiver receivers) - (append! receivers (list receiver))))) - - (set! remove-event-receiver! - (make-receiver-modifier 'REMOVE-EVENT-RECEIVER! delq!)) - -) \ No newline at end of file diff --git a/v7/src/runtime/format.scm b/v7/src/runtime/format.scm deleted file mode 100644 index 42536804f..000000000 --- a/v7/src/runtime/format.scm +++ /dev/null @@ -1,351 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/format.scm,v 13.42 1987/03/17 18:49:48 cph Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Output Formatter - -(declare (usual-integrations)) - -;;; Please don't believe this implementation! I don't like either the -;;; calling interface or the control string syntax, but I need the -;;; functionality pretty badly and I don't have the time to think -;;; about all of that right now -- CPH. - -(define format) -(let () - -;;;; Top Level - -(set! format -(named-lambda (format port-or-string . arguments) - (cond ((null? port-or-string) - (if (and (not (null? arguments)) - (string? (car arguments))) - (with-output-to-string - (lambda () - (format-start (car arguments) (cdr arguments)))) - (error "Missing format string" 'FORMAT))) - ((string? port-or-string) - (format-start port-or-string arguments) - *the-non-printing-object*) - ((output-port? port-or-string) - (if (and (not (null? arguments)) - (string? (car arguments))) - (begin (with-output-to-port port-or-string - (lambda () - (format-start (car arguments) (cdr arguments)))) - *the-non-printing-object*) - (error "Missing format string" 'FORMAT))) - (else - (error "Unrecognizable first argument" 'FORMAT - port-or-string))))) - -(define (format-start string arguments) - (format-loop string arguments) - ((access :flush-output *current-output-port*))) - -(declare (integrate *unparse-char *unparse-string *unparse-object)) - -(define (*unparse-char char) - (declare (integrate char)) - ((access :write-char *current-output-port*) char)) - -(define (*unparse-string string) - (declare (integrate string)) - ((access :write-string *current-output-port*) string)) - -(define (*unparse-object object) - (declare (integrate object)) - ((access unparse-object unparser-package) object *current-output-port*)) - -(define (format-loop string arguments) - (let ((index (string-find-next-char string #\~))) - (cond (index - (if (not (zero? index)) - (*unparse-string (substring string 0 index))) - (parse-dispatch (string-tail string (1+ index)) - arguments - '() - '() - (lambda (remaining-string remaining-arguments) - (format-loop remaining-string - remaining-arguments)))) - ((null? arguments) - (*unparse-string string)) - (else - (error "Too many arguments" 'FORMAT arguments))))) - -(define (parse-dispatch string supplied-arguments parsed-arguments modifiers - receiver) - ((vector-ref format-dispatch-table (vector-8b-ref string 0)) - string - supplied-arguments - parsed-arguments - modifiers - receiver)) - -;;;; Argument Parsing - -(define ((format-wrapper operator) - string supplied-arguments parsed-arguments modifiers receiver) - ((apply operator modifiers (reverse! parsed-arguments)) - (string-tail string 1) - supplied-arguments - receiver)) - -(define ((parse-modifier keyword) - string supplied-arguments parsed-arguments modifiers receiver) - (parse-dispatch (string-tail string 1) - supplied-arguments - parsed-arguments - (cons keyword modifiers) - receiver)) - -(define (parse-digit string supplied-arguments parsed-arguments modifiers - receiver) - (let accumulate ((acc (char->digit (string-ref string 0) 10)) (i 1)) - (if (char-numeric? (string-ref string i)) - (accumulate (+ (* acc 10) (char->digit (string-ref string i) 10)) - (1+ i)) - (parse-dispatch (string-tail string i) - supplied-arguments - (cons acc parsed-arguments) - modifiers - receiver)))) - -(define (parse-ignore string supplied-arguments parsed-arguments modifiers - receiver) - (parse-dispatch (string-tail string 1) supplied-arguments parsed-arguments - modifiers receiver)) - -(define (parse-arity string supplied-arguments parsed-arguments modifiers - receiver) - (parse-dispatch (string-tail string 1) - supplied-arguments - (cons (length supplied-arguments) parsed-arguments) - modifiers - receiver)) - -(define (parse-argument string supplied-arguments parsed-arguments modifiers - receiver) - (parse-dispatch (string-tail string 1) - (cdr supplied-arguments) - (cons (car supplied-arguments) parsed-arguments) - modifiers - receiver)) - -(define (string-tail string index) - (substring string index (string-length string))) - -;;;; Formatters - -(define (((format-insert-character character) modifiers #!optional n) - string arguments receiver) - (if (unassigned? n) - (*unparse-char character) - (let loop ((i 0)) - (if (not (= i n)) - (begin (*unparse-char character) - (loop (1+ i)))))) - (receiver string arguments)) - -(define format-insert-return (format-insert-character char:newline)) -(define format-insert-tilde (format-insert-character #\~)) -(define format-insert-space (format-insert-character #\Space)) - -(define ((format-ignore-comment modifiers) string arguments receiver) - (receiver (substring string - (1+ (string-find-next-char string char:newline)) - (string-length string)) - arguments)) - -(define format-ignore-whitespace) -(let () - -(define newline-string - (char->string char:newline)) - -(define (eliminate-whitespace string) - (let ((limit (string-length string))) - (let loop ((n 0)) - (cond ((= n limit) "") - ((let ((char (string-ref string n))) - (and (char-whitespace? char) - (not (char=? char char:newline)))) - (loop (1+ n))) - (else - (substring string n limit)))))) - -(set! format-ignore-whitespace -(named-lambda ((format-ignore-whitespace modifiers) string arguments receiver) - (receiver (cond ((null? modifiers) (eliminate-whitespace string)) - ((memq 'AT modifiers) - (string-append newline-string - (eliminate-whitespace string))) - (else string)) - arguments))) -) - -(define ((format-string modifiers #!optional n-columns) - string arguments receiver) - (if (null? arguments) - (error "Too few arguments" 'FORMAT string)) - (if (unassigned? n-columns) - (*unparse-string (car arguments)) - (unparse-string-into-fixed-size (car arguments) false - n-columns modifiers)) - (receiver string (cdr arguments))) - -(define ((format-object modifiers #!optional n-columns) - string arguments receiver) - (if (null? arguments) - (error "Too few arguments" 'FORMAT string)) - (if (unassigned? n-columns) - (*unparse-object (car arguments)) - (unparse-object-into-fixed-size (car arguments) n-columns modifiers)) - (receiver string (cdr arguments))) - -(define ((format-code modifiers #!optional n-columns) - string arguments receiver) - (if (null? arguments) - (error "Too few arguments" 'FORMAT string)) - (if (unassigned? n-columns) - (*unparse-object (unsyntax (car arguments))) - (unparse-object-into-fixed-size (unsyntax (car arguments)) - n-columns - modifiers)) - (receiver string (cdr arguments))) - -(define (unparse-object-into-fixed-size object n-columns modifiers) - (let ((output (write-to-string object n-columns))) - (unparse-string-into-fixed-size (cdr output) - (car output) - n-columns - modifiers))) - -(define (unparse-string-into-fixed-size string already-truncated? - n-columns modifiers) - (let ((padding (- n-columns (string-length string)))) - (cond ((and (zero? padding) (not already-truncated?)) - (*unparse-string string)) - ((positive? padding) - (let ((pad-string (make-string padding #\Space))) - (if (memq 'AT modifiers) - (begin (*unparse-string string) - (*unparse-string pad-string)) - (begin (*unparse-string pad-string) - (*unparse-string string))))) - ;; This is pretty random -- figure out something better. - ((memq 'COLON modifiers) - (*unparse-string (substring string 0 (- n-columns 4))) - (*unparse-string " ...")) - (else (*unparse-string (substring string 0 n-columns)))))) - -;;;; Dispatcher Setup - -(define format-dispatch-table - (make-initialized-vector - 128 - (lambda (character) - (lambda (string supplied-arguments parsed-arguments modifiers receiver) - (error "Unknown formatting character" 'FORMAT character))))) - -(define (add-dispatcher! char dispatcher) - (if (char-alphabetic? char) - (begin (vector-set! format-dispatch-table - (char->ascii (char-downcase char)) - dispatcher) - (vector-set! format-dispatch-table - (char->ascii (char-upcase char)) - dispatcher)) - (vector-set! format-dispatch-table - (char->ascii char) - dispatcher))) - -(add-dispatcher! #\0 parse-digit) -(add-dispatcher! #\1 parse-digit) -(add-dispatcher! #\2 parse-digit) -(add-dispatcher! #\3 parse-digit) -(add-dispatcher! #\4 parse-digit) -(add-dispatcher! #\5 parse-digit) -(add-dispatcher! #\6 parse-digit) -(add-dispatcher! #\7 parse-digit) -(add-dispatcher! #\8 parse-digit) -(add-dispatcher! #\9 parse-digit) -(add-dispatcher! #\, parse-ignore) -(add-dispatcher! #\# parse-arity) -(add-dispatcher! #\V parse-argument) -(add-dispatcher! #\@ (parse-modifier 'AT)) -(add-dispatcher! #\: (parse-modifier 'COLON)) - -;;; -;;; (format format-string arg arg ...) -;;; (format port format-string arg arg ...) -;;; -;;; Format strings are normally interpreted literally, except that -;;; certain escape sequences allow insertion of computed values. The -;;; following escape sequences are recognized: -;;; -;;; ~n% inserts n newlines -;;; ~n~ inserts n tildes -;;; ~nX inserts n spaces -;;; -;;; ~ inserts the next argument. -;;; ~n right justifies the argument in a field of size n. -;;; ~n@ left justifies the argument in a field of size n. -;;; -;;; where may be: -;;; S meaning the argument is a string and should be used literally. -;;; O meaning the argument is an object and should be printed first. -;;; C meaning the object is SCode and should be unsyntaxed and printed. -;;; -;;; If the resulting string is too long, it is truncated. -;;; ~n: or ~n:@ means print trailing dots when truncating. -;;; - -(add-dispatcher! #\% (format-wrapper format-insert-return)) -(add-dispatcher! #\~ (format-wrapper format-insert-tilde)) -(add-dispatcher! #\X (format-wrapper format-insert-space)) -(add-dispatcher! #\; (format-wrapper format-ignore-comment)) -(add-dispatcher! char:newline (format-wrapper format-ignore-whitespace)) -(add-dispatcher! #\S (format-wrapper format-string)) -(add-dispatcher! #\O (format-wrapper format-object)) -(add-dispatcher! #\C (format-wrapper format-code)) - -;;; end LET. -) \ No newline at end of file diff --git a/v7/src/runtime/gc.scm b/v7/src/runtime/gc.scm deleted file mode 100644 index 9af65598a..000000000 --- a/v7/src/runtime/gc.scm +++ /dev/null @@ -1,204 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gc.scm,v 13.43 1987/03/18 20:07:23 jinx Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Garbage Collector - -(declare (usual-integrations) - (integrate-primitive-procedures - garbage-collect primitive-purify primitive-impurify primitive-fasdump - set-interrupt-enables! enable-interrupts! primitive-gc-type pure? - get-next-constant call-with-current-continuation hunk3-cons - set-fixed-objects-vector! tty-write-char tty-write-string exit)) - -(define add-gc-daemon!) -(define gc-flip) -(define purify) -(define impurify) -(define fasdump) -(define suspend-world) -(define set-default-gc-safety-margin!) - -(define garbage-collector-package - (make-environment - -(define default-safety-margin 4500) - -;; SET-DEFAULT-GC-SAFETY-MARGIN! changes the amount of memory -;; saved from the heap to allow the GC handler to run. - -(set! set-default-gc-safety-margin! -(named-lambda (set-default-gc-safety-margin! #!optional margin) - (if (or (unassigned? margin) (null? margin)) - default-safety-margin - (begin (set! default-safety-margin margin) - (gc-flip margin))))) - -;;;; Cold Load GC - -(define (reset) - (enable-interrupts! interrupt-mask-none)) - -;;; User call -- optionally overrides the default GC safety -;;; margin for this flip only. - -(set! gc-flip -(named-lambda (gc-flip #!optional new-safety-margin) - (with-interrupts-reduced interrupt-mask-none - (lambda (old-interrupt-mask) - (garbage-collect - (if (unassigned? new-safety-margin) - default-safety-margin - new-safety-margin)))))) - -(vector-set! (vector-ref (get-fixed-objects-vector) 1) - 2 ;Local Garbage Collection Interrupt - (named-lambda (gc-interrupt interrupt-code interrupt-enables) - (gc-flip Default-Safety-Margin))) - -(vector-set! (vector-ref (get-fixed-objects-vector) 1) - 0 ;Local Stack Overflow Interrupt - (named-lambda (stack-overflow-interrupt interrupt-code - interrupt-enables) - (stack-overflow) - (set-interrupt-enables! interrupt-enables))) - -;;; This variable is clobbered by GCSTAT. -(define (stack-overflow) - (tty-write-char char:newline) - (tty-write-string "Stack overflow!") - (tty-write-char char:newline) - (exit)) - -(vector-set! (get-fixed-objects-vector) - #x0C - (named-lambda (hardware-trap-handler escape-code) - (hardware-trap))) - -;;; This is clobbered also by GCSTAT. -(define (hardware-trap) - (tty-write-char char:newline) - (tty-write-string "Hardware trap") - (tty-write-char char:newline) - (exit)) - -;;; The GC daemon is invoked by the microcode whenever there is a need. -;;; All we provide here is a trivial extension mechanism. - -(vector-set! (get-fixed-objects-vector) - #x0B - (named-lambda (gc-daemon) - (trigger-daemons gc-daemons))) - -(set-fixed-objects-vector! (get-fixed-objects-vector)) - -(define (trigger-daemons daemons . extra-args) - (let loop ((daemons daemons)) - (if (not (null? daemons)) - (begin (apply (car daemons) extra-args) - (loop (cdr daemons)))))) - -(define gc-daemons '()) - -(set! add-gc-daemon! -(named-lambda (add-gc-daemon! daemon) - (if (not (memq daemon gc-daemons)) - (set! gc-daemons (cons daemon gc-daemons))))) - -(reset) - -;;;; "GC-like" Primitives - -;; Purify an item -- move it into pure space and clean everything -;; by doing a gc-flip - -(set! purify -(named-lambda (purify item #!optional really-pure?) - (if (primitive-purify item - (if (unassigned? really-pure?) - false - really-pure?)) - item - (error "Not enough room in constant space" purify item)))) - -(set! impurify -(named-lambda (impurify object) - (if (or (zero? (primitive-gc-type object)) - (not (pure? object))) - object - (primitive-impurify object)))) - -(set! fasdump -(named-lambda (fasdump object filename) - (let ((filename (canonicalize-output-filename filename)) - (port (rep-output-port))) - (newline port) - (write-string "FASDumping " port) - (write filename port) - (if (not (primitive-fasdump object filename false)) - (error "Object is too large to be dumped" fasdump object)) - (write-string " -- done" port)) - object)) - -(set! suspend-world -(named-lambda (suspend-world suspender after-suspend after-restore) - (with-interrupts-reduced interrupt-mask-gc-ok - (lambda (ie) - ((call-with-current-continuation - (lambda (cont) - (let ((fixed-objects-vector (get-fixed-objects-vector)) - (dynamic-state (current-dynamic-state))) - (fluid-let () - (call-with-current-continuation - (lambda (restart) - (gc-flip) - (suspender restart) - (cont after-suspend))) - (set-fixed-objects-vector! fixed-objects-vector) - (set-current-dynamic-state! dynamic-state) - (reset) - ((access snarf-version microcode-system)) - (reset-keyboard-interrupt-dispatch-table!) - (set! *rep-keyboard-map* (keyboard-interrupt-dispatch-table)) - ((access reset! primitive-io)) - ((access reset! working-directory-package)) - after-restore)))) - ie))))) - -;;; end GARBAGE-COLLECTOR-PACKAGE. -)) diff --git a/v7/src/runtime/gcstat.scm b/v7/src/runtime/gcstat.scm deleted file mode 100644 index ac86593f3..000000000 --- a/v7/src/runtime/gcstat.scm +++ /dev/null @@ -1,272 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcstat.scm,v 13.43 1987/04/13 18:43:38 cph Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; GC Statistics - -(declare (usual-integrations)) - -(define gctime) -(define gc-statistics) -(define gc-history-mode) - -(define gc-statistics-package - (make-environment - -;;;; Statistics Hooks - -(define (gc-start-hook) 'DONE) -(define (gc-finish-hook state) 'DONE) - -(define ((make-flip-hook old-flip) . More) - (with-interrupts-reduced interrupt-mask-none - (lambda (Old-Interrupt-Mask) - (measure-interval - false ;i.e. do not count the interval in RUNTIME. - (lambda (start-time) - (let ((old-state (gc-start-hook))) - (let ((new-space-remaining (primitive-datum (apply old-flip more)))) - (gc-finish-hook old-state) - (if (< new-space-remaining 4096) - (abort->nearest - (standard-rep-message "Aborting: Out of memory!"))) - (lambda (end-time) - (statistics-flip start-time - end-time - new-space-remaining) - new-space-remaining)))))))) - -;;;; Statistics Collector - -(define meter) -(define total-gc-time) -(define last-gc-start) -(define last-gc-end) - -(define (statistics-reset!) - (set! meter 1) - (set! total-gc-time 0) - (set! last-gc-start false) - (set! last-gc-end (system-clock)) - (reset-recorder! '())) - -(define (statistics-flip start-time end-time heap-left) - (let ((statistic - (vector meter - start-time end-time - last-gc-start last-gc-end - heap-left))) - (set! meter (1+ meter)) - (set! total-gc-time (+ (- end-time start-time) total-gc-time)) - (set! last-gc-start start-time) - (set! last-gc-end end-time) - (record-statistic! statistic))) - -(set! gctime (named-lambda (gctime) total-gc-time)) - -;;;; Statistics Recorder - -(define last-statistic) -(define history) - -(define (reset-recorder! old) - (set! last-statistic false) - (reset-history! old)) - -(define (record-statistic! statistic) - (set! last-statistic statistic) - (record-in-history! statistic)) - -(set! gc-statistics - (named-lambda (gc-statistics) - (let ((history (get-history))) - (if (null? history) - (if last-statistic - (list last-statistic) - '()) - history)))) - -;;;; History Modes - -(define reset-history!) -(define record-in-history!) -(define get-history) -(define history-mode) - -(set! gc-history-mode - (named-lambda (gc-history-mode #!optional new-mode) - (let ((old-mode history-mode)) - (if (not (unassigned? new-mode)) - (let ((old-history (get-history))) - (set-history-mode! new-mode) - (reset-history! old-history))) - old-mode))) - -(define (set-history-mode! mode) - (let ((entry (assq mode history-modes))) - (if (not entry) - (error "Bad mode name" 'SET-HISTORY-MODE! mode)) - ((cdr entry)) - (set! history-mode (car entry)))) - -(define history-modes - `((NONE . ,(named-lambda (none:install-history!) - (set! reset-history! none:reset-history!) - (set! record-in-history! none:record-in-history!) - (set! get-history none:get-history))) - (BOUNDED . ,(named-lambda (bounded:install-history!) - (set! reset-history! bounded:reset-history!) - (set! record-in-history! bounded:record-in-history!) - (set! get-history bounded:get-history))) - (UNBOUNDED . ,(named-lambda (unbounded:install-history!) - (set! reset-history! unbounded:reset-history!) - (set! record-in-history! unbounded:record-in-history!) - (set! get-history unbounded:get-history))))) - -;;; NONE - -(define (none:reset-history! old) - (set! history '())) - -(define (none:record-in-history! item) - 'DONE) - -(define (none:get-history) - '()) - -;;; BOUNDED - -(define history-size 8) - -(define (copy-to-size l size) - (let ((max (length l))) - (if (>= max size) - (initial-segment l size) - (append (initial-segment l max) - (make-list (- size max) '()))))) - -(define (bounded:reset-history! old) - (set! history (apply circular-list (copy-to-size old history-size)))) - -(define (bounded:record-in-history! item) - (set-car! history item) - (set! history (cdr history))) - -(define (bounded:get-history) - (let loop ((scan (cdr history))) - (cond ((eq? scan history) '()) - ((null? (car scan)) (loop (cdr scan))) - (else (cons (car scan) (loop (cdr scan))))))) - -;;; UNBOUNDED - -(define (unbounded:reset-history! old) - (set! history old)) - -(define (unbounded:record-in-history! item) - (set! history (cons item history))) - -(define (unbounded:get-history) - (reverse history)) - -;;;; Initialization - -(define (install!) - (set-history-mode! 'BOUNDED) - (statistics-reset!) - (set! gc-flip (make-flip-hook gc-flip)) - (set! (access stack-overflow garbage-collector-package) - (named-lambda (stack-overflow) - (abort->nearest - (standard-rep-message - "Aborting: Maximum recursion depth exceeded!")))) - (set! (access hardware-trap garbage-collector-package) - (named-lambda (hardware-trap) - (abort->nearest - (standard-rep-message - "Aborting: The hardware trapped!")))) - (add-event-receiver! event:after-restore statistics-reset!)) - -;;; end GC-STATISTICS-PACKAGE. -)) - -;;;; GC Notification - -(define toggle-gc-notification!) -(define print-gc-statistics) -(let () - -(define normal-recorder '()) - -(define (gc-notification statistic) - (normal-recorder statistic) - (with-output-to-port (rep-output-port) - (lambda () - (print-statistic statistic)))) - -(set! toggle-gc-notification! -(named-lambda (toggle-gc-notification!) - (if (null? normal-recorder) - (begin (set! normal-recorder - (access record-statistic! gc-statistics-package)) - (set! (access record-statistic! gc-statistics-package) - gc-notification)) - (begin (set! (access record-statistic! gc-statistics-package) - normal-recorder) - (set! normal-recorder '()))) - *the-non-printing-object*)) - -(set! print-gc-statistics -(named-lambda (print-gc-statistics) - (for-each print-statistic (gc-statistics)))) - -(define (print-statistic statistic) - (apply (lambda (meter - this-gc-start this-gc-end - last-gc-start last-gc-end - heap-left) - (let ((delta-time (- this-gc-end this-gc-start))) - (newline) (write-string "GC #") (write meter) - (write-string " took: ") (write delta-time) - (write-string " (") - (write (round (* (/ delta-time (- this-gc-end last-gc-end)) - 100))) - (write-string "%) free: ") (write heap-left))) - (vector->list statistic))) - -) \ No newline at end of file diff --git a/v7/src/runtime/gensym.scm b/v7/src/runtime/gensym.scm deleted file mode 100644 index a4ca4f2d6..000000000 --- a/v7/src/runtime/gensym.scm +++ /dev/null @@ -1,71 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gensym.scm,v 13.41 1987/01/23 00:13:48 jinx Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; GENSYM - -(declare (usual-integrations)) - -(define (make-name-generator prefix) - (let ((counter 0)) - (named-lambda (name-generator) - (string->uninterned-symbol - (string-append prefix - (write-to-string - (let ((n counter)) - (set! counter (1+ counter)) - n))))))) - -(define generate-uninterned-symbol - (let ((name-counter 0) - (name-prefix "G")) - (define (get-number) - (let ((result name-counter)) - (set! name-counter (1+ name-counter)) - result)) - (named-lambda (generate-uninterned-symbol #!optional argument) - (if (not (unassigned? argument)) - (cond ((symbol? argument) - (set! name-prefix (symbol->string argument))) - ((integer? argument) - (set! name-counter argument)) - (else - (error "Bad argument: GENERATE-UNINTERNED-SYMBOL" - argument)))) - (string->uninterned-symbol - (string-append name-prefix (write-to-string (get-number))))))) diff --git a/v7/src/runtime/hash.scm b/v7/src/runtime/hash.scm deleted file mode 100644 index 77991cbce..000000000 --- a/v7/src/runtime/hash.scm +++ /dev/null @@ -1,239 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/hash.scm,v 13.45 1987/02/15 15:43:06 cph Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Object Hashing, populations, and 2D tables - -;;; The hashing code, and the population code below, depend on weak -;;; conses supported by the microcode. In particular, both pieces of -;;; code depend on the fact that the car of a weak cons becomes #F if -;;; the object is garbage collected. - -;;; Important: This code must be rewritten for a parallel processor, -;;; since two processors may be updating the data structures -;;; simultaneously. - -(declare (usual-integrations)) - -(add-event-receiver! event:after-restore gc-flip) - -;;;; Object hashing - -;;; How this works: - -;;; There are two tables, the hash table and the unhash table: - -;;; - The hash table associates objects to their hash numbers. The -;;; entries are keyed according to the address (datum) of the object, -;;; and thus must be recomputed after every relocation (ie. band -;;; loading, garbage collection, etc.). - -;;; - The unhash table associates the hash numbers with the -;;; corresponding objects. It is keyed according to the numbers -;;; themselves. - -;;; In order to make the hash and unhash tables weakly hold the -;;; objects hashed, the following mechanism is used: - -;;; The hash table, a vector, has a SNMV header before all the -;;; buckets, and therefore the garbage collector will skip it and will -;;; not relocate its buckets. It becomes invalid after a garbage -;;; collection and the first thing the daemon does is clear it. Each -;;; bucket is a normal alist with the objects in the cars, and the -;;; numbers in the cdrs, thus assq can be used to find an object in -;;; the bucket. - -;;; The unhash table, also a vector, holds the objects by means of -;;; weak conses. These weak conses are the same as the pairs in the -;;; buckets in the hash table, but with their type codes changed. -;;; Each of the buckets in the unhash table is headed by an extra pair -;;; whose car is usually #T. This pair is used by the splicing code. -;;; The daemon treats buckets headed by #F differently from buckets -;;; headed by #T. A bucket headed by #T is compressed: Those pairs -;;; whose cars have disappeared are spliced out from the bucket. On -;;; the other hand, buckets headed by #F are not compressed. The -;;; intent is that while object-unhash is traversing a bucket, the -;;; bucket is locked so that the daemon will not splice it out behind -;;; object-unhash's back. Then object-unhash does not need to be -;;; locked against garbage collection. - -(define (hash x) - (if (eq? x false) - 0 - (object-hash x))) - -(define (unhash n) - (if (zero? n) - false - (or (object-unhash n) - (error "unhash: Not a valid hash number" n)))) - -(define (valid-hash-number? n) - (or (zero? n) - (object-unhash n))) - -(define object-hash) -(define object-unhash) - -(let ((pair-type (microcode-type 'PAIR)) - (weak-cons-type (microcode-type 'WEAK-CONS)) - (snmv-type (microcode-type 'MANIFEST-SPECIAL-NM-VECTOR)) - (&make-object (make-primitive-procedure '&MAKE-OBJECT))) - (declare (integrate-primitive-procedures &make-object)) - -(define next-hash-number) -(define hash-table-size) -(define unhash-table) -(define hash-table) - -(define (initialize-object-hash! size) - (set! next-hash-number 1) - (set! hash-table-size size) - (set! unhash-table (vector-cons size '())) - (set! hash-table (vector-cons (1+ size) '())) - (vector-set! hash-table 0 (&make-object snmv-type size)) - (let initialize ((n 0)) - (if (< n size) - (begin (vector-set! unhash-table n (cons true '())) - (initialize (1+ n)))))) - -;;; This is not dangerous because assq is a primitive and does not -;;; cause consing. The rest of the consing (including that by the -;;; interpreter) is a small bounded amount. - -(set! object-hash -(named-lambda (object-hash object) - (with-interrupt-mask interrupt-mask-none - (lambda (ignore) - (let* ((hash-index (1+ (modulo (primitive-datum object) hash-table-size))) - (bucket (vector-ref hash-table hash-index)) - (association (assq object bucket))) - (if association - (cdr association) - (let ((pair (cons object next-hash-number)) - (result next-hash-number) - (unhash-bucket - (vector-ref unhash-table - (modulo next-hash-number hash-table-size)))) - (set! next-hash-number (1+ next-hash-number)) - (vector-set! hash-table hash-index (cons pair bucket)) - (set-cdr! unhash-bucket - (cons (primitive-set-type weak-cons-type pair) - (cdr unhash-bucket))) - result))))))) - -;;; This is safe because it locks the garbage collector out only for a -;;; little time, enough to tag the bucket being searched, so that the -;;; daemon will not splice that bucket. - -(set! object-unhash -(named-lambda (object-unhash number) - (let ((index (modulo number hash-table-size))) - (with-interrupt-mask interrupt-mask-none - (lambda (ignore) - (let ((bucket (vector-ref unhash-table index))) - (set-car! bucket false) - (let ((result - (with-interrupt-mask interrupt-mask-gc-ok - (lambda (ignore) - (let loop ((l (cdr bucket))) - (cond ((null? l) false) - ((= number (system-pair-cdr (car l))) - (system-pair-car (car l))) - (else (loop (cdr l))))))))) - (set-car! bucket true) - result))))))) - -;;;; Rehash daemon - -;;; The following is dangerous because of the (unnecessary) consing -;;; done by the interpreter while it executes the loops. It runs with -;;; interrupts turned off. The (necessary) consing done by rehash is -;;; not dangerous because at least that much storage was freed by the -;;; garbage collector. To understand this, notice that the hash table -;;; has a SNMV header, so the garbage collector does not trace the -;;; hash table buckets, therefore freeing their storage. The header -;;; is SNM rather than NM to make the buckets be relocated at band -;;; load/restore time. - -;;; Until this code is compiled, and therefore safe, it is replaced by -;;; a primitive. See the installation code below. - -#| -(define (rehash weak-pair) - (let ((index (1+ (modulo (primitive-datum (system-pair-car weak-pair)) - hash-table-size)))) - (vector-set! hash-table - index - (cons (primitive-set-type pair-type weak-pair) - (vector-ref hash-table index))))) - -(define (cleanup n) - (if (zero? n) - 'DONE - (begin (vector-set! hash-table n '()) - (cleanup (-1+ n))))) - -(define (rehash-gc-daemon) - (cleanup hash-table-size) - (let outer ((n (-1+ hash-table-size))) - (if (negative? n) - true - (let ((bucket (vector-ref unhash-table n))) - (if (car bucket) - (let inner1 ((l1 bucket) (l2 (cdr bucket))) - (cond ((null? l2) (outer (-1+ n))) - ((eq? (system-pair-car (car l2)) false) - (set-cdr! l1 (cdr l2)) - (inner1 l1 (cdr l1))) - (else (rehash (car l2)) - (inner1 l2 (cdr l2))))) - (let inner2 ((l (cdr bucket))) - (cond ((null? l) (outer (-1+ n))) - ((eq? (system-pair-car (car l)) false) - (inner2 (cdr l))) - (else (rehash (car l)) - (inner2 (cdr l)))))))))) - -(add-gc-daemon! rehash-gc-daemon) -|# - -(add-gc-daemon! - (let ((primitive (make-primitive-procedure 'REHASH))) - (lambda () - (primitive unhash-table hash-table)))) diff --git a/v7/src/runtime/histry.scm b/v7/src/runtime/histry.scm deleted file mode 100644 index acdd5dc0e..000000000 --- a/v7/src/runtime/histry.scm +++ /dev/null @@ -1,254 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/histry.scm,v 13.45 1987/04/17 00:54:28 cph Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; History Manipulation - -(declare (usual-integrations)) - -(define max-subproblems 10) -(define max-reductions 5) -(define with-new-history) - -(define history-package - (let ((set-current-history! - (make-primitive-procedure 'SET-CURRENT-HISTORY!)) - (return-address-pop-from-compiled-code - (make-return-address - (microcode-return 'POP-FROM-COMPILED-CODE))) - - ;; VERTEBRA abstraction. - (make-vertebra (make-primitive-procedure 'HUNK3-CONS)) - (vertebra-rib system-hunk3-cxr0) - (shallower-vertebra system-hunk3-cxr2) - (set-vertebra-rib! system-hunk3-set-cxr0!) - (set-deeper-vertebra! system-hunk3-set-cxr1!) - (set-shallower-vertebra! system-hunk3-set-cxr2!) - - ;; REDUCTION abstraction. - (make-reduction (make-primitive-procedure 'HUNK3-CONS)) - (reduction-expression system-hunk3-cxr0) - (reduction-environment system-hunk3-cxr1) - (set-reduction-expression! system-hunk3-set-cxr0!) - (set-reduction-environment! system-hunk3-set-cxr1!) - (set-next-reduction! system-hunk3-set-cxr2!) - ) - -(declare (integrate-primitive-procedures - (make-vertebra hunk3-cons) - (vertebra-rib system-hunk3-cxr0) - (shallower-vertebra system-hunk3-cxr2) - (set-vertebra-rib! system-hunk3-set-cxr0!) - (set-deeper-vertebra! system-hunk3-set-cxr1!) - (set-shallower-vertebra! system-hunk3-set-cxr2!) - (make-reduction hunk3-cons) - (reduction-expression system-hunk3-cxr0) - (reduction-environment system-hunk3-cxr1) - (set-reduction-expression! system-hunk3-set-cxr0!) - (set-reduction-environment! system-hunk3-set-cxr1!) - (set-next-reduction! system-hunk3-set-cxr2!))) - -(define (deeper-vertebra vertebra) - (make-object-safe (system-hunk3-cxr1 vertebra))) - -(define (marked-vertebra? vertebra) - (object-dangerous? (system-hunk3-cxr1 vertebra))) - -(define (mark-vertebra! vertebra) - (system-hunk3-set-cxr1! - vertebra - (make-object-dangerous (system-hunk3-cxr1 vertebra)))) - -(define (unmark-vertebra! vertebra) - (system-hunk3-set-cxr1! vertebra - (make-object-safe (system-hunk3-cxr1 vertebra)))) - -(define (next-reduction reduction) - (make-object-safe (system-hunk3-cxr2 reduction))) - -(define (marked-reduction? reduction) - (object-dangerous? (system-hunk3-cxr2 reduction))) - -(define (mark-reduction! reduction) - (system-hunk3-set-cxr2! - reduction - (make-object-dangerous (system-hunk3-cxr2 reduction)))) - -(define (unmark-reduction! reduction) - (system-hunk3-set-cxr2! reduction - (make-object-safe (system-hunk3-cxr2 reduction)))) - -(define (link-vertebrae previous next) - (set-deeper-vertebra! previous next) - (set-shallower-vertebra! next previous)) - -;;;; History Initialization - -(define (create-history depth width) - (define (new-vertebra) - (let ((head (make-reduction false false '()))) - (set-next-reduction! - head - (let reduction-loop ((n (-1+ width))) - (if (zero? n) - head - (make-reduction false false (reduction-loop (-1+ n)))))) - (make-vertebra head '() '()))) - - (cond ((or (not (integer? depth)) - (negative? depth)) - (error "Invalid Depth" 'CREATE-HISTORY depth)) - ((or (not (integer? width)) - (negative? width)) - (error "Invalid Width" 'CREATE-HISTORY width)) - (else - (if (or (zero? depth) (zero? width)) - (begin (set! depth 1) (set! width 1))) - (let ((head (new-vertebra))) - (let subproblem-loop ((n (-1+ depth)) - (previous head)) - (if (zero? n) - (link-vertebrae previous head) - (let ((next (new-vertebra))) - (link-vertebrae previous next) - (subproblem-loop (-1+ n) next)))) - head)))) - -;;; The PUSH-HISTORY! accounts for the pop which happens after -;;; SET-CURRENT-HISTORY! is run. - -(set! with-new-history - (named-lambda (with-new-history thunk) - (set-current-history! - (let ((history - (push-history! (create-history max-subproblems - max-reductions)))) - (if (zero? max-subproblems) - - ;; In this case, we want the history to appear empty, - ;; so when it pops up, there is nothing in it. - history - - ;; Otherwise, record a dummy reduction, which will appear - ;; in the history. - (begin - (record-evaluation-in-history! history - (scode-quote #F) - system-global-environment) - (push-history! history))))) - (thunk))) - -;;;; Primitive History Operations -;;; These operations mimic the actions of the microcode. -;;; The history motion operations all return the new history. - -(define (record-evaluation-in-history! history expression environment) - (let ((current-reduction (vertebra-rib history))) - (set-reduction-expression! current-reduction expression) - (set-reduction-environment! current-reduction environment))) - -(define (set-history-to-next-reduction! history) - (let ((next-reduction (next-reduction (vertebra-rib history)))) - (set-vertebra-rib! history next-reduction) - (unmark-reduction! next-reduction) - history)) - -(define (push-history! history) - (let ((deeper-vertebra (deeper-vertebra history))) - (mark-vertebra! deeper-vertebra) - (mark-reduction! (vertebra-rib deeper-vertebra)) - deeper-vertebra)) - -(define (pop-history! history) - (unmark-vertebra! history) - (shallower-vertebra history)) - -;;;; Side-Effectless Examiners - -(define (history-transform history) - (let loop ((current history)) - (cons current - (if (marked-vertebra? current) - (cons (delay (unfold-and-reverse-rib (vertebra-rib current))) - (delay - (let ((next (shallower-vertebra current))) - (if (eq? next history) - '() - (loop next))))) - '())))) - -(define (dummy-compiler-reduction? reduction) - (and (marked-reduction? reduction) - (null? (reduction-expression reduction)) - (eq? return-address-pop-from-compiled-code - (reduction-environment reduction)))) - -(define (unfold-and-reverse-rib rib) - (let loop ((current (next-reduction rib)) (output 'WRAP-AROUND)) - (let ((step - (if (dummy-compiler-reduction? current) - '() - (cons (list (reduction-expression current) - (reduction-environment current)) - (if (marked-reduction? current) - '() - output))))) - (if (eq? current rib) - step - (loop (next-reduction current) step))))) - -(define the-empty-history - (cons (vector-ref (get-fixed-objects-vector) - (fixed-objects-vector-slot 'DUMMY-HISTORY)) - '())) - -(define (history-superproblem history) - (if (null? (cdr history)) - history - (force (cddr history)))) - -(define (history-reductions history) - (if (null? (cdr history)) - '() - (force (cadr history)))) - -(define (history-untransform history) - (car history)) - -;;; end HISTORY-PACKAGE. -(the-environment))) \ No newline at end of file diff --git a/v7/src/runtime/input.scm b/v7/src/runtime/input.scm deleted file mode 100644 index 91994809e..000000000 --- a/v7/src/runtime/input.scm +++ /dev/null @@ -1,546 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/input.scm,v 13.43 1987/03/17 18:50:41 cph Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Input - -(declare (usual-integrations)) - -;;;; Input Ports - -(define input-port-tag - "Input Port") - -(define (input-port? object) - (and (environment? object) - (not (lexical-unreferenceable? object ':type)) - (eq? (access :type object) input-port-tag))) - -(define eof-object - "EOF Object") - -(define (eof-object? object) - (eq? object eof-object)) - -(define *current-input-port*) - -(define (current-input-port) - *current-input-port*) - -(define (with-input-from-port port thunk) - (if (not (input-port? port)) (error "Bad input port" port)) - (fluid-let ((*current-input-port* port)) - (thunk))) - -(define (with-input-from-file input-specifier thunk) - (define new-port (open-input-file input-specifier)) - (define old-port) - (dynamic-wind (lambda () - (set! old-port - (set! *current-input-port* - (set! new-port)))) - thunk - (lambda () - (let ((port)) - ;; Only SET! is guaranteed to do the right thing with - ;; an unassigned value. Binding may not work right. - (set! port (set! *current-input-port* (set! old-port))) - (if (not (unassigned? port)) - (close-input-port port)))))) - -(define (call-with-input-file input-specifier receiver) - (let ((port (open-input-file input-specifier))) - (let ((value (receiver port))) - (close-input-port port) - value))) - -(define (close-input-port port) - ((access :close port))) - -;;;; Console Input Port - -(define console-input-port) -(let () - -(define tty-read-char - (make-primitive-procedure 'TTY-READ-CHAR)) - -(define tty-read-char-immediate - (make-primitive-procedure 'TTY-READ-CHAR-IMMEDIATE)) - -(define tty-read-char-ready? - (make-primitive-procedure 'TTY-READ-CHAR-READY?)) - -(define tty-read-finish - (make-primitive-procedure 'TTY-READ-FINISH)) - -(define (read-start-hook) - 'DONE) - -(define (read-finish-hook) - 'DONE) - -(set! console-input-port - (make-environment - -(define :type input-port-tag) - -(define (:print-self) - (unparse-with-brackets - (lambda () - (write-string "Console input port")))) - -(define (:close) - 'DONE) - -(define character-buffer - false) - -(define (:peek-char) - (or character-buffer - (begin (set! character-buffer (tty-read-char)) - character-buffer))) - -(define (:discard-char) - (set! character-buffer false)) - -(define (:read-char) - (if character-buffer - (set! character-buffer false) - (tty-read-char))) - -(define (:read-string delimiters) - (define (loop) - (if (char-set-member? delimiters (:peek-char)) - '() - (let ((char (:read-char))) - (cons char (loop))))) - (list->string (loop))) - -(define (:discard-chars delimiters) - (define (loop) - (if (not (char-set-member? delimiters (:peek-char))) - (begin (:discard-char) - (loop)))) - (loop)) - -(define (:peek-char-immediate) - (or character-buffer - (begin (set! character-buffer (tty-read-char-immediate)) - character-buffer))) - -(define (:read-char-immediate) - (if character-buffer - (set! character-buffer false) - (tty-read-char-immediate))) - -(define (:char-ready? delay) - (or character-buffer (tty-read-char-ready? delay))) - -(define (:read-start!) - (read-start-hook)) - -(define :read-finish! - (let () - (define (read-finish-loop) - (if (and (:char-ready? 0) - (char-whitespace? (:peek-char))) - (begin (:discard-char) - (read-finish-loop)))) - (lambda () - (tty-read-finish) - (read-finish-loop) - (read-finish-hook)))) - -;;; end CONSOLE-INPUT-PORT. -)) - -) - -(set! *current-input-port* console-input-port) - -;;;; File Input Ports - -(define open-input-file) -(let () - -(define file-fill-input-buffer - (make-primitive-procedure 'FILE-FILL-INPUT-BUFFER)) - -(define file-length - (make-primitive-procedure 'FILE-LENGTH)) - -(define file-port-buffer-size - 512) - -(set! open-input-file -(named-lambda (open-input-file filename) - (let ((file-channel ((access open-input-channel primitive-io) - (canonicalize-input-filename filename)))) - -(define :type input-port-tag) - -(define (:print-self) - (unparse-with-brackets - (lambda () - (write-string "Buffered input port for file: ") - (write ((access channel-name primitive-io) file-channel))))) - -(define (:pathname) - (->pathname filename)) - -(define (:truename) - (->pathname ((access channel-name primitive-io) file-channel))) - -(define (:length) - (file-length file-channel)) - -(define buffer false) -(define start-index 0) -(define end-index -1) - -(define (refill-buffer!) - (if (not buffer) (set! buffer (string-allocate file-port-buffer-size))) - (set! start-index 0) - (set! end-index (file-fill-input-buffer file-channel buffer)) - (zero? end-index)) - -(define (:char-ready? delay) - (not (zero? end-index))) - -(define (:close) - (set! end-index 0) - (set! buffer false) - ((access close-physical-channel primitive-io) file-channel)) - -(define (:peek-char) - (if (< start-index end-index) - (string-ref buffer start-index) - (and (not (zero? end-index)) - (not (refill-buffer!)) - (string-ref buffer 0)))) - -(define (:discard-char) - (set! start-index (1+ start-index))) - -(define (:read-char) - (if (< start-index end-index) - (string-ref buffer (set! start-index (1+ start-index))) - (and (not (zero? end-index)) - (not (refill-buffer!)) - (begin (set! start-index 1) - (string-ref buffer 0))))) - -(define (:read-string delimiters) - (define (loop) - (let ((index - (substring-find-next-char-in-set buffer start-index end-index - delimiters))) - (if index - (substring buffer (set! start-index index) index) - (let ((head (substring buffer start-index end-index))) - (if (refill-buffer!) - head - (let ((tail (loop)) - (head-length (string-length head))) - (let ((result (string-allocate (+ head-length - (string-length tail))))) - (substring-move-right! head 0 head-length - result 0) - (substring-move-right! tail 0 (string-length tail) - result head-length) - result))))))) - (and (or (< start-index end-index) - (and (not (zero? end-index)) - (not (refill-buffer!)))) - (loop))) - -(define (:discard-chars delimiters) - (define (loop) - (let ((index - (substring-find-next-char-in-set buffer start-index end-index - delimiters))) - (cond (index (set! start-index index)) - ((not (refill-buffer!)) (loop))))) - (if (or (< start-index end-index) - (and (not (zero? end-index)) - (not (refill-buffer!)))) - (loop))) - -(define (:rest->string) - (define (read-rest) - (set! end-index 0) - (loop)) - - (define (loop) - (let ((buffer (string-allocate file-port-buffer-size))) - (let ((n (file-fill-input-buffer file-channel buffer))) - (cond ((zero? n) '()) - ((< n file-port-buffer-size) - (set-string-length! buffer n) - (list buffer)) - (else (cons buffer (loop))))))) - - (if (zero? end-index) - (error "End of file -- :REST->STRING")) - (cond ((= -1 end-index) - (let ((l (:length))) - (if l - (let ((buffer (string-allocate l))) - (set! end-index 0) - (file-fill-input-buffer file-channel buffer) - buffer) - (apply string-append (read-rest))))) - ((< start-index end-index) - (let ((first (substring buffer start-index end-index))) - (apply string-append - (cons first - (read-rest))))) - (else - (apply string-append (read-rest))))) - -(the-environment)))) - -) - -;;;; String Input Ports - -(define (with-input-from-string string thunk) - (fluid-let ((*current-input-port* (string->input-port string))) - (thunk))) - -(define (string->input-port string #!optional start end) - (cond ((unassigned? start) - (set! start 0) - (set! end (string-length string))) - ((unassigned? end) - (set! end (string-length string)))) - -(define :type input-port-tag) - -(define (:print-self) - (unparse-with-brackets - (lambda () - (write-string "Input port for string")))) - -(define (:char-ready? delay) - (< start end)) - -(define (:close) 'DONE) - -(define (:peek-char) - (and (< start end) - (string-ref string start))) - -(define (:discard-char) - (set! start (1+ start))) - -(define (:read-char) - (and (< start end) - (string-ref string (set! start (1+ start))))) - -(define (:read-string delimiters) - (and (< start end) - (let ((index - (substring-find-next-char-in-set string start end delimiters))) - (if index - (substring string (set! start index) index) - (substring string start end))))) - -(define (:discard-chars delimiters) - (if (< start end) - (set! start - (or (substring-find-next-char-in-set string start end delimiters) - end)))) - -;;; end STRING->INPUT-PORT. -(the-environment)) - -;;;; Input Procedures - -(define (peek-char #!optional port) - (cond ((unassigned? port) (set! port *current-input-port*)) - ((not (input-port? port)) (error "Bad input port" port))) - (or ((if (lexical-unreferenceable? port ':peek-char-immediate) - (access :peek-char port) - (access :peek-char-immediate port))) - eof-object)) - -(define (read-char #!optional port) - (cond ((unassigned? port) (set! port *current-input-port*)) - ((not (input-port? port)) (error "Bad input port" port))) - (or ((if (lexical-unreferenceable? port ':read-char-immediate) - (access :read-char port) - (access :read-char-immediate port))) - eof-object)) - -(define (read-string delimiters #!optional port) - (cond ((unassigned? port) (set! port *current-input-port*)) - ((not (input-port? port)) (error "Bad input port" port))) - (or ((access :read-string port) delimiters) - eof-object)) - -(define (read #!optional port) - (cond ((unassigned? port) (set! port *current-input-port*)) - ((not (input-port? port)) (error "Bad input port" port))) - (if (not (lexical-unreferenceable? port ':read-start!)) - ((access :read-start! port))) - (let ((object ((access *parse-object parser-package) port))) - (if (not (lexical-unreferenceable? port ':read-finish!)) - ((access :read-finish! port))) - object)) - -;;; **** The DELAY option for this operation works only for the -;;; console port. Since it is a kludge, it is probably OK. - -(define (char-ready? #!optional port delay) - (cond ((unassigned? port) (set! port *current-input-port*)) - ((not (input-port? port)) (error "Bad input port" port))) - (cond ((unassigned? delay) (set! delay 0)) - ((not (and (integer? delay) (>= delay 0))) (error "Bad delay" delay))) - ((access :char-ready? port) delay)) - -(define (read-char-no-hang #!optional port) - (cond ((unassigned? port) (set! port *current-input-port*)) - ((not (input-port? port)) (error "Bad input port" port))) - (and ((access :char-ready? port) 0) - (read-char port))) - -(define load) -(define load-noisily) -(define load-noisily? false) -(define read-file) -(let () - -(define default-pathname - (make-pathname false false false false 'NEWEST)) - -;;; This crufty piece of code, once it decides which file to load, -;;; does `file-exists?' on that file at least three times!! - -(define (basic-load filename environment) - (define (kernel filename) - (let ((pathname - (let ((pathname (->pathname filename))) - (or (pathname->input-truename pathname) - (let ((pathname (merge-pathnames pathname default-pathname))) - (if (pathname-type pathname) - (pathname->input-truename pathname) - (or (pathname->input-truename - (pathname-new-type pathname "bin")) - (pathname->input-truename - (pathname-new-type pathname "scm"))))) - (error "No such file" pathname))))) - (if (call-with-input-file pathname - (lambda (port) - (= 250 (char->ascii (peek-char port))))) - (scode-load pathname) - (sexp-load pathname)))) - - (define (sexp-load filename) - (call-with-input-file filename - (lambda (port) - (define (load-loop previous-object) - (let ((object (read port))) - (if (eof-object? object) - previous-object - (let ((value (eval object environment))) - (if load-noisily? (begin (newline) (write value))) - (load-loop value))))) - (load-loop *the-non-printing-object*)))) - - (define (scode-load filename) - (scode-eval (fasload filename) environment)) - - (if (pair? filename) - (for-each kernel filename) - (kernel filename))) - -(set! load -(named-lambda (load filename #!optional environment) - (if (unassigned? environment) (set! environment (rep-environment))) - (basic-load filename environment))) - -(set! load-noisily -(named-lambda (load-noisily filename #!optional environment) - (if (unassigned? environment) (set! environment (rep-environment))) - (fluid-let ((load-noisily? true)) - (basic-load filename environment)))) - -(set! read-file -(named-lambda (read-file filename) - (let ((name (pathname->input-truename - (merge-pathnames (->pathname filename) default-pathname)))) - (if name - (call-with-input-file name - (access *parse-objects-until-eof parser-package)) - (error "Read-file: No such file" name))))) -) - -(define fasload) -(let () - -(define binary-fasload - (make-primitive-procedure 'BINARY-FASLOAD)) - -(set! fasload -(named-lambda (fasload filename) - (set! filename (canonicalize-input-filename filename)) - (let ((port (rep-output-port))) - (newline port) - (write-string "FASLoading " port) - (write filename port) - (let ((value (binary-fasload filename))) - (write-string " -- done" port) - value)))) - -) - -(define transcript-on - (let ((photo-open (make-primitive-procedure 'PHOTO-OPEN))) - (named-lambda (transcript-on filename) - (if (not (photo-open (canonicalize-output-filename filename))) - (error "Transcript file already open: TRANSCRIPT-ON" filename)) - *the-non-printing-object*))) - -(define transcript-off - (let ((photo-close (make-primitive-procedure 'PHOTO-CLOSE))) - (named-lambda (transcript-off) - (if (not (photo-close)) - (error "Transcript file already closed: TRANSCRIPT-OFF")) - *the-non-printing-object*))) \ No newline at end of file diff --git a/v7/src/runtime/intrpt.scm b/v7/src/runtime/intrpt.scm deleted file mode 100644 index c5e0b863f..000000000 --- a/v7/src/runtime/intrpt.scm +++ /dev/null @@ -1,255 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 13.43 1987/03/17 18:50:56 cph Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Interrupt System - -(declare (usual-integrations) - (integrate-primitive-procedures set-fixed-objects-vector!)) - -(define with-external-interrupts-handler) - -(define timer-interrupt - (let ((setup-timer-interrupt - (make-primitive-procedure 'SETUP-TIMER-INTERRUPT true))) - (named-lambda (timer-interrupt) - (setup-timer-interrupt '() '()) - (error "Unhandled Timer interrupt received")))) - -(define interrupt-system - (let ((get-next-interrupt-character - (make-primitive-procedure 'GET-NEXT-INTERRUPT-CHARACTER)) - (check-and-clean-up-input-channel - (make-primitive-procedure 'CHECK-AND-CLEAN-UP-INPUT-CHANNEL)) - (index:interrupt-vector - (fixed-objects-vector-slot 'SYSTEM-INTERRUPT-VECTOR)) - (index:termination-vector - (fixed-objects-vector-slot - 'MICROCODE-TERMINATIONS-PROCEDURES)) - (^Q-Hook '())) - -;;;; Soft interrupts - -;;; Timer interrupts - -(define (timer-interrupt-handler interrupt-code interrupt-enables) - (timer-interrupt)) - -;;; Keyboard Interrupts - -(define (external-interrupt-handler interrupt-code interrupt-enables) - (let ((interrupt-character (get-next-interrupt-character))) - ((vector-ref keyboard-interrupts interrupt-character) interrupt-character - interrupt-enables))) - -(define (losing-keyboard-interrupt interrupt-character interrupt-enables) - (error "Bad interrupt character" interrupt-character)) - -(define keyboard-interrupts - (vector-cons 256 losing-keyboard-interrupt)) - -(define (install-keyboard-interrupt! interrupt-char handler) - (vector-set! keyboard-interrupts - (char->ascii interrupt-char) - handler)) - -(define (remove-keyboard-interrupt! interrupt-char) - (vector-set! keyboard-interrupts - (char->ascii interrupt-char) - losing-keyboard-interrupt)) - -(define until-most-recent-interrupt-character 0) ;for Pascal, ugh! -(define multiple-copies-only 1) - -(define ((flush-typeahead kernel) interrupt-character interrupt-enables) - (if (check-and-clean-up-input-channel until-most-recent-interrupt-character - interrupt-character) - (kernel interrupt-character interrupt-enables))) - -(define ((keep-typeahead kernel) interrupt-character interrupt-enables) - (if (check-and-clean-up-input-channel multiple-copies-only - interrupt-character) - (kernel interrupt-character interrupt-enables))) - -(define ^B-interrupt-handler - (keep-typeahead - (lambda (interrupt-character interrupt-enables) - (with-standard-proceed-point - (lambda () - (breakpoint "^B interrupt" (rep-environment))))))) - -; (define ^S-interrupt-handler -; (keep-typeahead -; (lambda (interrupt-character interrupt-enables) -; (if (null? ^Q-Hook) -; (begin (set-interrupt-enables! interrupt-enables) -; (beep) -; (call-with-current-continuation -; (lambda (stop-^S-wait) -; (fluid-let ((^Q-Hook Stop-^S-Wait)) -; (let busy-wait () (busy-wait)))))))))) -; -; (define ^Q-interrupt-handler -; (keep-typeahead -; (lambda (interrupt-character interrupt-enables) -; (if (not (null? ^Q-Hook)) -; (begin (set-interrupt-enables! interrupt-enables) -; (^Q-Hook 'GO-ON)))))) -; -; (define ^P-interrupt-handler -; (flush-typeahead -; (lambda (interrupt-character interrupt-enables) -; (set-interrupt-enables! interrupt-enables) -; (proceed)))) -; -; (define ^Z-interrupt-handler -; (flush-typeahead -; (lambda (interrupt-character interrupt-enables) -; (set-interrupt-enables! interrupt-enables) -; (edit)))) - -(define ^G-interrupt-handler - (flush-typeahead - (lambda (interrupt-character interrupt-enables) - (abort-to-top-level-driver "Quit!")))) - -(define ^U-interrupt-handler - (flush-typeahead - (lambda (interrupt-character interrupt-enables) - (abort-to-previous-driver "Up!")))) - -(define ^X-interrupt-handler - (flush-typeahead - (lambda (interrupt-character interrupt-enables) - (abort-to-nearest-driver "Abort!")))) - -(define (gc-out-of-space-handler . args) - (abort-to-nearest-driver "Aborting! Out of memory")) - -(install-keyboard-interrupt! #\G ^G-interrupt-handler) -(install-keyboard-interrupt! #\B ^B-interrupt-handler) -; (install-keyboard-interrupt! #\P ^P-interrupt-handler) -(install-keyboard-interrupt! #\U ^U-interrupt-handler) -(install-keyboard-interrupt! #\X ^X-interrupt-handler) -; (install-keyboard-interrupt! #\Z ^Z-interrupt-handler) -; (install-keyboard-interrupt! #\S ^S-interrupt-handler) -; (install-keyboard-interrupt! #\Q ^Q-interrupt-handler) - -(define stack-overflow-slot 0) -(define gc-slot 2) -(define character-slot 4) -(define timer-slot 6) - -(define (install) - (with-interrupts-reduced interrupt-mask-gc-ok - (lambda (old-mask) - (let ((old-system-interrupt-vector - (vector-ref (get-fixed-objects-vector) index:interrupt-vector)) - (old-termination-vector - (vector-ref (get-fixed-objects-vector) index:termination-vector))) - (let ((previous-gc-interrupt - (vector-ref old-system-interrupt-vector gc-slot)) - (previous-stack-interrupt - (vector-ref old-system-interrupt-vector stack-overflow-slot)) - (system-interrupt-vector - (vector-cons (vector-length old-system-interrupt-vector) - default-interrupt-handler)) - (termination-vector - (if old-termination-vector - (if (> number-of-microcode-terminations - (vector-length old-termination-vector)) - (vector-grow old-termination-vector - number-of-microcode-terminations) - old-termination-vector) - (vector-cons number-of-microcode-terminations false)))) - - (vector-set! system-interrupt-vector gc-slot previous-gc-interrupt) - (vector-set! system-interrupt-vector stack-overflow-slot - previous-stack-interrupt) - (vector-set! system-interrupt-vector character-slot - external-interrupt-handler) - (vector-set! system-interrupt-vector timer-slot - timer-interrupt-handler) - - ;; slots 4-15 unused. - - ;; install the new vector atomically - (vector-set! (get-fixed-objects-vector) - index:interrupt-vector - system-interrupt-vector) - - (vector-set! termination-vector - (microcode-termination 'GC-OUT-OF-SPACE) - gc-out-of-space-handler) - - (vector-set! (get-fixed-objects-vector) - index:termination-vector - termination-vector) - - (set-fixed-objects-vector! (get-fixed-objects-vector))))))) - -(define (default-interrupt-handler interrupt-code interrupt-enables) - (write-string "Anomalous Interrupt: ") (write interrupt-code) - (write-string " Mask: ") (write interrupt-enables)) - -(set! with-external-interrupts-handler -(named-lambda (with-external-interrupts-handler handler code) - (define (interrupt-routine interrupt-code interrupt-enables) - (let ((character (get-next-interrupt-character))) - (check-and-clean-up-input-channel - until-most-recent-interrupt-character - character) - (handler character interrupt-enables))) - - (define old-handler interrupt-routine) - - (define interrupt-vector - (vector-ref (get-fixed-objects-vector) index:interrupt-vector)) - - (dynamic-wind - (lambda () - (set! old-handler - (vector-set! interrupt-vector character-slot old-handler))) - code - (lambda () - (vector-set! interrupt-vector character-slot - (set! old-handler - (vector-ref interrupt-vector character-slot))))))) - -;;; end INTERRUPT-SYSTEM package. -(the-environment))) \ No newline at end of file diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm deleted file mode 100644 index 76fd1e7b3..000000000 --- a/v7/src/runtime/io.scm +++ /dev/null @@ -1,205 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 13.45 1987/04/13 18:43:17 cph Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Input/output utilities - -(declare (usual-integrations)) - -(define close-all-open-files) - -(define primitive-io - (let ((open-file-list-tag '*ALL-THE-OPEN-FILES*) - - (weak-cons-type (microcode-type 'WEAK-CONS)) - - (make-physical-channel (make-primitive-procedure 'HUNK3-CONS)) - (channel-descriptor system-hunk3-cxr0) - (set-channel-descriptor! system-hunk3-set-cxr0!) - (channel-name system-hunk3-cxr1) - (channel-direction system-hunk3-cxr2) - (set-channel-direction! system-hunk3-set-cxr2!) - - (closed-direction 0) - (closed-descriptor false)) - - (make-environment - -(declare (integrate-primitive-procedures - (make-physical-channel hunk3-cons) - (channel-descriptor system-hunk3-cxr0) - (set-channel-descriptor! system-hunk3-set-cxr0!) - (channel-name system-hunk3-cxr1) - (channel-direction system-hunk3-cxr2) - (set-channel-direction! system-hunk3-set-cxr2!))) - -(define open-files-list) -(define traversing?) - -(define (initialize) - (set! open-files-list (list open-file-list-tag)) - (set! traversing? false) - true) - -;;;; Open/Close Files - -;;; Direction is one of the following: -;;; - true: output channel -;;; - false: input channel -;;; - 0: closed channel - -(define open-channel-wrapper - (let ((open-channel (make-primitive-procedure 'FILE-OPEN-CHANNEL))) - (named-lambda ((open-channel-wrapper direction) filename) - (without-interrupts - (lambda () - (let ((channel - (make-physical-channel (open-channel filename direction) - filename - direction))) - (with-interrupt-mask interrupt-mask-none ; Disallow gc - (lambda (ie) - (set-cdr! open-files-list - (cons (system-pair-cons weak-cons-type - channel - (channel-descriptor channel)) - (cdr open-files-list))))) - channel)))))) - -(define open-input-channel (open-channel-wrapper false)) -(define open-output-channel (open-channel-wrapper true)) - -;; This is locked from interrupts, but GC can occur since the -;; procedure itself hangs on to the channel until the last moment, -;; when it returns the channel's name. The list will not be spliced -;; by the daemon behind its back because of the traversing? flag. - -(define close-physical-channel - (let ((primitive (make-primitive-procedure 'FILE-CLOSE-CHANNEL))) - (named-lambda (close-physical-channel channel) - (fluid-let ((traversing? true)) - (without-interrupts - (lambda () - (if (eq? closed-direction - (set-channel-direction! channel closed-direction)) - true ;Already closed! - (begin - (primitive (set-channel-descriptor! channel - closed-descriptor)) - (let loop - ((l1 open-files-list) - (l2 (cdr open-files-list))) - (cond ((null? l2) - (set! traversing? false) - (error "CLOSE-PHYSICAL-CHANNEL: lost channel" - channel)) - ((eq? channel (system-pair-car (car l2))) - (set-cdr! l1 (cdr l2)) - (channel-name channel)) - (else - (loop l2 (cdr l2))))))))))))) - -;;;; Finalization and daemon. - -(define (close-files action) - (lambda () - (fluid-let ((traversing? true)) - (without-interrupts - (lambda () - (let loop ((l (cdr open-files-list))) - (cond ((null? l) true) - (else - (let ((channel (system-pair-car (car l)))) - (if (not (eq? channel false)) - (begin - (set-channel-descriptor! channel - closed-descriptor) - (set-channel-direction! channel - closed-direction))) - (action (system-pair-cdr (car l))) - (set-cdr! open-files-list (cdr l))) - (loop (cdr open-files-list)))))))))) - -;;; This is invoked before disk-restoring. It "cleans" the microcode. - -(set! close-all-open-files - (close-files (make-primitive-procedure 'FILE-CLOSE-CHANNEL))) - -;;; This is invoked after disk-restoring. It "cleans" the new runtime system. - -(define reset! - (close-files (lambda (ignore) true))) - -;; This is the daemon which closes files which no one points to. -;; Runs with GC, and lower priority interrupts, disabled. -;; It is unsafe because of the (unnecessary) consing by the -;; interpreter while it executes the loop. - -;; Replaced by a primitive installed below. - -#| - -(define close-lost-open-files-daemon - (let ((primitive (make-primitive-procedure 'FILE-CLOSE-CHANNEL))) - (named-lambda (close-lost-open-files-daemon) - (if (not traversing?) - (let loop - ((l1 open-files-list) - (l2 (cdr open-files-list))) - (cond ((null? l2) - true) - ((null? (system-pair-car (car l2))) - (primitive (system-pair-cdr (car l2))) - (set-cdr! l1 (cdr l2)) - (loop l1 (cdr l1))) - (else - (loop l2 (cdr l2))))))))) - -|# - -(define close-lost-open-files-daemon - (let ((primitive (make-primitive-procedure 'CLOSE-LOST-OPEN-FILES))) - (named-lambda (close-lost-open-files-daemon) - (if (not traversing?) - (primitive open-files-list))))) - -;;; End of PRIMITIVE-IO package. -))) - -((access initialize primitive-io)) -(add-gc-daemon! (access close-lost-open-files-daemon primitive-io)) \ No newline at end of file diff --git a/v7/src/runtime/lambda.scm b/v7/src/runtime/lambda.scm deleted file mode 100644 index 2751b2970..000000000 --- a/v7/src/runtime/lambda.scm +++ /dev/null @@ -1,522 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambda.scm,v 13.42 1987/03/17 18:51:08 cph Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Lambda Abstraction - -(declare (usual-integrations)) - -(define lambda?) -(define make-lambda) -(define lambda-components) -(define lambda-body) -(define set-lambda-body!) -(define lambda-bound) - -(define lambda-package - (let ((slambda-type (microcode-type 'LAMBDA)) - (slexpr-type (microcode-type 'LEXPR)) - (xlambda-type (microcode-type 'EXTENDED-LAMBDA)) - (internal-lambda-tag (make-named-tag "INTERNAL-LAMBDA")) - (internal-lexpr-tag (make-named-tag "INTERNAL-LEXPR")) - (lambda-optional-tag (make-interned-symbol "#!OPTIONAL")) - (lambda-rest-tag (make-interned-symbol "#!REST"))) - -(define internal-lambda-tags - (list internal-lambda-tag internal-lexpr-tag)) - -;;;; Hairy Advice Wrappers - -;;; The body of a LAMBDA object can be modified by transformation. -;;; This has the advantage that the body can be transformed many times, -;;; but the original state will always remain. - -;;; **** Note: this stuff was implemented for the advice package. -;;; Please don't use it for anything else since it will just -;;; confuse things. - -(define lambda-body-procedures - (let ((wrapper-tag '(LAMBDA-WRAPPER)) - (wrapper-body comment-expression) - (set-wrapper-body! set-comment-expression!)) - - (define (make-wrapper original-body new-body state) - (make-comment (vector wrapper-tag original-body state) - new-body)) - - (define (wrapper? object) - (and (comment? object) - (let ((text (comment-text object))) - (and (vector? text) - (not (zero? (vector-length text))) - (eq? (vector-ref text 0) wrapper-tag))))) - - (define (wrapper-state wrapper) - (vector-ref (comment-text wrapper) 2)) - - (define (set-wrapper-state! wrapper new-state) - (vector-set! (comment-text wrapper) 2 new-state)) - - (define (wrapper-original-body wrapper) - (vector-ref (comment-text wrapper) 1)) - - (define (set-wrapper-original-body! wrapper new-body) - (vector-set! (comment-text wrapper) 1 new-body)) - - (named-lambda (lambda-body-procedures physical-body set-physical-body! - receiver) - (receiver - - (named-lambda (wrap-body! lambda transform) - (let ((physical-body (physical-body lambda))) - (if (wrapper? physical-body) - (transform (wrapper-body physical-body) - (wrapper-state physical-body) - (lambda (new-body new-state) - (set-wrapper-body! physical-body new-body) - (set-wrapper-state! physical-body new-state))) - (transform physical-body - '() - (lambda (new-body new-state) - (set-physical-body! lambda - (make-wrapper physical-body - new-body - new-state))))))) - - (named-lambda (wrapper-components lambda receiver) - (let ((physical-body (physical-body lambda))) - (if (wrapper? physical-body) - (receiver (wrapper-original-body physical-body) - (wrapper-state physical-body)) - (receiver physical-body - '())))) - - (named-lambda (unwrap-body! lambda) - (let ((physical-body (physical-body lambda))) - (if (wrapper? physical-body) - (set-physical-body! lambda - (wrapper-original-body physical-body))))) - - (named-lambda (unwrapped-body lambda) - (let ((physical-body (physical-body lambda))) - (if (wrapper? physical-body) - (wrapper-original-body physical-body) - physical-body))) - - (named-lambda (set-unwrapped-body! lambda new-body) - (if (wrapper? (physical-body lambda)) - (set-wrapper-original-body! (physical-body lambda) new-body) - (set-physical-body! lambda new-body))) - - )) - )) - -;;;; Compound Lambda - -(define (make-clambda name required auxiliary body) - (make-slambda name - required - (if (null? auxiliary) - body - (make-combination (make-slambda internal-lambda-tag - auxiliary - body) - (map (lambda (auxiliary) - (make-unassigned-object)) - auxiliary))))) - -(define (clambda-components clambda receiver) - (slambda-components clambda - (lambda (name required body) - (let ((unwrapped-body (clambda-unwrapped-body clambda))) - (if (combination? body) - (let ((operator (combination-operator body))) - (if (is-internal-lambda? operator) - (slambda-components operator - (lambda (tag auxiliary body) - (receiver name required '() '() auxiliary - unwrapped-body))) - (receiver name required '() '() '() unwrapped-body))) - (receiver name required '() '() '() unwrapped-body)))))) - -(define (clambda-bound clambda) - (slambda-components clambda - (lambda (name required body) - (if (combination? body) - (let ((operator (combination-operator body))) - (if (is-internal-lambda? operator) - (slambda-components operator - (lambda (tag auxiliary body) - (append required auxiliary))) - required)) - required)))) - -(define (clambda-has-internal-lambda? clambda) - (let ((body (slambda-body clambda))) - (and (combination? body) - (let ((operator (combination-operator body))) - (and (is-internal-lambda? operator) - operator))))) - -(define clambda-wrap-body!) -(define clambda-wrapper-components) -(define clambda-unwrap-body!) -(define clambda-unwrapped-body) -(define set-clambda-unwrapped-body!) - -(lambda-body-procedures (lambda (clambda) - (slambda-body - (or (clambda-has-internal-lambda? clambda) - clambda))) - (lambda (clambda new-body) - (set-slambda-body! - (or (clambda-has-internal-lambda? clambda) - clambda) - new-body)) - (lambda (wrap-body! wrapper-components unwrap-body! - unwrapped-body set-unwrapped-body!) - (set! clambda-wrap-body! wrap-body!) - (set! clambda-wrapper-components wrapper-components) - (set! clambda-unwrap-body! unwrap-body!) - (set! clambda-unwrapped-body unwrapped-body) - (set! set-clambda-unwrapped-body! set-unwrapped-body!))) - -;;;; Compound Lexpr - -(define (make-clexpr name required rest auxiliary body) - (make-slexpr name - required - (make-combination (make-slambda internal-lexpr-tag - (cons rest auxiliary) - body) - (cons (let ((e (make-the-environment))) - (make-combination - system-subvector-to-list - (list e - (+ (length required) 3) - (make-combination - system-vector-size - (list e))))) - (map (lambda (auxiliary) - (make-unassigned-object)) - auxiliary))))) - -(define (clexpr-components clexpr receiver) - (slexpr-components clexpr - (lambda (name required body) - (slambda-components (combination-operator body) - (lambda (tag auxiliary body) - (receiver name - required - '() - (car auxiliary) - (cdr auxiliary) - (clexpr-unwrapped-body clexpr))))))) - -(define (clexpr-bound clexpr) - (slexpr-components clexpr - (lambda (name required body) - (slambda-components (combination-operator body) - (lambda (tag auxiliary body) - (append required auxiliary)))))) - -(define (clexpr-has-internal-lambda? clexpr) - (combination-operator (slexpr-body clexpr))) - -(define clexpr-wrap-body!) -(define clexpr-wrapper-components) -(define clexpr-unwrap-body!) -(define clexpr-unwrapped-body) -(define set-clexpr-unwrapped-body!) - -(lambda-body-procedures (lambda (clexpr) - (slambda-body (clexpr-has-internal-lambda? clexpr))) - (lambda (clexpr new-body) - (set-slambda-body! - (clexpr-has-internal-lambda? clexpr) - new-body)) - (lambda (wrap-body! wrapper-components unwrap-body! - unwrapped-body set-unwrapped-body!) - (set! clexpr-wrap-body! wrap-body!) - (set! clexpr-wrapper-components wrapper-components) - (set! clexpr-unwrap-body! unwrap-body!) - (set! clexpr-unwrapped-body unwrapped-body) - (set! set-clexpr-unwrapped-body! set-unwrapped-body!))) - -;;;; Extended Lambda - -(define (make-xlambda name required optional rest auxiliary body) - (&typed-triple-cons xlambda-type - body - (list->vector - `(,name ,@required - ,@optional - ,@(if (null? rest) - auxiliary - (cons rest auxiliary)))) - (make-non-pointer-object - (+ (length optional) - (* 256 - (+ (length required) - (if (null? rest) 0 256))))))) - -(define (xlambda-components xlambda receiver) - (let ((qr1 (integer-divide (primitive-datum (&triple-third xlambda)) 256))) - (let ((qr2 (integer-divide (car qr1) 256))) - (let ((ostart (1+ (cdr qr2)))) - (let ((rstart (+ ostart (cdr qr1)))) - (let ((astart (+ rstart (car qr2))) - (bound (&triple-second xlambda))) - (receiver (vector-ref bound 0) - (subvector->list bound 1 ostart) - (subvector->list bound ostart rstart) - (if (zero? (car qr2)) - '() - (vector-ref bound rstart)) - (subvector->list bound - astart - (vector-length bound)) - (xlambda-unwrapped-body xlambda)))))))) - -(define (xlambda-bound xlambda) - (let ((names (&triple-second xlambda))) - (subvector->list names 1 (vector-length names)))) - -(define (xlambda-has-internal-lambda? xlambda) - false) - -(define xlambda-wrap-body!) -(define xlambda-wrapper-components) -(define xlambda-unwrap-body!) -(define xlambda-unwrapped-body) -(define set-xlambda-unwrapped-body!) - -(lambda-body-procedures &triple-first &triple-set-first! - (lambda (wrap-body! wrapper-components unwrap-body! - unwrapped-body set-unwrapped-body!) - (set! xlambda-wrap-body! wrap-body!) - (set! xlambda-wrapper-components wrapper-components) - (set! xlambda-unwrap-body! unwrap-body!) - (set! xlambda-unwrapped-body unwrapped-body) - (set! set-xlambda-unwrapped-body! set-unwrapped-body!))) - -;;;; Generic Lambda - -(set! lambda? -(named-lambda (lambda? object) - (or (primitive-type? slambda-type object) - (primitive-type? slexpr-type object) - (primitive-type? xlambda-type object)))) - -(define (is-internal-lambda? lambda) - (and (primitive-type? slambda-type lambda) - (memq (slambda-name lambda) internal-lambda-tags))) - -(set! make-lambda -(named-lambda (make-lambda name required optional rest auxiliary - declarations body) - (let ((body* (if (null? declarations) - body - (make-sequence (list (make-block-declaration declarations) - body))))) - (cond ((and (< (length required) 256) - (< (length optional) 256) - (or (not (null? optional)) - (not (null? rest)) - (not (null? auxiliary)))) - (make-xlambda name required optional rest auxiliary body*)) - ((not (null? optional)) - (error "Optionals not implemented" 'MAKE-LAMBDA)) - ((null? rest) - (make-clambda name required auxiliary body*)) - (else - (make-clexpr name required rest auxiliary body*)))))) - -(set! lambda-components -(named-lambda (lambda-components lambda receiver) - (&lambda-components lambda - (lambda (name required optional rest auxiliary body) - (let ((actions (and (sequence? body) - (sequence-actions body)))) - (if (and actions - (block-declaration? (car actions))) - (receiver name required optional rest auxiliary - (block-declaration-text (car actions)) - (make-sequence (cdr actions))) - (receiver name required optional rest auxiliary '() body))))))) - -(define ((dispatch-0 op-name clambda-op clexpr-op xlambda-op) lambda) - ((cond ((primitive-type? slambda-type lambda) clambda-op) - ((primitive-type? slexpr-type lambda) clexpr-op) - ((primitive-type? xlambda-type lambda) xlambda-op) - (else (error "Not a lambda" op-name lambda))) - lambda)) - -(define ((dispatch-1 op-name clambda-op clexpr-op xlambda-op) lambda arg) - ((cond ((primitive-type? slambda-type lambda) clambda-op) - ((primitive-type? slexpr-type lambda) clexpr-op) - ((primitive-type? xlambda-type lambda) xlambda-op) - (else (error "Not a lambda" op-name lambda))) - lambda arg)) - -(define &lambda-components - (dispatch-1 'LAMBDA-COMPONENTS - clambda-components - clexpr-components - xlambda-components)) - -(define has-internal-lambda? - (dispatch-0 'HAS-INTERNAL-LAMBDA? - clambda-has-internal-lambda? - clexpr-has-internal-lambda? - xlambda-has-internal-lambda?)) - -(define lambda-wrap-body! - (dispatch-1 'LAMBDA-WRAP-BODY! - clambda-wrap-body! - clexpr-wrap-body! - xlambda-wrap-body!)) - -(define lambda-wrapper-components - (dispatch-1 'LAMBDA-WRAPPER-COMPONENTS - clambda-wrapper-components - clexpr-wrapper-components - xlambda-wrapper-components)) - -(define lambda-unwrap-body! - (dispatch-0 'LAMBDA-UNWRAP-BODY! - clambda-unwrap-body! - clexpr-unwrap-body! - xlambda-unwrap-body!)) - -(set! lambda-body - (dispatch-0 'LAMBDA-BODY - clambda-unwrapped-body - clexpr-unwrapped-body - xlambda-unwrapped-body)) - -(set! set-lambda-body! - (dispatch-1 'SET-LAMBDA-BODY! - set-clambda-unwrapped-body! - set-clexpr-unwrapped-body! - set-xlambda-unwrapped-body!)) - -(set! lambda-bound - (dispatch-0 'LAMBDA-BOUND - clambda-bound - clexpr-bound - xlambda-bound)) - -;;;; Simple Lambda/Lexpr - -(define (make-slambda name required body) - (&typed-pair-cons slambda-type body (list->vector (cons name required)))) - -(define (slambda-components slambda receiver) - (let ((bound (&pair-cdr slambda))) - (receiver (vector-ref bound 0) - (subvector->list bound 1 (vector-length bound)) - (&pair-car slambda)))) - -(define (slambda-name slambda) - (vector-ref (&pair-cdr slambda) 0)) - -(define slambda-body &pair-car) -(define set-slambda-body! &pair-set-car!) - -(define (make-slexpr name required body) - (&typed-pair-cons slexpr-type body (list->vector (cons name required)))) - -(define slexpr-components slambda-components) -(define slexpr-body slambda-body) - -;;; end LAMBDA-PACKAGE. -(the-environment))) - -;;;; Alternative Component Views - -(define (make-lambda* name required optional rest body) - (scan-defines body - (lambda (auxiliary declarations body*) - (make-lambda name required optional rest auxiliary declarations body*)))) - -(define (lambda-components* lambda receiver) - (lambda-components lambda - (lambda (name required optional rest auxiliary declarations body) - (receiver name required optional rest - (make-open-block auxiliary declarations body))))) - -(define (lambda-components** lambda receiver) - (lambda-components* lambda - (lambda (name required optional rest body) - (receiver (vector name required optional rest) - (append required optional (if (null? rest) '() (list rest))) - body)))) - -(define (lambda-pattern/name pattern) - (vector-ref pattern 0)) - -(define (lambda-pattern/required pattern) - (vector-ref pattern 1)) - -(define (lambda-pattern/optional pattern) - (vector-ref pattern 2)) - -(define (lambda-pattern/rest pattern) - (vector-ref pattern 3)) - -(define (make-lambda** pattern bound body) - - (define (split pattern bound receiver) - (cond ((null? pattern) - (receiver '() bound)) - (else - (split (cdr pattern) (cdr bound) - (lambda (copy tail) - (receiver (cons (car bound) copy) - tail)))))) - - (split (lambda-pattern/required pattern) bound - (lambda (required tail) - (split (lambda-pattern/optional pattern) tail - (lambda (optional rest) - (make-lambda* (lambda-pattern/name pattern) - required - optional - (if (null? rest) rest (car rest)) - body)))))) \ No newline at end of file diff --git a/v7/src/runtime/list.scm b/v7/src/runtime/list.scm deleted file mode 100644 index ba68e7f05..000000000 --- a/v7/src/runtime/list.scm +++ /dev/null @@ -1,468 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/list.scm,v 13.42 1987/02/11 02:22:09 cph Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; List Operations - -(declare (usual-integrations)) - -;;; This IN-PACKAGE is just a kludge to prevent the definitions of the -;;; primitives from shadowing the USUAL-INTEGRATIONS declaration. -#| Temporarily relocated to `boot.scm' to help compiler. -(in-package system-global-environment -(let-syntax () - (define-macro (define-primitives . names) - `(BEGIN ,@(map (lambda (name) - `(DEFINE ,name ,(make-primitive-procedure name))) - names))) - (define-primitives - cons pair? null? length car cdr set-car! set-cdr! - general-car-cdr memq assq)))|# - -(define (list . elements) - elements) - -(define (list? frob) - (cond ((null? frob) true) - ((pair? frob) (list? (cdr frob))) - (else false))) - -(define (cons* first-element . rest-elements) - (define (loop this-element rest-elements) - (if (null? rest-elements) - this-element - (cons this-element - (loop (car rest-elements) - (cdr rest-elements))))) - (loop first-element rest-elements)) - -(define (make-list size #!optional value) - (subvector->list (vector-cons size (if (unassigned? value) '() value)) - 0 - size)) - -(define (list-copy elements) - (apply list elements)) - -(define (list-ref l n) - (cond ((not (pair? l)) (error "LIST-REF: Bad argument" l n)) - ((zero? n) (car l)) - (else (list-ref (cdr l) (-1+ n))))) - -(define (list-tail l n) - (cond ((zero? n) l) - ((pair? l) (list-tail (cdr l) (-1+ n))) - (else (error "LIST-TAIL: Bad argument" l)))) - -(define the-empty-stream '()) -(define empty-stream? null?) -(define head car) - -(define (tail stream) - (force (cdr stream))) - -;;;; Standard Selectors - -(define (cddr x) (general-car-cdr x #o4)) -(define (cdar x) (general-car-cdr x #o5)) -(define (cadr x) (general-car-cdr x #o6)) -(define (caar x) (general-car-cdr x #o7)) - -(define (cdddr x) (general-car-cdr x #o10)) -(define (cddar x) (general-car-cdr x #o11)) -(define (cdadr x) (general-car-cdr x #o12)) -(define (cdaar x) (general-car-cdr x #o13)) -(define (caddr x) (general-car-cdr x #o14)) -(define (cadar x) (general-car-cdr x #o15)) -(define (caadr x) (general-car-cdr x #o16)) -(define (caaar x) (general-car-cdr x #o17)) - -(define (cddddr x) (general-car-cdr x #o20)) -(define (cdddar x) (general-car-cdr x #o21)) -(define (cddadr x) (general-car-cdr x #o22)) -(define (cddaar x) (general-car-cdr x #o23)) -(define (cdaddr x) (general-car-cdr x #o24)) -(define (cdadar x) (general-car-cdr x #o25)) -(define (cdaadr x) (general-car-cdr x #o26)) -(define (cdaaar x) (general-car-cdr x #o27)) -(define (cadddr x) (general-car-cdr x #o30)) -(define (caddar x) (general-car-cdr x #o31)) -(define (cadadr x) (general-car-cdr x #o32)) -(define (cadaar x) (general-car-cdr x #o33)) -(define (caaddr x) (general-car-cdr x #o34)) -(define (caadar x) (general-car-cdr x #o35)) -(define (caaadr x) (general-car-cdr x #o36)) -(define (caaaar x) (general-car-cdr x #o37)) - -(define first car) -(define (second x) (general-car-cdr x #o6)) -(define (third x) (general-car-cdr x #o14)) -(define (fourth x) (general-car-cdr x #o30)) -(define (fifth x) (general-car-cdr x #o60)) -(define (sixth x) (general-car-cdr x #o140)) -(define (seventh x) (general-car-cdr x #o300)) -(define (eighth x) (general-car-cdr x #o600)) - -;;;; Sequence Operations - -(define (append . lists) - (define (outer current remaining) - (define (inner list) - (cond ((pair? list) (cons (car list) (inner (cdr list)))) - ((null? list) (outer (car remaining) (cdr remaining))) - (else (error "APPEND: Argument not a list" current)))) - (if (null? remaining) - current - (inner current))) - (if (null? lists) - '() - (outer (car lists) (cdr lists)))) - -(define (append! . lists) - (define (loop head tail) - (cond ((null? tail) head) - ((null? head) (loop (car tail) (cdr tail))) - ((pair? head) - (set-cdr! (last-pair head) (loop (car tail) (cdr tail))) - head) - (else (error "APPEND!: Argument not a list" head)))) - (if (null? lists) - '() - (loop (car lists) (cdr lists)))) - -(define (reverse l) - (define (loop rest so-far) - (cond ((pair? rest) (loop (cdr rest) (cons (car rest) so-far))) - ((null? rest) so-far) - (else (error "REVERSE: Argument not a list" l)))) - (loop l '())) - -(define (reverse! l) - (define (loop current new-cdr) - (cond ((pair? current) (loop (set-cdr! current new-cdr) current)) - ((null? current) new-cdr) - (else (error "REVERSE!: Argument not a list" l)))) - (loop l '())) - -;;;; Mapping Procedures - -(define (map f . lists) - (cond ((null? lists) - (error "MAP: Too few arguments" f)) - ((null? (cdr lists)) - (let 1-loop ((list (car lists))) - (if (null? list) - '() - (cons (f (car list)) - (1-loop (cdr list)))))) - (else - (let n-loop ((lists lists)) - (let parse-cars - ((lists lists) - (receiver - (lambda (cars cdrs) - (cons (apply f cars) - (n-loop cdrs))))) - (cond ((null? lists) - (receiver '() '())) - ((null? (car lists)) - '()) - ((pair? (car lists)) - (parse-cars (cdr lists) - (lambda (cars cdrs) - (receiver (cons (car (car lists)) cars) - (cons (cdr (car lists)) cdrs))))) - (else - (error "MAP: Argument not a list" (car lists))))))))) - -(define (map* initial-value f . lists) - (cond ((null? lists) - (error "MAP*: Too few arguments" f)) - ((null? (cdr lists)) - (let 1-loop ((list (car lists))) - (if (null? list) - initial-value - (cons (f (car list)) - (1-loop (cdr list)))))) - (else - (let n-loop ((lists lists)) - (let parse-cars - ((lists lists) - (receiver - (lambda (cars cdrs) - (cons (apply f cars) - (n-loop cdrs))))) - (cond ((null? lists) - (receiver '() '())) - ((null? (car lists)) - initial-value) - ((pair? (car lists)) - (parse-cars (cdr lists) - (lambda (cars cdrs) - (receiver (cons (car (car lists)) cars) - (cons (cdr (car lists)) cdrs))))) - (else - (error "MAP*: Argument not a list" (car lists))))))))) - -(define (for-each f . lists) - (cond ((null? lists) - (error "FOR-EACH: Too few arguments" f)) - ((null? (cdr lists)) - (let 1-loop ((list (car lists))) - (if (null? list) - *the-non-printing-object* - (begin (f (car list)) - (1-loop (cdr list)))))) - (else - (let n-loop ((lists lists)) - (let parse-cars - ((lists lists) - (receiver - (lambda (cars cdrs) - (apply f cars) - (n-loop cdrs)))) - (cond ((null? lists) - (receiver '() '())) - ((null? (car lists)) - *the-non-printing-object*) - ((pair? (car lists)) - (parse-cars (cdr lists) - (lambda (cars cdrs) - (receiver (cons (car (car lists)) cars) - (cons (cdr (car lists)) cdrs))))) - (else - (error "FOR-EACH: Argument not a list" (car lists))))))))) - -(define mapcar map) -(define mapcar* map*) -(define mapc for-each) - -(define (there-exists? predicate) - (define (loop objects) - (and (pair? objects) - (or (predicate (car objects)) - (loop (cdr objects))))) - loop) - -(define (for-all? predicate) - (define (loop objects) - (if (pair? objects) - (and (predicate (car objects)) - (loop (cdr objects))) - true)) - loop) - -;;;; Generalized List Operations - -(define (positive-list-searcher predicate if-win if-lose) - (define (list-searcher-loop list) - (if (pair? list) - (if (predicate list) - (if-win list) - (list-searcher-loop (cdr list))) - (and if-lose (if-lose)))) - list-searcher-loop) - -(define (negative-list-searcher predicate if-win if-lose) - (define (list-searcher-loop list) - (if (pair? list) - (if (predicate list) - (list-searcher-loop (cdr list)) - (if-win list)) - (and if-lose (if-lose)))) - list-searcher-loop) - -(define (positive-list-transformer predicate tail) - (define (list-transform-loop list) - (if (pair? list) - (if (predicate (car list)) - (cons (car list) - (list-transform-loop (cdr list))) - (list-transform-loop (cdr list))) - tail)) - list-transform-loop) - -(define (negative-list-transformer predicate tail) - (define (list-transform-loop list) - (if (pair? list) - (if (predicate (car list)) - (list-transform-loop (cdr list)) - (cons (car list) - (list-transform-loop (cdr list)))) - tail)) - list-transform-loop) - -(define (list-deletor predicate) - (define (list-deletor-loop list) - (if (pair? list) - (if (predicate (car list)) - (list-deletor-loop (cdr list)) - (cons (car list) (list-deletor-loop (cdr list)))) - '())) - list-deletor-loop) - -(define (list-deletor! predicate) - (define (trim-initial-segment list) - (if (pair? list) - (if (predicate (car list)) - (trim-initial-segment (cdr list)) - (begin (locate-initial-segment list (cdr list)) - list)) - list)) - (define (locate-initial-segment last this) - (if (pair? this) - (if (predicate (car this)) - (set-cdr! last (trim-initial-segment (cdr this))) - (locate-initial-segment this (cdr this))) - this)) - trim-initial-segment) - -(define (list-transform-positive list predicate) - (let loop ((list list)) - (if (pair? list) - (if (predicate (car list)) - (cons (car list) (loop (cdr list))) - (loop (cdr list))) - '()))) - -(define (list-transform-negative list predicate) - (let loop ((list list)) - (if (pair? list) - (if (predicate (car list)) - (loop (cdr list)) - (cons (car list) (loop (cdr list)))) - '()))) - -(define (list-search-positive list predicate) - (let loop ((list list)) - (and (pair? list) - (if (predicate (car list)) - (car list) - (loop (cdr list)))))) - -(define (list-search-negative list predicate) - (let loop ((list list)) - (and (pair? list) - (if (predicate (car list)) - (loop (cdr list)) - (car list))))) - -;;;; Membership Lists - -(define (member-procedure predicate) - (lambda (element list) - (let loop ((list list)) - (and (pair? list) - (if (predicate (car list) element) - list - (loop (cdr list))))))) - -;(define memq (member-procedure eq?)) -(define memv (member-procedure eqv?)) -(define member (member-procedure equal?)) - -(define (delete-member-procedure deletor predicate) - (lambda (element list) - ((deletor (lambda (match) - (predicate match element))) - list))) - -(define delq (delete-member-procedure list-deletor eq?)) -(define delv (delete-member-procedure list-deletor eqv?)) -(define delete (delete-member-procedure list-deletor equal?)) - -(define delq! (delete-member-procedure list-deletor! eq?)) -(define delv! (delete-member-procedure list-deletor! eqv?)) -(define delete! (delete-member-procedure list-deletor! equal?)) - -;;;; Association Lists - -(define (association-procedure predicate selector) - (lambda (key alist) - (let loop ((alist alist)) - (and (pair? alist) - (if (predicate (selector (car alist)) key) - (car alist) - (loop (cdr alist))))))) - -;(define assq (association-procedure eq? car)) -(define assv (association-procedure eqv? car)) -(define assoc (association-procedure equal? car)) - -(define ((delete-association-procedure deletor predicate selector) key alist) - ((deletor (lambda (association) - (predicate (selector association) key))) - alist)) - -(define del-assq (delete-association-procedure list-deletor eq? car)) -(define del-assv (delete-association-procedure list-deletor eqv? car)) -(define del-assoc (delete-association-procedure list-deletor equal? car)) - -(define del-assq! (delete-association-procedure list-deletor! eq? car)) -(define del-assv! (delete-association-procedure list-deletor! eqv? car)) -(define del-assoc! (delete-association-procedure list-deletor! equal? car)) - -;;;; Lastness - -(define (last-pair l) - (if (pair? l) - (let loop ((l l)) - (if (pair? (cdr l)) - (loop (cdr l)) - l)) - (error "LAST-PAIR: Argument not a list" l))) - -(define (except-last-pair l) - (if (pair? l) - (let loop ((l l)) - (if (pair? (cdr l)) - (cons (car l) - (loop (cdr l))) - '())) - (error "EXCEPT-LAST-PAIR: Argument not a list" l))) - -(define (except-last-pair! l) - (if (pair? l) - (if (pair? (cdr l)) - (begin (let loop ((l l)) - (if (pair? (cddr l)) - (loop (cdr l)) - (set-cdr! l '()))) - l) - '()) - (error "EXCEPT-LAST-PAIR!: Argument not a list" l))) \ No newline at end of file diff --git a/v7/src/runtime/msort.scm b/v7/src/runtime/msort.scm deleted file mode 100644 index a14d3e95a..000000000 --- a/v7/src/runtime/msort.scm +++ /dev/null @@ -1,102 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/msort.scm,v 13.41 1987/01/23 00:15:59 jinx Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Merge Sort - -(declare (usual-integrations)) - -;; Functional and unstable but fairly fast - -(define (sort the-list p) - (define (loop l) - (if (and (pair? l) (pair? (cdr l))) - (split l '() '()) - l)) - - (define (split l one two) - (if (pair? l) - (split (cdr l) two (cons (car l) one)) - (merge (loop one) (loop two)))) - - (define (merge one two) - (cond ((null? one) two) - ((p (car two) (car one)) - (cons (car two) - (merge (cdr two) one))) - (else - (cons (car one) - (merge (cdr one) two))))) - - (loop the-list)) - -;; In-place and stable, fairly slow - -#| - -(define (sort! vector p) - (define (merge! source target low1 high1 low2 high2 point) - (define (loop low1 high1 low2 high2 point) - (cond ((= low1 high1) (transfer! source target low2 high2 point)) - ((p (vector-ref source low2) (vector-ref source low1)) - (vector-set! target point (vector-ref source low2)) - (loop (1+ low2) high2 low1 high1 (1+ point))) - (else - (vector-set! target point (vector-ref source low1)) - (loop (1+ low1) high1 low2 high2 (1+ point))))) - (loop low1 high1 low2 high2 point)) - (define (transfer! from to low high where) - (if (= low high) - 'DONE - (begin (vector-set! to where (vector-ref from low)) - (transfer! from to (1+ low) high (1+ where))))) - (define (split! source target low high) - (let ((bound (ceiling (/ (+ low high) 2)))) - (transfer! source target low bound low) - (transfer! source target bound high bound) - (do! target source low bound) - (do! target source bound high) - (merge! target source low bound bound high low))) - (define (do! source target low high) - (if (< high (+ low 2)) - 'DONE - (split! source target low high))) - (let ((size (vector-length vector))) - (do! vector (vector-cons size '()) 0 size) - vector)) -|# diff --git a/v7/src/runtime/numpar.scm b/v7/src/runtime/numpar.scm deleted file mode 100644 index d359592fc..000000000 --- a/v7/src/runtime/numpar.scm +++ /dev/null @@ -1,282 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/numpar.scm,v 13.42 1987/02/09 23:10:13 cph Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Number Parser - -(declare (usual-integrations)) - -(define string->number) - -(define number-parser-package - (make-environment - -;;; These are not supported right now. - -(define ->exact identity-procedure) -(define ->inexact identity-procedure) -(define ->long-flonum identity-procedure) -(define ->short-flonum identity-procedure) - -(define *radix*) - -(set! string->number -(named-lambda (string->number string #!optional exactness radix) - ((cond ((or (unassigned? exactness) (not exactness)) identity-procedure) - ((eq? exactness 'E) ->exact) - ((eq? exactness 'I) ->inexact) - (else (error "Illegal exactness argument" exactness))) - (fluid-let ((*radix* - (cond ((unassigned? radix) *parser-radix*) - ((memv radix '(2 8 10 16)) radix) - ((eq? radix 'B) 2) - ((eq? radix 'O) 8) - ((eq? radix 'D) 10) - ((eq? radix 'X) 16) - (else (error "Illegal radix argument" radix))))) - (parse-number (string->list string)))))) - -(define (parse-number chars) - (parse-real chars - (lambda (chars real) - (if (null? chars) - real - (case (car chars) - ((#\+ #\-) - (parse-real chars - (lambda (chars* real*) - (and (not (null? chars*)) - (null? (cdr chars*)) - (or (char-ci=? (car chars*) #\i) - (char-ci=? (car chars*) #\j)) - (make-rectangular real real*))))) - ((#\@) - (parse-real (cdr chars) - (lambda (chars real*) - (and (null? chars) - (make-polar real real*))))) - (else false)))))) - -(define (parse-real chars receiver) - (and (not (null? chars)) - (case (car chars) - ((#\+) - (parse-unsigned-real (cdr chars) - receiver)) - ((#\-) - (parse-unsigned-real (cdr chars) - (lambda (chars real) - (receiver chars (- real))))) - (else - (parse-unsigned-real chars - receiver))))) - -(define (parse-unsigned-real chars receiver) - (parse-prefix chars false false false - (lambda (chars radix exactness precision) - (define (finish) - (parse-body chars - (lambda (chars real) - (parse-suffix chars - (lambda (chars exponent) - (receiver chars - ((case exactness - ((#F) identity-procedure) - ((#\e) ->exact) - ((#\i) ->inexact)) - ((case precision - ((#F) identity-procedure) - ((#\s) ->short-flonum) - ((#\l) ->long-flonum)) - (if exponent - (* real (expt 10 exponent)) - real))))))))) - (if radix - (fluid-let ((*radix* - (cdr (assv radix - '((#\b . 2) - (#\o . 8) - (#\d . 10) - (#\x . 16)))))) - (finish)) - (finish))))) - -(define (parse-prefix chars radix exactness precision receiver) - (and (not (null? chars)) - (if (char=? (car chars) #\#) - (and (pair? (cdr chars)) - (let ((type (char-downcase (cadr chars))) - (rest (cddr chars))) - (let ((specify-prefix-type - (lambda (old) - (if old - (error "Respecification of prefix type" type) - type)))) - (case type - ((#\b #\o #\d #\x) - (parse-prefix rest - (specify-prefix-type radix) - exactness - precision - receiver)) - ((#\i #\e) - (parse-prefix rest - radix - (specify-prefix-type exactness) - precision - receiver)) - ((#\s #\l) - (parse-prefix rest - radix - exactness - (specify-prefix-type precision) - receiver)) - (else (error "Unknown prefix type" type)))))) - (receiver chars radix exactness precision)))) - -(define (parse-suffix chars receiver) - (if (and (not (null? chars)) - (char-ci=? (car chars) #\e)) - (parse-signed-suffix (cdr chars) receiver) - (receiver chars false))) - -(define (parse-signed-suffix chars receiver) - (and (not (null? chars)) - (case (car chars) - ((#\+) - (parse-unsigned-suffix (cdr chars) - receiver)) - ((#\-) - (parse-unsigned-suffix (cdr chars) - (lambda (chars exponent) - (receiver chars (- exponent))))) - (else - (parse-unsigned-suffix chars - receiver))))) - -(define (parse-unsigned-suffix chars receiver) - (define (parse-digit chars value if-digit) - (let ((digit (char->digit (car chars) 10))) - (if digit - (if-digit (cdr chars) digit) - (receiver chars value)))) - - (define (loop chars value) - (if (null? chars) - (receiver chars value) - (parse-digit chars value - (lambda (chars digit) - (loop chars (+ digit (* value 10))))))) - - (and (not (null? chars)) - (parse-digit chars false - loop))) - -(define (parse-body chars receiver) - (and (not (null? chars)) - (if (char=? (car chars) #\.) - (require-digit (cdr chars) - (lambda (chars digit) - (parse-fraction chars digit 1 - receiver))) - (parse-integer chars - (lambda (chars integer) - (if (null? chars) - (receiver chars integer) - (case (car chars) - ((#\/) - (parse-integer (cdr chars) - (lambda (chars denominator) - (receiver chars (/ integer denominator))))) - ((#\.) - (parse-fraction (cdr chars) 0 0 - (lambda (chars fraction) - (receiver chars (+ integer fraction))))) - (else - (receiver chars integer))))))))) - -(define (parse-integer chars receiver) - (define (loop chars integer) - (parse-digit/sharp chars - (lambda (chars count) - (receiver chars (->inexact (* integer (expt *radix* count))))) - (lambda (chars digit) - (loop chars (+ digit (* integer *radix*)))) - (lambda (chars) - (receiver chars integer)))) - (require-digit chars loop)) - -(define (parse-fraction chars integer place-value receiver) - (define (loop chars integer place-value) - (parse-digit/sharp chars - (lambda (chars count) - (finish chars (->inexact integer) place-value)) - (lambda (chars digit) - (loop chars - (+ digit (* integer *radix*)) - (1+ place-value))) - (lambda (chars) - (finish chars integer place-value)))) - - (define (finish chars integer place-value) - (receiver chars (/ integer (expt *radix* place-value)))) - - (loop chars integer place-value)) - -(define (require-digit chars receiver) - (and (not (null? chars)) - (let ((digit (char->digit (car chars) *radix*))) - (and digit - (receiver (cdr chars) digit))))) - -(define (parse-digit/sharp chars if-sharp if-digit otherwise) - (cond ((null? chars) (otherwise chars)) - ((char=? (car chars) #\#) - (let count-sharps ((chars (cdr chars)) (count 1)) - (if (and (not (null? chars)) - (char=? (car chars) #\#)) - (count-sharps (cdr chars) (1+ count)) - (if-sharp chars count)))) - (else - (let ((digit (char->digit (car chars) *radix*))) - (if digit - (if-digit (cdr chars) digit) - (otherwise chars)))))) - -;;; end NUMBER-PARSER-PACKAGE -)) diff --git a/v7/src/runtime/output.scm b/v7/src/runtime/output.scm deleted file mode 100644 index 7f2764d4b..000000000 --- a/v7/src/runtime/output.scm +++ /dev/null @@ -1,326 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/output.scm,v 13.42 1987/02/15 15:45:07 cph Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Output - -(declare (usual-integrations)) - -;;;; Output Ports - -(define output-port-tag - "Output Port") - -(define (output-port? object) - (and (environment? object) - (not (lexical-unreferenceable? object ':TYPE)) - (eq? (access :type object) output-port-tag))) - -(define *current-output-port*) - -(define (current-output-port) - *current-output-port*) - -(define (with-output-to-port port thunk) - (if (not (output-port? port)) (error "Bad output port" port)) - (fluid-let ((*current-output-port* port)) - (thunk))) - -(define (with-output-to-file output-specifier thunk) - (define new-port (open-output-file output-specifier)) - (define old-port) - (dynamic-wind (lambda () - (set! old-port - (set! *current-output-port* - (set! new-port)))) - thunk - (lambda () - (let ((port)) - ;; Only SET! is guaranteed to do the right thing with - ;; an unassigned value. Binding may not work right. - (set! port (set! *current-output-port* (set! old-port))) - (if (not (unassigned? port)) - (close-output-port port)))))) - -(define (call-with-output-file output-specifier receiver) - (let ((port (open-output-file output-specifier))) - (let ((value (receiver port))) - (close-output-port port) - value))) - -(define (close-output-port port) - ((access :close port))) - -;;;; Console Output Port - -(define beep - (make-primitive-procedure 'TTY-BEEP)) - -(define (screen-clear) - ((access :clear-screen console-output-port)) - ((access :flush-output console-output-port))) - -(define console-output-port) -(let () - -(define tty-write-char - (make-primitive-procedure 'TTY-WRITE-CHAR)) - -(define tty-write-string - (make-primitive-procedure 'TTY-WRITE-STRING)) - -(define tty-flush-output - (make-primitive-procedure 'TTY-FLUSH-OUTPUT)) - -(define tty-clear - (make-primitive-procedure 'TTY-CLEAR)) - -(set! console-output-port - (make-environment - -(define :type output-port-tag) - -(define (:print-self) - (unparse-with-brackets - (lambda () - (write-string "Console output port")))) - -(define (:close) 'DONE) -(define :write-char tty-write-char) -(define :write-string tty-write-string) -(define :flush-output tty-flush-output) -(define :clear-screen tty-clear) - -(define (:x-size) - (access printer-width implementation-dependencies)) - -(define (:y-size) - (access printer-length implementation-dependencies)) - -;;; end CONSOLE-OUTPUT-PORT. -)) - -) - -(set! *current-output-port* console-output-port) - -;;; File Output Ports - -(define open-output-file) -(let () -#| -(declare (integrate-primitive-procedures file-write-char file-write-string)) -|# -(define file-write-char - (make-primitive-procedure 'FILE-WRITE-CHAR)) - -(define file-write-string - (make-primitive-procedure 'FILE-WRITE-STRING)) - -(set! open-output-file -(named-lambda (open-output-file filename) - (make-file-output-port - ((access open-output-channel primitive-io) - (canonicalize-output-filename filename))))) - -(define (make-file-output-port file-channel) - -(define :type output-port-tag) - -(define (:print-self) - (unparse-with-brackets - (lambda () - (write-string "Output port for file: ") - (write ((access channel-name primitive-io) file-channel))))) - -(define (:close) - ((access close-physical-channel primitive-io) file-channel)) - -(define (:write-char char) - (file-write-char char file-channel)) - -(define (:write-string string) - (file-write-string string file-channel)) - -(define (:flush-output) 'DONE) -(define (:x-size) false) -(define (:y-size) false) - -;;; end MAKE-FILE-OUTPUT-PORT. -(the-environment)) - -) - -;;;; String Output Ports - -(define (write-to-string object #!optional max) - (if (unassigned? max) (set! max false)) - (if (not max) - (with-output-to-string - (lambda () - (write object))) - (with-output-to-truncated-string max - (lambda () - (write object))))) - -(define (with-output-to-string thunk) - (let ((port (string-output-port))) - (fluid-let ((*current-output-port* port)) - (thunk)) - ((access :value port)))) - -(define (string-output-port) - -(define :type output-port-tag) - -(define (:print-self) - (unparse-with-brackets - (lambda () - (write-string "Output port to string")))) - -(define accumulator '()) - -(define (:value) - (let ((string (apply string-append (reverse! accumulator)))) - (set! accumulator (list string)) - string)) - -(define (:write-char char) - (set! accumulator (cons (char->string char) accumulator))) - -(define (:write-string string) - (set! accumulator (cons string accumulator))) - -(define (:close) 'DONE) -(define (:flush-output) 'DONE) -(define (:x-size) false) -(define (:y-size) false) - -;;; end STRING-OUTPUT-PORT. -(the-environment)) - -(define (with-output-to-truncated-string maxsize thunk) - (call-with-current-continuation - (lambda (return) - -(define :type output-port-tag) - -(define (:print-self) - (unparse-with-brackets - (lambda () - (write-string "Output port to truncated string")))) - -(define accumulator '()) -(define counter maxsize) - -(define (:write-char char) - (:write-string (char->string char))) - -(define (:write-string string) - (set! accumulator (cons string accumulator)) - (set! counter (- counter (string-length string))) - (if (negative? counter) - (return (cons true - (substring (apply string-append (reverse! accumulator)) - 0 maxsize))))) - -(define (:close) 'DONE) -(define (:flush-output) 'DONE) -(define (:x-size) false) -(define (:y-size) false) - -(fluid-let ((*current-output-port* (the-environment))) - (thunk)) -(cons false (apply string-append (reverse! accumulator))) - -;;; end WITH-OUTPUT-TO-TRUNCATED-STRING. -))) - -;;;; Output Procedures - -(define (write-char char #!optional port) - (cond ((unassigned? port) (set! port *current-output-port*)) - ((not (output-port? port)) (error "Bad output port" port))) - ((access :write-char port) char) - ((access :flush-output port)) - *the-non-printing-object*) - -(define (write-string string #!optional port) - (cond ((unassigned? port) (set! port *current-output-port*)) - ((not (output-port? port)) (error "Bad output port" port))) - ((access :write-string port) string) - ((access :flush-output port)) - *the-non-printing-object*) - -(define (newline #!optional port) - (cond ((unassigned? port) (set! port *current-output-port*)) - ((not (output-port? port)) (error "Bad output port" port))) - ((access :write-char port) char:newline) - ((access :flush-output port)) - *the-non-printing-object*) - -(define (display object #!optional port) - (cond ((unassigned? port) (set! port *current-output-port*)) - ((not (output-port? port)) (error "Bad output port" port))) - (if (not (non-printing-object? object)) - (begin (if (and (not (future? object)) (string? object)) - ((access :write-string port) object) - ((access unparse-object unparser-package) object port false)) - ((access :flush-output port)))) - *the-non-printing-object*) - -(define (write object #!optional port) - (cond ((unassigned? port) (set! port *current-output-port*)) - ((not (output-port? port)) (error "Bad output port" port))) - (if (not (non-printing-object? object)) - (begin ((access unparse-object unparser-package) object port) - ((access :flush-output port)))) - *the-non-printing-object*) - -(define (write-line object #!optional port) - (cond ((unassigned? port) (set! port *current-output-port*)) - ((not (output-port? port)) (error "Bad output port" port))) - (if (not (non-printing-object? object)) - (begin ((access :write-char port) char:newline) - ((access unparse-object unparser-package) object port) - ((access :flush-output port)))) - *the-non-printing-object*) - -(define (non-printing-object? object) - (and (not (future? object)) - ((access :flush-output port)))))) \ No newline at end of file diff --git a/v7/src/runtime/parse.scm b/v7/src/runtime/parse.scm deleted file mode 100644 index fda41feae..000000000 --- a/v7/src/runtime/parse.scm +++ /dev/null @@ -1,476 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/parse.scm,v 13.42 1987/03/17 18:51:44 cph Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Scheme Parser - -(declare (usual-integrations)) - -(define *parser-radix* #d10) -(define *parser-table*) - -(define parser-package - (make-environment - -(define *parser-parse-object-table*) -(define *parser-collect-list-table*) -(define *parser-parse-object-special-table*) -(define *parser-collect-list-special-table*) -(define *parser-peek-char*) -(define *parser-discard-char*) -(define *parser-read-char*) -(define *parser-read-string*) -(define *parser-discard-chars*) -(define *parser-input-port*) - -(define (*parse-object port) - (fluid-let ((*parser-input-port* port) - (*parser-parse-object-table* (caar *parser-table*)) - (*parser-collect-list-table* (cdar *parser-table*)) - (*parser-parse-object-special-table* (cadr *parser-table*)) - (*parser-collect-list-special-table* (cddr *parser-table*)) - (*parser-peek-char* (access :peek-char port)) - (*parser-discard-char* (access :discard-char port)) - (*parser-read-char* (access :read-char port)) - (*parser-read-string* (access :read-string port)) - (*parser-discard-chars* (access :discard-chars port))) - (parse-object))) - -(define (*parse-objects-until-eof port) - (fluid-let ((*parser-input-port* port) - (*parser-parse-object-table* (caar *parser-table*)) - (*parser-collect-list-table* (cdar *parser-table*)) - (*parser-parse-object-special-table* (cadr *parser-table*)) - (*parser-collect-list-special-table* (cddr *parser-table*)) - (*parser-peek-char* (access :peek-char port)) - (*parser-discard-char* (access :discard-char port)) - (*parser-read-char* (access :read-char port)) - (*parser-read-string* (access :read-string port)) - (*parser-discard-chars* (access :discard-chars port))) - (define (loop object) - (if (eof-object? object) - '() - (cons object (loop (parse-object))))) - (loop (parse-object)))) - -;;;; Character Operations - -(declare (integrate peek-char read-char discard-char - read-string discard-chars)) - -(define (peek-char) - (or (*parser-peek-char*) - (error "End of file within READ"))) - -(define (read-char) - (or (*parser-read-char*) - (error "End of file within READ"))) - -(define (discard-char) - (*parser-discard-char*)) - -(define (read-string delimiters) - (declare (integrate delimiters)) - (*parser-read-string* delimiters)) - -(define (discard-chars delimiters) - (declare (integrate delimiters)) - (*parser-discard-chars* delimiters)) - -;;; There are two major dispatch tables, one for parsing at top level, -;;; the other for parsing the elements of a list. Most of the entries -;;; for each table are have similar actions. - -;;; Default is atomic object. Parsing an atomic object does not -;;; consume its terminator. Thus different terminators [such as open -;;; paren, close paren, and whitespace], can have different effects on -;;; parser. - -(define (parse-object:atom) - (build-atom (read-atom))) - -(define ((collect-list-wrapper object-parser)) - (let ((value (object-parser))) ;forces order. - (cons value (collect-list)))) - -(define (parse-undefined-special) - (error "No such special reader macro" (peek-char))) - -(set! *parser-table* - (cons (cons (vector-cons 256 parse-object:atom) - (vector-cons 256 (collect-list-wrapper parse-object:atom))) - (cons (vector-cons 256 parse-undefined-special) - (vector-cons 256 parse-undefined-special)))) - -(define ((parser-char-definer tables) - char/chars procedure #!optional list-procedure) - (if (unassigned? list-procedure) - (set! list-procedure (collect-list-wrapper procedure))) - (define (do-it char) - (vector-set! (car tables) (char->ascii char) procedure) - (vector-set! (cdr tables) (char->ascii char) list-procedure)) - (cond ((char? char/chars) (do-it char/chars)) - ((char-set? char/chars) - (for-each do-it (char-set-members char/chars))) - ((pair? char/chars) (for-each do-it char/chars)) - (else (error "Unknown character" char/chars)))) - -(define define-char - (parser-char-definer (car *parser-table*))) - -(define define-char-special - (parser-char-definer (cdr *parser-table*))) - -(declare (integrate peek-ascii parse-object collect-list)) - -(define (peek-ascii) - (or (char-ascii? (peek-char)) - (non-ascii-error))) - -(define (non-ascii-error) - (error "Non-ASCII character encountered during parse" (read-char))) - -(define (parse-object) - (let ((char (*parser-peek-char*))) - (if char - ((vector-ref *parser-parse-object-table* - (or (char-ascii? char) - (non-ascii-error)))) - eof-object))) - -(define (collect-list) - ((vector-ref *parser-collect-list-table* (peek-ascii)))) - -(define-char #\# - (lambda () - (discard-char) - ((vector-ref *parser-parse-object-special-table* (peek-ascii)))) - (lambda () - (discard-char) - ((vector-ref *parser-collect-list-special-table* (peek-ascii))))) - -(define numeric-leaders - (char-set-union char-set:numeric - (char-set #\+ #\- #\. #\#))) - -(define undefined-atom-delimiters - (char-set #\[ #\] #\{ #\} #\|)) - -(define atom-delimiters - (char-set-union char-set:whitespace - (char-set-union undefined-atom-delimiters - (char-set #\( #\) #\; #\" #\' #\`)))) - -(define atom-constituents - (char-set-invert atom-delimiters)) - -(declare (integrate read-atom)) - -(define (read-atom) - (read-string atom-delimiters)) - -(define (build-atom string) - (or (parse-number string) - (intern-string! string))) - -(declare (integrate parse-number)) - -(define (parse-number string) - (declare (integrate string)) - (string->number string false *parser-radix*)) - -(define (intern-string! string) - (substring-upcase! string 0 (string-length string)) - (string->symbol string)) - -(define-char (char-set-difference atom-constituents numeric-leaders) - (lambda () - (intern-string! (read-atom)))) - -(let ((numeric-prefix - (lambda () - (let ((number - (let ((char (read-char))) - (string-append (char->string #\# char) (read-atom))))) - (or (parse-number number) - (error "READ: Bad number syntax" number)))))) - (define-char-special '(#\b #\B) numeric-prefix) - (define-char-special '(#\o #\O) numeric-prefix) - (define-char-special '(#\d #\D) numeric-prefix) - (define-char-special '(#\x #\X) numeric-prefix) - (define-char-special '(#\i #\I) numeric-prefix) - (define-char-special '(#\e #\E) numeric-prefix) - (define-char-special '(#\s #\S) numeric-prefix) - (define-char-special '(#\l #\L) numeric-prefix)) - -(define-char #\( - (lambda () - (discard-char) - (collect-list))) - -(define-char-special #\( - (lambda () - (discard-char) - (list->vector (collect-list)))) - -(define-char #\) - (lambda () - (if (not (eq? console-input-port *parser-input-port*)) - (error "PARSE-OBJECT: Unmatched close paren" (read-char)) - (read-char)) - (parse-object)) - (lambda () - (discard-char) - '())) - -(define-char undefined-atom-delimiters - (lambda () - (error "PARSE-OBJECT: Undefined atom delimiter" (read-char)) - (parse-object)) - (lambda () - (error "PARSE-OBJECT: Undefined atom delimiter" (read-char)) - (collect-list))) - -(let () - -(vector-set! (cdar *parser-table*) - (char->ascii #\.) - (lambda () - (discard-char) - ;; atom with initial dot? - (if (char-set-member? atom-constituents (peek-char)) - (let ((first (build-atom (string-append "." (read-atom))))) - (cons first (collect-list))) - - ;; (A . B) -- get B and ignore whitespace following it. - (let ((tail (parse-object))) - (discard-whitespace) - (if (not (char=? (peek-char) #\))) - (error "Illegal character in ignored stream" (peek-char))) - (discard-char) - tail)))) - -(define-char char-set:whitespace - (lambda () - (discard-whitespace) - (parse-object)) - (lambda () - (discard-whitespace) - (collect-list))) - -(define (discard-whitespace) - (discard-chars non-whitespace)) - -(define non-whitespace - (char-set-invert char-set:whitespace)) - -) - -(let () - -(define-char #\; - (lambda () - (discard-comment) - (parse-object)) - (lambda () - (discard-comment) - (collect-list))) - -(define (discard-comment) - (discard-char) - (discard-chars comment-delimiters) - (discard-char)) - -(define comment-delimiters - (char-set char:newline)) - -) - -(let () - -(define-char-special #\| - (lambda () - (discard-char) - (discard-special-comment) - (parse-object)) - (lambda () - (discard-char) - (discard-special-comment) - (collect-list))) - -(define (discard-special-comment) - (discard-chars special-comment-leaders) - (if (char=? #\| (read-char)) - (if (char=? #\# (peek-char)) - (discard-char) - (discard-special-comment)) - (begin (if (char=? #\| (peek-char)) - (begin (discard-char) - (discard-special-comment))) - (discard-special-comment)))) - -(define special-comment-leaders - (char-set #\# #\|)) - -) - -(define-char #\' - (lambda () - (discard-char) - (list 'QUOTE (parse-object)))) - -(define-char #\` - (lambda () - (discard-char) - (list 'QUASIQUOTE (parse-object)))) - -(define-char #\, - (lambda () - (discard-char) - (if (char=? #\@ (peek-char)) - (begin (discard-char) - (list 'UNQUOTE-SPLICING (parse-object))) - (list 'UNQUOTE (parse-object))))) - -(define-char #\" - (let ((delimiters (char-set #\" #\\))) - (lambda () - (define (loop string) - (if (char=? #\" (read-char)) - string - (let ((char (read-char))) - (string-append string - (char->string - (cond ((char-ci=? char #\t) #\Tab) - ((char-ci=? char #\n) char:newline) - ((char-ci=? char #\f) #\Page) - (else char))) - (loop (read-string delimiters)))))) - (discard-char) - (loop (read-string delimiters))))) - -(define-char-special #\\ - (let ((delimiters (char-set-union (char-set #\- #\\) atom-delimiters))) - (lambda () - (define (loop) - (cond ((char=? #\\ (peek-char)) - (discard-char) - (char->string (read-char))) - ((char-set-member? delimiters (peek-char)) - (char->string (read-char))) - (else - (let ((string (read-string delimiters))) - (if (char=? #\- (peek-char)) - (begin (discard-char) - (string-append string "-" (loop))) - string))))) - (discard-char) - (if (char=? #\\ (peek-char)) - (read-char) - (name->char (loop)))))) - -(define ((fixed-object-parser object)) - (discard-char) - object) - -(define-char-special '(#\f #\F) (fixed-object-parser false)) -(define-char-special '(#\t #\T) (fixed-object-parser true)) - -(define-char-special #\! - (lambda () - (discard-char) - (let ((object-name (parse-object))) - (cdr (or (assq object-name named-objects) - (error "No object by this name" object-name)))))) - -(define named-objects - `((NULL . ,(list)) - (FALSE . ,(eq? 'TRUE 'FALSE)) - (TRUE . ,(eq? 'TRUE 'TRUE)) - (OPTIONAL . ,(access lambda-optional-tag lambda-package)) - (REST . ,(access lambda-rest-tag lambda-package)))) - -;;; end PARSER-PACKAGE. -)) - -;;;; Parser Tables - -(define (parser-table-copy table) - (cons (cons (vector-copy (caar table)) - (vector-copy (cdar table))) - (cons (vector-copy (cadr table)) - (vector-copy (cddr table))))) - -(define parser-table-entry) -(define set-parser-table-entry!) -(let () - -(define (decode-parser-char table char receiver) - (cond ((char? char) - (receiver (car table) (char->ascii char))) - ((string? char) - (cond ((= (string-length char) 1) - (receiver (car table) (char->ascii (string-ref char 0)))) - ((and (= (string-length char) 2) - (char=? #\# (string-ref char 0))) - (receiver (cdr table) (char->ascii (string-ref char 1)))) - (else - (error "Bad character" 'DECODE-PARSER-CHAR char)))) - (else - (error "Bad character" 'DECODE-PARSER-CHAR char)))) - -(define (ptable-ref table index) - (cons (vector-ref (car table) index) - (vector-ref (cdr table) index))) - -(define (ptable-set! table index value) - (vector-set! (car table) index (car value)) - (vector-set! (cdr table) index (cdr value))) - -(set! parser-table-entry -(named-lambda (parser-table-entry table char) - (decode-parser-char table char ptable-ref))) - -(set! set-parser-table-entry! -(named-lambda (set-parser-table-entry! table char entry) - (decode-parser-char table char - (lambda (sub-table index) - (ptable-set! sub-table index entry))))) - -) - diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm deleted file mode 100644 index ec558658f..000000000 --- a/v7/src/runtime/pathnm.scm +++ /dev/null @@ -1,247 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 13.42 1987/03/12 02:16:14 jinx Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Pathnames - -(declare (usual-integrations)) - -;;; A pathname component is normally one of: - -;;; * A string, which is the literal component. - -;;; * 'WILD, meaning that the component is wildcarded. Such -;;; components may have special meaning to certain directory -;;; operations. - -;;; * 'UNSPECIFIC, meaning that the component was supplied, but null. -;;; This means about the same thing as "". (maybe it should be -;;; eliminated in favor of that?) - -;;; * #F, meaning that the component was not supplied. This has -;;; special meaning to `merge-pathnames', in which such components are -;;; substituted. - -;;; A pathname consists of 5 components, not all necessarily -;;; meaningful, as follows: - -;;; * The DEVICE is usually a physical device, as in the Twenex `ps:'. - -;;; * The DIRECTORY is a list of components. If the first component -;;; is the null string, then the directory path is absolute. -;;; Otherwise it is relative. - -;;; * The NAME is the proper name part of the filename. - -;;; * The TYPE usually indicates something about the contents of the -;;; file. Certain system procedures will default the type to standard -;;; type strings. - -;;; * The VERSION is special. Unlike an ordinary component, it is -;;; never a string, but may be either a positive integer, 'NEWEST, -;;; 'WILD, 'UNSPECIFIC, or #F. Many system procedures will default -;;; the version to 'NEWEST, which means to search the directory for -;;; the highest version numbered file. - -;;; This file requires the following procedures and variables which -;;; define the conventions for the particular file system in use: -;;; -;;; (symbol->pathname symbol) -;;; (string->pathname string) -;;; (pathname-unparse device directory name type version) -;;; (pathname-unparse-name name type version) -;;; (simplify-directory directory) -;;; working-directory-package -;;; (access reset! working-directory-package) -;;; init-file-pathname -;;; (home-directory-pathname) -;;; (working-directory-pathname) -;;; (set-working-directory-pathname! name) -;;; -;;; See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples. - -;;;; Basic Pathnames - -(define (pathname? object) - (and (environment? object) - (eq? (environment-procedure object) make-pathname))) - -(define (make-pathname device directory name type version) - (define string #F) - - (define (:print-self) - (unparse-with-brackets - (lambda () - (write-string "PATHNAME ") - (write (pathname->string (the-environment)))))) - - (the-environment)) - -(define (pathname-components pathname receiver) - (receiver (access device pathname) - (access directory pathname) - (access name pathname) - (access type pathname) - (access version pathname))) - -(define (pathname-device pathname) - (access device pathname)) - -(define (pathname-directory pathname) - (access directory pathname)) - -(define (pathname-name pathname) - (access name pathname)) - -(define (pathname-type pathname) - (access type pathname)) - -(define (pathname-version pathname) - (access version pathname)) - -(define (pathname-extract pathname . fields) - (pathname-components pathname - (lambda (device directory name type version) - (make-pathname (and (memq 'DEVICE fields) device) - (and (memq 'DIRECTORY fields) directory) - (and (memq 'NAME fields) name) - (and (memq 'TYPE fields) type) - (and (memq 'VERSION fields) version))))) - -(define (pathname-absolute? pathname) - (let ((directory (pathname-directory pathname))) - (and (not (null? directory)) - (string-null? (car directory))))) - -(define (pathname-new-device pathname device) - (pathname-components pathname - (lambda (old-device directory name type version) - (make-pathname device directory name type version)))) - -(define (pathname-new-directory pathname directory) - (pathname-components pathname - (lambda (device old-directory name type version) - (make-pathname device directory name type version)))) - -(define (pathname-new-name pathname name) - (pathname-components pathname - (lambda (device directory old-name type version) - (make-pathname device directory name type version)))) - -(define (pathname-new-type pathname type) - (pathname-components pathname - (lambda (device directory name old-type version) - (make-pathname device directory name type version)))) - -(define (pathname-new-version pathname version) - (pathname-components pathname - (lambda (device directory name type old-version) - (make-pathname device directory name type version)))) - -(define (pathname-directory-path pathname) - (pathname-components pathname - (lambda (device directory name type version) - (make-pathname device directory #F #F #F)))) - -(define (pathname-directory-string pathname) - (pathname-components pathname - (lambda (device directory name type version) - (pathname-unparse device directory #F #F #F)))) - -(define (pathname-name-path pathname) - (pathname-components pathname - (lambda (device directory name type version) - (make-pathname #F #F name type version)))) - -(define (pathname-name-string pathname) - (pathname-components pathname - (lambda (device directory name type version) - (pathname-unparse #F #F name type version)))) - -;;;; Parse and unparse. - -;;; Defined in terms of operating system dependent procedures. - -(define (->pathname object) - (cond ((pathname? object) object) - ((string? object) (string->pathname object)) - ((symbol? object) (symbol->pathname object)) - (else (error "Unable to coerce into pathname" object)))) - -(define (pathname->string pathname) - (or (access string pathname) - (let ((string (pathname-components pathname pathname-unparse))) - (set! (access string pathname) string) - string))) - -(define (pathname-extract-string pathname . fields) - (pathname-components pathname - (lambda (device directory name type version) - (pathname-unparse (and (memq 'DEVICE fields) device) - (and (memq 'DIRECTORY fields) directory) - (and (memq 'NAME fields) name) - (and (memq 'TYPE fields) type) - (and (memq 'VERSION fields) version))))) - -;;;; Merging pathnames - -(define (merge-pathnames pathname default) - (make-pathname (or (pathname-device pathname) (pathname-device default)) - (simplify-directory - (let ((directory (pathname-directory pathname))) - (cond ((null? directory) (pathname-directory default)) - ((string-null? (car directory)) directory) - (else - (append (pathname-directory default) directory))))) - (or (pathname-name pathname) (pathname-name default)) - (or (pathname-type pathname) (pathname-type default)) - (or (pathname-version pathname) (pathname-version default)))) - -(define (pathname-as-directory pathname) - (let ((file (pathname-unparse-name (pathname-name pathname) - (pathname-type pathname) - (pathname-version pathname)))) - (if (string-null? file) - pathname - (make-pathname (pathname-device pathname) - (append (pathname-directory pathname) - (list file)) - #F #F #F)))) - -(define (pathname->absolute-pathname pathname) - (merge-pathnames pathname (working-directory-pathname))) diff --git a/v7/src/runtime/pp.scm b/v7/src/runtime/pp.scm deleted file mode 100644 index 187586c26..000000000 --- a/v7/src/runtime/pp.scm +++ /dev/null @@ -1,465 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 13.42 1987/03/17 18:52:08 cph Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Pretty Printer - -(declare (usual-integrations)) - -(define scheme-pretty-printer - (make-environment - -(define *pp-primitives-by-name* true) -(define *forced-x-size* false) -(define *default-x-size* 80) - -(define x-size) -(define next-coords) -(define add-sc-entry!) -(define sc-relink!) - -(declare (integrate *unparse-string *unparse-char)) - -(define (*unparse-string string) - (declare (integrate string)) - ((access :write-string *current-output-port*) string)) - -(define (*unparse-char char) - (declare (integrate char)) - ((access :write-char *current-output-port*) char)) - -(define (*unparse-open) - (*unparse-char #\()) - -(define (*unparse-close) - (*unparse-char #\))) - -(define (*unparse-space) - (*unparse-char #\Space)) - -(define (*unparse-newline) - (*unparse-char char:newline)) - -;;;; Top Level - -(define (pp expression as-code?) - (fluid-let ((x-size (get-x-size))) - (let ((node (numerical-walk expression))) - (*unparse-newline) - ((if as-code? print-node print-non-code-node) node 0 0) - ((access :flush-output *current-output-port*))))) - -(define (stepper-pp expression port p-wrapper table nc relink! sc! offset) - (fluid-let ((x-size (get-x-size)) - (walk-dispatcher table) - (next-coords nc) - (sc-relink! relink!) - (add-sc-entry! sc!) - (print-combination (p-wrapper print-combination)) - (forced-indentation (p-wrapper forced-indentation)) - (pressured-indentation (p-wrapper pressured-indentation)) - (print-procedure (p-wrapper print-procedure)) - (print-let-expression (p-wrapper print-let-expression)) - (print-node (p-wrapper print-node)) - (print-guaranteed-node (p-wrapper print-guaranteed-node))) - (let ((node (numerical-walk expression))) - (with-output-to-port port - (lambda () - (print-node node (car offset) 0) - ((access :flush-output *current-output-port*))))))) - -(define (get-x-size) - (or *forced-x-size* - ((access :x-size *current-output-port*)) - *default-x-size*)) - -(define (print-non-code-node node column depth) - (fluid-let ((dispatch-list '())) - (print-node node column depth))) - -(define (print-node node column depth) - (cond ((list-node? node) (print-list-node node column depth)) - ((symbol? node) (*unparse-symbol node)) - ((prefix-node? node) (*unparse-string (node-prefix node)) - (print-node (node-subnode node) - (+ (string-length (node-prefix node)) column) - depth)) - (else (*unparse-string node)))) - -(define (print-list-node node column depth) - (if (fits-within? node column depth) - (print-guaranteed-list-node node) - (let ((subnodes (node-subnodes node))) - ((or (let ((association (assq (car subnodes) dispatch-list))) - (and association (cdr association))) - print-combination) - subnodes column depth)))) - -(define (print-guaranteed-node node) - (cond ((list-node? node) (print-guaranteed-list-node node)) - ((symbol? node) (*unparse-symbol node)) - ((prefix-node? node) - (*unparse-string (node-prefix node)) - (print-guaranteed-node (node-subnode node))) - (else (*unparse-string node)))) - -(define (print-guaranteed-list-node node) - (define (loop nodes) - (print-guaranteed-node (car nodes)) - (if (not (null? (cdr nodes))) - (begin (*unparse-space) - (loop (cdr nodes))))) - (*unparse-open) - (loop (node-subnodes node)) - (*unparse-close)) - -(define (print-column nodes column depth) - (define (loop nodes) - (if (null? (cdr nodes)) - (print-node (car nodes) column depth) - (begin (print-node (car nodes) column 0) - (tab-to column) - (loop (cdr nodes))))) - (loop nodes)) - -(define (print-guaranteed-column nodes column) - (define (loop nodes) - (print-guaranteed-node (car nodes)) - (if (not (null? (cdr nodes))) - (begin (tab-to column) - (loop (cdr nodes))))) - (loop nodes)) - -;;;; Printers - -(define (print-combination nodes column depth) - (*unparse-open) - (let ((column (1+ column)) (depth (1+ depth))) - (cond ((null? (cdr nodes)) - (print-node (car nodes) column depth)) - ((two-on-first-line? nodes column depth) - (print-guaranteed-node (car nodes)) - (*unparse-space) - (print-guaranteed-column (cdr nodes) - (1+ (+ column (node-size (car nodes)))))) - (else - (print-column nodes column depth)))) - (*unparse-close)) - -(define ((special-printer procedure) nodes column depth) - (*unparse-open) - (*unparse-symbol (car nodes)) - (*unparse-space) - (if (not (null? (cdr nodes))) - (procedure (cdr nodes) - (+ 2 (+ column (symbol-length (car nodes)))) - (+ 2 column) - (1+ depth))) - (*unparse-close)) - -;;; Force the indentation to be an optimistic column. - -(define forced-indentation - (special-printer - (lambda (nodes optimistic pessimistic depth) - (print-column nodes optimistic depth)))) - -;;; Pressure the indentation to be an optimistic column; no matter -;;; what happens, insist on a column, but accept a pessimistic one if -;;; necessary. - -(define pressured-indentation - (special-printer - (lambda (nodes optimistic pessimistic depth) - (if (fits-as-column? nodes optimistic depth) - (print-guaranteed-column nodes optimistic) - (begin (tab-to pessimistic) - (print-column nodes pessimistic depth)))))) - -;;; Print a procedure definition. The bound variable pattern goes on -;;; the same line as the keyword, while everything else gets indented -;;; pessimistically. We may later want to modify this to make higher -;;; order procedure patterns be printed more carefully. - -(define print-procedure - (special-printer - (lambda (nodes optimistic pessimistic depth) - (print-node (car nodes) optimistic 0) - (tab-to pessimistic) - (print-column (cdr nodes) pessimistic depth)))) - -;;; Print a binding form. There is a great deal of complication here, -;;; some of which is to gracefully handle the case of a badly-formed -;;; binder. But most important is the code that handles the name when -;;; we encounter a named LET; it must go on the same line as the -;;; keyword. In that case, the bindings try to fit on that line or -;;; start on that line if possible; otherwise they line up under the -;;; name. The body, of course, is always indented pessimistically. - -(define print-let-expression - (special-printer - (lambda (nodes optimistic pessimistic depth) - (define (print-body nodes) - (if (not (null? nodes)) - (begin (tab-to pessimistic) - (print-column nodes pessimistic depth)))) - (cond ((null? (cdr nodes)) ;Screw case. - (print-node (car nodes) optimistic depth)) - ((symbol? (car nodes)) ;Named LET. - (*unparse-symbol (car nodes)) - (let ((new-optimistic - (1+ (+ optimistic (symbol-length (car nodes)))))) - (cond ((fits-within? (cadr nodes) new-optimistic 0) - (*unparse-space) - (print-guaranteed-node (cadr nodes)) - (print-body (cddr nodes))) - ((fits-as-column? (node-subnodes (cadr nodes)) - (+ new-optimistic 2) - 0) - (*unparse-space) - (*unparse-open) - (print-guaranteed-column (node-subnodes (cadr nodes)) - (1+ new-optimistic)) - (*unparse-close) - (print-body (cddr nodes))) - (else - (tab-to optimistic) - (print-node (cadr nodes) optimistic 0) - (print-body (cddr nodes)))))) - (else ;Ordinary LET. - (print-node (car nodes) optimistic 0) - (print-body (cdr nodes))))))) - -(define dispatch-list - `((COND . ,forced-indentation) - (IF . ,forced-indentation) - (OR . ,forced-indentation) - (AND . ,forced-indentation) - (LET . ,print-let-expression) - (FLUID-LET . ,print-let-expression) - (DEFINE . ,print-procedure) - (LAMBDA . ,print-procedure) - (NAMED-LAMBDA . ,print-procedure))) - -;;;; Alignment - -(declare (integrate fits-within?)) - -(define (fits-within? node column depth) - (declare (integrate node column depth)) - (> (- x-size depth) - (+ column (node-size node)))) - -;;; Fits if each node fits when stacked vertically at the given column. - -(define (fits-as-column? nodes column depth) - (define (loop nodes) - (if (null? (cdr nodes)) - (fits-within? (car nodes) column depth) - (and (> x-size - (+ column (node-size (car nodes)))) - (loop (cdr nodes))))) - (loop nodes)) - -;;; Fits if first two nodes fit on same line, and rest fit under the -;;; second node. Assumes at least two nodes are given. - -(define (two-on-first-line? nodes column depth) - (let ((column (1+ (+ column (node-size (car nodes)))))) - (and (> x-size column) - (fits-as-column? (cdr nodes) column depth)))) - -;;; Starts a new line with the specified indentation. - -(define (tab-to column) - (*unparse-newline) - (*unparse-string (make-string column #\Space))) - -;;;; Numerical Walk - -(define (numerical-walk object) - ((walk-dispatcher object) object)) - -(define (walk-general object) - (write-to-string object)) - -(define (walk-primitive primitive) - (if *pp-primitives-by-name* - (primitive-procedure-name primitive) - (write-to-string primitive))) - -(define (walk-pair pair) - (if (and (eq? (car pair) 'QUOTE) - (pair? (cdr pair)) - (null? (cddr pair))) - (make-prefix-node "'" (numerical-walk (cadr pair))) - (walk-unquoted-pair pair))) - -(define (walk-unquoted-pair pair) - (if (null? (cdr pair)) - (make-singleton-list-node (numerical-walk (car pair))) - (make-list-node - (numerical-walk (car pair)) - (if (pair? (cdr pair)) - (walk-unquoted-pair (cdr pair)) - (make-singleton-list-node - (make-prefix-node ". " (numerical-walk (cdr pair)))))))) - -(define (walk-vector vector) - (if (zero? (vector-length vector)) - "#()" - (make-prefix-node "#" (walk-unquoted-pair (vector->list vector))))) - -(define walk-dispatcher - (make-type-dispatcher - `((,symbol-type ,identity-procedure) - (,primitive-procedure-type ,walk-primitive) - (,(microcode-type-object 'PAIR) ,walk-pair) - (,(microcode-type-object 'VECTOR) ,walk-vector) - (,unparser-special-object-type ,walk-general)) - walk-general)) - -;;;; Node Model -;;; Carefully crafted to use the least amount of memory, while at the -;;; same time being as fast as possible. The only concession to -;;; space was in the implementation of atomic nodes, in which it was -;;; decided that the extra space needed to cache the size of a string -;;; or the print-name of a symbol wasn't worth the speed that would -;;; be gained by keeping it around. - -(declare (integrate symbol-length *unparse-symbol)) - -(define (symbol-length symbol) - (declare (integrate symbol)) - (string-length (symbol->string symbol))) - -(define (*unparse-symbol symbol) - (declare (integrate symbol)) - (*unparse-string (symbol->string symbol))) - -(define (make-prefix-node prefix subnode) - (cond ((or (list-node? subnode) - (symbol? subnode)) - (vector (+ (string-length prefix) (node-size subnode)) - prefix - subnode)) - ((prefix-node? subnode) - (make-prefix-node (string-append prefix (node-prefix subnode)) - (node-subnode subnode))) - (else (string-append prefix subnode)))) - -(define prefix-node? vector?) -(define prefix-node-size vector-first) -(define node-prefix vector-second) -(define node-subnode vector-third) - -(define (make-list-node car-node cdr-node) - (cons (1+ (+ (node-size car-node) (list-node-size cdr-node))) ;+1 space. - (cons car-node (node-subnodes cdr-node)))) - -(define (make-singleton-list-node car-node) - (cons (+ 2 (node-size car-node)) ;+1 each parenthesis. - (list car-node))) - -(declare (integrate list-node? list-node-size node-subnodes)) - -(define list-node? pair?) -(define list-node-size car) -(define node-subnodes cdr) - -(define (node-size node) - ((cond ((list-node? node) list-node-size) - ((symbol? node) symbol-length) - ((prefix-node? node) prefix-node-size) - (else string-length)) - node)) - -;;; end SCHEME-PRETTY-PRINTER package. -)) - -;;;; Exports - -(define pp - (let () - (define (prepare scode) - (let ((s-expression (unsyntax scode))) - (if (and (pair? s-expression) - (eq? (car s-expression) 'NAMED-LAMBDA)) - `(DEFINE ,@(cdr s-expression)) - s-expression))) - - (define (bad-arg argument) - (error "Bad optional argument" 'PP argument)) - - (lambda (scode . optionals) - (define (kernel as-code?) - (if (scode-constant? scode) - ((access pp scheme-pretty-printer) scode as-code?) - ((access pp scheme-pretty-printer) (prepare scode) true))) - - (cond ((null? optionals) - (kernel false)) - ((null? (cdr optionals)) - (cond ((eq? (car optionals) 'AS-CODE) - (kernel true)) - ((output-port? (car optionals)) - (with-output-to-port (car optionals) - (lambda () (kernel false)))) - (else - (bad-arg (car optionals))))) - ((null? (cddr optionals)) - (cond ((eq? (car optionals) 'AS-CODE) - (if (output-port? (cadr optionals)) - (with-output-to-port (cadr optionals) - (lambda () (kernel true))) - (bad-arg (cadr optionals)))) - ((output-port? (car optionals)) - (if (eq? (cadr optionals) 'AS-CODE) - (with-output-to-port (car optionals) - (lambda () (kernel true))) - (bad-arg (cadr optionals)))) - (else - (bad-arg (car optionals))))) - (else - (error "Too many optional arguments" 'PP optionals))) - *the-non-printing-object*))) - -(define (pa procedure) - (if (not (compound-procedure? procedure)) - (error "Must be a compound procedure" procedure)) - (pp (unsyntax-lambda-list (procedure-lambda procedure)))) \ No newline at end of file diff --git a/v7/src/runtime/qsort.scm b/v7/src/runtime/qsort.scm deleted file mode 100644 index 51483a837..000000000 --- a/v7/src/runtime/qsort.scm +++ /dev/null @@ -1,95 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/qsort.scm,v 13.41 1987/01/23 00:18:12 jinx Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Quick Sort - -(declare (usual-integrations)) - -(define (sort obj pred) - (if (vector? obj) - (sort! (vector-copy obj) pred) - (vector->list (sort! (list->vector obj) pred)))) - -(define sort! - (let () - - (define (exchange! vec i j) - ;; Speedup hack uses value of VECTOR-SET!. - (vector-set! vec j (vector-set! vec i (vector-ref vec j)))) - - (named-lambda (sort! obj pred) - (define (sort-internal! vec l r) - (cond - ((<= r l) - vec) - ((= r (1+ l)) - (if (pred (vector-ref vec r) - (vector-ref vec l)) - (exchange! vec l r) - vec)) - (else - (quick-merge vec l r)))) - - (define (quick-merge vec l r) - (let ((first (vector-ref vec l))) - (define (increase-i i) - (if (or (> i r) - (pred first (vector-ref vec i))) - i - (increase-i (1+ i)))) - (define (decrease-j j) - (if (or (<= j l) - (not (pred first (vector-ref vec j)))) - j - (decrease-j (-1+ j)))) - (define (loop i j) - (if (< i j) ;* used to be <= - (begin (exchange! vec i j) - (loop (increase-i (1+ i)) (decrease-j (-1+ j)))) - (begin (if (> j l) - (exchange! vec j l)) - (sort-internal! vec (1+ j) r) - (sort-internal! vec l (-1+ j))))) - (loop (increase-i (1+ l)) - (decrease-j r)))) - - (if (vector? obj) - (begin (sort-internal! obj 0 (-1+ (vector-length obj))) - obj) - (error "SORT! works on vectors only" obj))))) diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm deleted file mode 100644 index 8ceaa5e7a..000000000 --- a/v7/src/runtime/rep.scm +++ /dev/null @@ -1,330 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 13.42 1987/04/13 18:44:00 cph Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Read-Eval-Print Loop - -(declare (usual-integrations)) - -;;;; Command Loops - -(define make-command-loop) -(define push-command-loop) -(define push-command-hook) -(define with-rep-continuation) -(define continue-rep) -(define rep-continuation) -(define rep-state) -(define rep-level) -(define abort->nearest) -(define abort->previous) -(define abort->top-level) -(let () - -(define top-level-driver-hook) -(define previous-driver-hook) -(define nearest-driver-hook) -(define current-continuation) -(define current-state) -(define current-level 0) - -;; PUSH-COMMAND-HOOK is provided so that the Butterfly, in particular, -;; can add its own little code just before creating a REP loop -(set! push-command-hook - (lambda (startup driver state continuation) - (continuation startup driver state (lambda () 'ignore)))) - -(set! make-command-loop - (named-lambda (make-command-loop message driver) - (define (driver-loop message) - (driver-loop - (with-rep-continuation - (lambda (quit) - (set! top-level-driver-hook quit) - (set! nearest-driver-hook quit) - (driver message))))) - (set-interrupt-enables! interrupt-mask-gc-ok) - (fluid-let ((top-level-driver-hook) - (nearest-driver-hook)) - (driver-loop message)))) - -(set! push-command-loop -(named-lambda (push-command-loop startup-hook driver initial-state) - (define (restart entry-hook each-time) - (let ((reentry-hook - (call-with-current-continuation - (lambda (again) - (set! nearest-driver-hook again) - (set-interrupt-enables! interrupt-mask-all) - (each-time) - (entry-hook) - (loop))))) - (set-interrupt-enables! interrupt-mask-gc-ok) - (restart reentry-hook each-time))) - - (define (loop) - (set! current-state (driver current-state)) - (loop)) - - (fluid-let ((current-level (1+ current-level)) - (previous-driver-hook nearest-driver-hook) - (nearest-driver-hook) - (current-state)) - (push-command-hook - startup-hook driver initial-state - (lambda (startup-hook driver initial-state each-time) - (set! current-state initial-state) - (restart startup-hook each-time)))))) - -(set! with-rep-continuation -(named-lambda (with-rep-continuation receiver) - (call-with-current-continuation - (lambda (raw-continuation) - (let ((continuation (raw-continuation->continuation raw-continuation))) - (fluid-let ((current-continuation continuation)) - (receiver continuation))))))) - -(set! continue-rep -(named-lambda (continue-rep value) - (current-continuation - (if (eq? current-continuation top-level-driver-hook) - (lambda () - (write-line value)) - value)))) - -(set! abort->nearest -(named-lambda (abort->nearest message) - (nearest-driver-hook message))) - -(set! abort->previous -(named-lambda (abort->previous message) - ((if (null? previous-driver-hook) - nearest-driver-hook - previous-driver-hook) - message))) - -(set! abort->top-level -(named-lambda (abort->top-level message) - (top-level-driver-hook message))) - -(set! rep-continuation -(named-lambda (rep-continuation) - current-continuation)) - -(set! rep-state -(named-lambda (rep-state) - current-state)) - -(set! rep-level -(named-lambda (rep-level) - current-level)) - -) ; LET - -;;;; Read-Eval-Print Loops - -(define *rep-base-environment*) -(define *rep-current-environment*) -(define *rep-base-syntax-table*) -(define *rep-current-syntax-table*) -(define *rep-base-prompt*) -(define *rep-current-prompt*) -(define *rep-base-input-port*) -(define *rep-current-input-port*) -(define *rep-base-output-port*) -(define *rep-current-output-port*) -(define *rep-keyboard-map*) -(define *rep-error-hook*) - -(define (rep-environment) - *rep-current-environment*) - -(define (rep-base-environment) - *rep-base-environment*) - -(define (set-rep-environment! environment) - (set! *rep-current-environment* environment) - (environment-warning-hook *rep-current-environment*)) - -(define (set-rep-base-environment! environment) - (set! *rep-base-environment* environment) - (set! *rep-current-environment* environment) - (environment-warning-hook *rep-current-environment*)) - -(define (rep-syntax-table) - *rep-current-syntax-table*) - -(define (rep-base-syntax-table) - *rep-base-syntax-table*) - -(define (set-rep-syntax-table! syntax-table) - (set! *rep-current-syntax-table* syntax-table)) - -(define (set-rep-base-syntax-table! syntax-table) - (set! *rep-base-syntax-table* syntax-table) - (set! *rep-current-syntax-table* syntax-table)) - -(define (rep-prompt) - *rep-current-prompt*) - -(define (set-rep-prompt! prompt) - (set! *rep-current-prompt* prompt)) - -(define (rep-base-prompt) - *rep-base-prompt*) - -(define (set-rep-base-prompt! prompt) - (set! *rep-base-prompt* prompt) - (set! *rep-current-prompt* prompt)) - -(define (rep-input-port) - *rep-current-input-port*) - -(define (rep-output-port) - *rep-current-output-port*) - -(define environment-warning-hook - identity-procedure) - -(define rep-value-hook - write-line) - -(define make-rep) -(define push-rep) -(define reader-history) -(define printer-history) -(let () - -(set! make-rep -(named-lambda (make-rep environment syntax-table prompt input-port output-port - message) - (fluid-let ((*rep-base-environment* environment) - (*rep-base-syntax-table* syntax-table) - (*rep-base-prompt* prompt) - (*rep-base-input-port* input-port) - (*rep-base-output-port* output-port) - (*rep-keyboard-map* (keyboard-interrupt-dispatch-table)) - (*rep-error-hook* (access *error-hook* error-system))) - (make-command-loop message rep-top-driver)))) - -(define (rep-top-driver message) - (push-rep *rep-base-environment* message *rep-base-prompt*)) - -(set! push-rep -(named-lambda (push-rep environment message prompt) - (fluid-let ((*rep-current-environment* environment) - (*rep-current-syntax-table* *rep-base-syntax-table*) - (*rep-current-prompt* prompt) - (*rep-current-input-port* *rep-base-input-port*) - (*rep-current-output-port* *rep-base-output-port*) - (*current-input-port* *rep-base-input-port*) - (*current-output-port* *rep-base-output-port*) - ((access *error-hook* error-system) *rep-error-hook*)) - (with-keyboard-interrupt-dispatch-table *rep-keyboard-map* - (lambda () - (environment-warning-hook *rep-current-environment*) - (push-command-loop message - rep-driver - (make-rep-state (make-history 5) - (make-history 10)))))))) - -(define (rep-driver state) - (*rep-current-prompt*) - (let ((object - (let ((scode - (let ((s-expression (read))) - (record-in-history! (rep-state-reader-history state) - s-expression) - (syntax s-expression *rep-current-syntax-table*)))) - (with-new-history - (lambda () - (scode-eval scode *rep-current-environment*)))))) - (record-in-history! (rep-state-printer-history state) object) - (rep-value-hook object)) - state) - -;;; History Manipulation - -(define (make-history size) - (let ((list (make-list size '()))) - (append! list list) - (vector history-tag size list))) - -(define history-tag - '(REP-HISTORY)) - -(define (record-in-history! history object) - (if (not (null? (vector-ref history 2))) - (begin (set-car! (vector-ref history 2) object) - (vector-set! history 2 (cdr (vector-ref history 2)))))) - -(define (read-history history n) - (if (not (and (integer? n) - (not (negative? n)) - (< n (vector-ref history 1)))) - (error "Bad argument: READ-HISTORY" n)) - (list-ref (vector-ref history 2) - (- (-1+ (vector-ref history 1)) n))) - -(define ((history-reader selector name) n) - (let ((state (rep-state))) - (if (rep-state? state) - (read-history (selector state) n) - (error "Not in REP loop" name)))) - -(define rep-state-tag - "REP State") - -(define (make-rep-state reader-history printer-history) - (vector rep-state-tag reader-history printer-history)) - -(define (rep-state? object) - (and (vector? object) - (not (zero? (vector-length object))) - (eq? (vector-ref object 0) rep-state-tag))) - -(define rep-state-reader-history vector-second) -(define rep-state-printer-history vector-third) - -(set! reader-history - (history-reader rep-state-reader-history 'READER-HISTORY)) - -(set! printer-history - (history-reader rep-state-printer-history 'PRINTER-HISTORY)) - -) \ No newline at end of file diff --git a/v7/src/runtime/scan.scm b/v7/src/runtime/scan.scm deleted file mode 100644 index 9847bea7c..000000000 --- a/v7/src/runtime/scan.scm +++ /dev/null @@ -1,213 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scan.scm,v 13.41 1987/01/23 00:18:56 jinx Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Definition Scanner - -(declare (usual-integrations)) - -;;; Scanning of internal definitions is necessary to reduce the number -;;; of "real auxiliary" variables in the system. These bindings are -;;; maintained in alists by the microcode, and cannot be compiled as -;;; ordinary formals can. - -;;; The following support is provided. SCAN-DEFINES will find the -;;; top-level definitions in a sequence, and returns an ordered list -;;; of those names, and a new sequence in which those definitions are -;;; replaced by assignments. UNSCAN-DEFINES will invert that. - -;;; The Open Block abstraction can be used to store scanned -;;; definitions in code, which is extremely useful for code analysis -;;; and transformation. The supplied procedures, MAKE-OPEN-BLOCK and -;;; OPEN-BLOCK-COMPONENTS, will connect directly to SCAN-DEFINES and -;;; UNSCAN-DEFINES, respectively. - -(define scan-defines) -(define unscan-defines) -(define make-open-block) -(define open-block?) -(define open-block-components) - -(let ((open-block-tag (make-named-tag "OPEN-BLOCK")) - (sequence-2-type (microcode-type 'SEQUENCE-2)) - (sequence-3-type (microcode-type 'SEQUENCE-3)) - (null-sequence '(NULL-SEQUENCE))) - -;;;; Scanning - -;;; This depends on the fact that the lambda abstraction will preserve -;;; the order of the auxiliaries. That is, giving MAKE-LAMBDA a list -;;; of auxiliaries will result in LAMBDA-COMPONENTS returning an -;;; EQUAL? list. - -(set! scan-defines -(named-lambda (scan-defines expression receiver) - ((scan-loop expression receiver) '() '() null-sequence))) - -(define (scan-loop expression receiver) - (cond ((primitive-type? sequence-2-type expression) - (scan-loop (&pair-cdr expression) - (scan-loop (&pair-car expression) - receiver))) - ((primitive-type? sequence-3-type expression) - (let ((first (&triple-first expression))) - (if (and (vector? first) - (not (zero? (vector-length first))) - (eq? (vector-ref first 0) open-block-tag)) - (lambda (names declarations body) - (receiver (append (vector-ref first 1) names) - (append (vector-ref first 2) declarations) - (cons-sequence (&triple-third expression) - body))) - (scan-loop (&triple-third expression) - (scan-loop (&triple-second expression) - (scan-loop first - receiver)))))) - ((definition? expression) - (definition-components expression - (lambda (name value) - (lambda (names declarations body) - (receiver (cons name names) - declarations - (cons-sequence (make-assignment name value) - body)))))) - ((block-declaration? expression) - (lambda (names declarations body) - (receiver names - (append (block-declaration-text expression) - declarations) - body))) - (else - (lambda (names declarations body) - (receiver names - declarations - (cons-sequence expression body)))))) - -(define (cons-sequence action sequence) - (cond ((primitive-type? sequence-2-type sequence) - (&typed-triple-cons sequence-3-type - action - (&pair-car sequence) - (&pair-cdr sequence))) - ((eq? sequence null-sequence) - action) - (else - (&typed-pair-cons sequence-2-type action sequence)))) - -(set! unscan-defines -(named-lambda (unscan-defines names declarations body) - (unscan-loop names body - (lambda (names* body*) - (if (not (null? names*)) - (error "Extraneous auxiliaries -- get a wizard" - 'UNSCAN-DEFINES - names*)) - (if (null? declarations) - body* - (&typed-pair-cons sequence-2-type - (make-block-declaration declarations) - body*)))))) - -(define (unscan-loop names body receiver) - (cond ((null? names) (receiver '() body)) - ((assignment? body) - (assignment-components body - (lambda (name value) - (if (eq? name (car names)) - (receiver (cdr names) - (make-definition name value)) - (receiver names - body))))) - ((primitive-type? sequence-2-type body) - (unscan-loop names (&pair-car body) - (lambda (names* body*) - (unscan-loop names* (&pair-cdr body) - (lambda (names** body**) - (receiver names** - (&typed-pair-cons sequence-2-type - body* - body**))))))) - ((primitive-type? sequence-3-type body) - (unscan-loop names (&triple-first body) - (lambda (names* body*) - (unscan-loop names* (&triple-second body) - (lambda (names** body**) - (unscan-loop names** (&triple-third body) - (lambda (names*** body***) - (receiver names*** - (&typed-triple-cons sequence-3-type - body* - body** - body***))))))))) - (else - (receiver names - body)))) - -;;;; Open Block - -(set! make-open-block -(named-lambda (make-open-block names declarations body) - (if (and (null? names) - (null? declarations)) - body - (&typed-triple-cons - sequence-3-type - (vector open-block-tag names declarations) - (if (null? names) - '() - (make-sequence - (map (lambda (name) - (make-definition name (make-unassigned-object))) - names))) - body)))) - - -(set! open-block? -(named-lambda (open-block? object) - (and (primitive-type? sequence-3-type object) - (vector? (&triple-first object)) - (eq? (vector-ref (&triple-first object) 0) open-block-tag)))) - -(set! open-block-components -(named-lambda (open-block-components open-block receiver) - (receiver (vector-ref (&triple-first open-block) 1) - (vector-ref (&triple-first open-block) 2) - (&triple-third open-block)))) - -;;; end LET -) diff --git a/v7/src/runtime/scode.scm b/v7/src/runtime/scode.scm deleted file mode 100644 index 37624c0b6..000000000 --- a/v7/src/runtime/scode.scm +++ /dev/null @@ -1,351 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scode.scm,v 13.42 1987/03/17 18:52:47 cph Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; SCODE Grab Bag - -(declare (usual-integrations)) - -;;;; Constants - -(define scode-constant? - (let ((type-vector (make-vector number-of-microcode-types false))) - (for-each (lambda (name) - (vector-set! type-vector (microcode-type name) true)) - '(NULL TRUE UNASSIGNED - FIXNUM BIGNUM FLONUM - CHARACTER STRING UNINTERNED-SYMBOL INTERNED-SYMBOL - NON-MARKED-VECTOR VECTOR-1B VECTOR-16B - PAIR TRIPLE VECTOR QUOTATION PRIMITIVE)) - (named-lambda (scode-constant? object) - (vector-ref type-vector (primitive-type object))))) - -(define make-null) -(define make-false) -(define make-true) - -(let () - (define (make-constant-maker name) - (let ((type (microcode-type name))) - (lambda () - (primitive-set-type type 0)))) - (set! make-null (make-constant-maker 'NULL)) - (set! make-false (make-constant-maker 'FALSE)) - (set! make-true (make-constant-maker 'TRUE))) - -;;;; QUOTATION - -(define quotation?) -(define make-quotation) - -(let ((type (microcode-type 'QUOTATION))) - (set! quotation? - (named-lambda (quotation? object) - (primitive-type? type object))) - (set! make-quotation - (named-lambda (make-quotation expression) - (&typed-singleton-cons type expression)))) - -(define quotation-expression &singleton-element) - -;;;; SYMBOL - -(define symbol?) -(define string->uninterned-symbol) -(let () - -(define utype - (microcode-type 'UNINTERNED-SYMBOL)) - -(define itype - (microcode-type 'INTERNED-SYMBOL)) - -(set! symbol? -(named-lambda (symbol? object) - (or (primitive-type? itype object) - (primitive-type? utype object)))) - -(set! string->uninterned-symbol -(named-lambda (string->uninterned-symbol string) - (&typed-pair-cons utype - string - (make-unbound-object)))) - -) - -(define string->symbol - (make-primitive-procedure 'STRING->SYMBOL)) - -(define (symbol->string symbol) - (make-object-safe (&pair-car symbol))) - -(define make-symbol string->uninterned-symbol) -(define make-interned-symbol string->symbol) -(define symbol-print-name symbol->string) - -(define (symbol-global-value symbol) - (make-object-safe (&pair-cdr symbol))) - -(define (set-symbol-global-value! symbol value) - (&pair-set-cdr! symbol - ((if (object-dangerous? (&pair-cdr symbol)) - make-object-dangerous - make-object-safe) - value))) - -(define (make-named-tag name) - (string->symbol (string-append "#[" name "]"))) - -;;;; VARIABLE - -(define variable?) -(define make-variable) - -(let ((type (microcode-type 'VARIABLE))) - (set! variable? - (named-lambda (variable? object) - (primitive-type? type object))) - (set! make-variable - (named-lambda (make-variable name) - (system-hunk3-cons type name (make-true) (make-null))))) - -(define variable-name system-hunk3-cxr0) - -(define (variable-components variable receiver) - (receiver (variable-name variable))) - -;;;; DEFINITION - -(define definition?) -(define make-definition) - -(let ((type (microcode-type 'DEFINITION))) - (set! definition? - (named-lambda (definition? object) - (primitive-type? type object))) - (set! make-definition - (named-lambda (make-definition name value) - (&typed-pair-cons type name value)))) - -(define (definition-components definition receiver) - (receiver (definition-name definition) - (definition-value definition))) - -(define definition-name system-pair-car) -(define set-definition-name! system-pair-set-car!) -(define definition-value &pair-cdr) -(define set-definition-value! &pair-set-cdr!) - -;;;; ASSIGNMENT - -(define assignment?) -(define make-assignment-from-variable) - -(let ((type (microcode-type 'ASSIGNMENT))) - (set! assignment? - (named-lambda (assignment? object) - (primitive-type? type object))) - (set! make-assignment-from-variable - (named-lambda (make-assignment-from-variable variable value) - (&typed-pair-cons type variable value)))) - -(define (assignment-components-with-variable assignment receiver) - (receiver (assignment-variable assignment) - (assignment-value assignment))) - -(define assignment-variable system-pair-car) -(define set-assignment-variable! system-pair-set-car!) -(define assignment-value &pair-cdr) -(define set-assignment-value! &pair-set-cdr!) - -(define (make-assignment name value) - (make-assignment-from-variable (make-variable name) value)) - -(define (assignment-components assignment receiver) - (assignment-components-with-variable assignment - (lambda (variable value) - (receiver (variable-name variable) value)))) - -(define (assignment-name assignment) - (variable-name (assignment-variable assignment))) - -;;;; COMMENT - -(define comment?) -(define make-comment) - -(let ((type (microcode-type 'COMMENT))) - (set! comment? - (named-lambda (comment? object) - (primitive-type? type object))) - (set! make-comment - (named-lambda (make-comment text expression) - (&typed-pair-cons type expression text)))) - -(define (comment-components comment receiver) - (receiver (comment-text comment) - (comment-expression comment))) - -(define comment-text &pair-cdr) -(define set-comment-text! &pair-set-cdr!) -(define comment-expression &pair-car) -(define set-comment-expression! &pair-set-car!) - -;;;; DECLARATION - -(define declaration?) -(define make-declaration) - -(let ((tag (make-named-tag "DECLARATION"))) - (set! declaration? - (named-lambda (declaration? object) - (and (comment? object) - (let ((text (comment-text object))) - (and (pair? text) - (eq? (car text) tag)))))) - (set! make-declaration - (named-lambda (make-declaration text expression) - (make-comment (cons tag text) expression)))) - -(define (declaration-components declaration receiver) - (comment-components declaration - (lambda (text expression) - (receiver (cdr text) expression)))) - -(define (declaration-text tagged-comment) - (cdr (comment-text tagged-comment))) - -(define (set-declaration-text! tagged-comment new-text) - (set-cdr! (comment-text tagged-comment) new-text)) - -(define declaration-expression - comment-expression) - -(define set-declaration-expression! - set-comment-expression!) - -(define make-block-declaration) -(define block-declaration?) -(let () - -(define tag - (make-named-tag "Block Declaration")) - -(set! make-block-declaration -(named-lambda (make-block-declaration text) - (cons tag text))) - -(set! block-declaration? -(named-lambda (block-declaration? object) - (and (pair? object) (eq? (car object) tag)))) - -) - -(define block-declaration-text - cdr) - -;;;; THE-ENVIRONMENT - -(define the-environment?) -(define make-the-environment) - -(let ((type (microcode-type 'THE-ENVIRONMENT))) - (set! the-environment? - (named-lambda (the-environment? object) - (primitive-type? type object))) - (set! make-the-environment - (named-lambda (make-the-environment) - (primitive-set-type type 0)))) - -;;;; ACCESS - -(define access?) -(define make-access) - -(let ((type (microcode-type 'ACCESS))) - (set! access? - (named-lambda (access? object) - (primitive-type? type object))) - (set! make-access - (named-lambda (make-access environment name) - (&typed-pair-cons type environment name)))) - -(define (access-components access receiver) - (receiver (access-environment access) - (access-name access))) - -(define access-environment &pair-car) -(define access-name system-pair-cdr) - -;;;; IN-PACKAGE - -(define in-package?) -(define make-in-package) - -(let ((type (microcode-type 'IN-PACKAGE))) - (set! in-package? - (named-lambda (in-package? object) - (primitive-type? type object))) - (set! make-in-package - (named-lambda (make-in-package environment expression) - (&typed-pair-cons type environment expression)))) - -(define (in-package-components in-package receiver) - (receiver (in-package-environment in-package) - (in-package-expression in-package))) - -(define in-package-environment &pair-car) -(define in-package-expression &pair-cdr) - -;;;; DELAY - -(define delay?) -(define make-delay) - -(let ((type (microcode-type 'DELAY))) - (set! delay? - (named-lambda (delay? object) - (primitive-type? type object))) - (set! make-delay - (named-lambda (make-delay expression) - (&typed-singleton-cons type expression)))) - -(define delay-expression &singleton-element) - -(define (delay-components delay receiver) - (receiver (delay-expression delay))) \ No newline at end of file diff --git a/v7/src/runtime/scomb.scm b/v7/src/runtime/scomb.scm deleted file mode 100644 index 55ab9a2a0..000000000 --- a/v7/src/runtime/scomb.scm +++ /dev/null @@ -1,368 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scomb.scm,v 13.42 1987/03/17 18:52:59 cph Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; SCODE Combinator Abstractions - -(declare (usual-integrations)) - -;;;; SEQUENCE - -(define sequence?) -(define make-sequence) -(define sequence-actions) -(let () - -(define type-2 - (microcode-type 'SEQUENCE-2)) - -(define type-3 - (microcode-type 'SEQUENCE-3)) - -(set! sequence? -(named-lambda (sequence? object) - (or (primitive-type? type-2 object) - (primitive-type? type-3 object)))) - -(set! make-sequence -(lambda (actions) - (if (null? actions) - (error "MAKE-SEQUENCE: No actions") - (actions->sequence actions)))) - -(define (actions->sequence actions) - (cond ((null? (cdr actions)) - (car actions)) - ((null? (cddr actions)) - (&typed-pair-cons type-2 - (car actions) - (cadr actions))) - (else - (&typed-triple-cons type-3 - (car actions) - (cadr actions) - (actions->sequence (cddr actions)))))) - -(set! sequence-actions -(named-lambda (sequence-actions sequence) - (cond ((primitive-type? type-2 sequence) - (append! (sequence-actions (&pair-car sequence)) - (sequence-actions (&pair-cdr sequence)))) - ((primitive-type? type-3 sequence) - (append! (sequence-actions (&triple-first sequence)) - (sequence-actions (&triple-second sequence)) - (sequence-actions (&triple-third sequence)))) - (else - (list sequence))))) - -) - -(define (sequence-components sequence receiver) - (receiver (sequence-actions sequence))) - -;;;; CONDITIONAL - -(define conditional?) -(define make-conditional) -(let () - -(define type - (microcode-type 'CONDITIONAL)) - -(set! conditional? -(named-lambda (conditional? object) - (primitive-type? type object))) - -(set! make-conditional -(named-lambda (make-conditional predicate consequent alternative) - (if (combination? predicate) - (combination-components predicate - (lambda (operator operands) - (if (eq? operator not) - (make-conditional (first operands) - alternative - consequent) - (&typed-triple-cons type - predicate - consequent - alternative)))) - (&typed-triple-cons type predicate consequent alternative)))) - -) - -(define (conditional-components conditional receiver) - (receiver (conditional-predicate conditional) - (conditional-consequent conditional) - (conditional-alternative conditional))) - -(define conditional-predicate &triple-first) -(define conditional-consequent &triple-second) -(define conditional-alternative &triple-third) - -;;;; DISJUNCTION - -(define disjunction?) -(define make-disjunction) -(let () - -(define type - (microcode-type 'DISJUNCTION)) - -(set! disjunction? -(named-lambda (disjunction? object) - (primitive-type? type object))) - -(set! make-disjunction -(named-lambda (make-disjunction predicate alternative) - (if (combination? predicate) - (combination-components predicate - (lambda (operator operands) - (if (eq? operator not) - (make-conditional (first operands) alternative true) - (&typed-pair-cons type predicate alternative)))) - (&typed-pair-cons type predicate alternative)))) - -) - -(define (disjunction-components disjunction receiver) - (receiver (disjunction-predicate disjunction) - (disjunction-alternative disjunction))) - -(define disjunction-predicate &pair-car) -(define disjunction-alternative &pair-cdr) - -;;;; COMBINATION - -(define combination?) -(define make-combination) -(define combination-size) -(define combination-components) -(define combination-operator) -(define combination-operands) -(let () - -(define type-1 (microcode-type 'COMBINATION-1)) -(define type-2 (microcode-type 'COMBINATION-2)) -(define type-N (microcode-type 'COMBINATION)) -(define p-type (microcode-type 'PRIMITIVE)) -(define p-type-0 (microcode-type 'PRIMITIVE-COMBINATION-0)) -(define p-type-1 (microcode-type 'PRIMITIVE-COMBINATION-1)) -(define p-type-2 (microcode-type 'PRIMITIVE-COMBINATION-2)) -(define p-type-3 (microcode-type 'PRIMITIVE-COMBINATION-3)) - -(define (primitive-procedure? object) - (primitive-type? p-type object)) - -(set! combination? -(named-lambda (combination? object) - (or (primitive-type? type-1 object) - (primitive-type? type-2 object) - (primitive-type? type-N object) - (primitive-type? p-type-0 object) - (primitive-type? p-type-1 object) - (primitive-type? p-type-2 object) - (primitive-type? p-type-3 object)))) - -(set! make-combination -(lambda (operator operands) - (cond ((and (memq operator constant-folding-operators) - (all-constants? operands)) - (apply operator operands)) - ((null? operands) - (if (and (primitive-procedure? operator) - (= (primitive-procedure-arity operator) 0)) - (primitive-set-type p-type-0 operator) - (&typed-vector-cons type-N (cons operator '())))) - ((null? (cdr operands)) - (&typed-pair-cons - (if (and (primitive-procedure? operator) - (= (primitive-procedure-arity operator) 1)) - p-type-1 - type-1) - operator - (car operands))) - ((null? (cddr operands)) - (&typed-triple-cons - (if (and (primitive-procedure? operator) - (= (primitive-procedure-arity operator) 2)) - p-type-2 - type-2) - operator - (car operands) - (cadr operands))) - (else - (&typed-vector-cons - (if (and (null? (cdddr operands)) - (primitive-procedure? operator) - (= (primitive-procedure-arity operator) 3)) - p-type-3 - type-N) - (cons operator operands)))))) - -(define constant-folding-operators - (map make-primitive-procedure - '(PRIMITIVE-TYPE - CAR CDR VECTOR-LENGTH VECTOR-REF - &+ &- &* &/ INTEGER-DIVIDE 1+ -1+ - TRUNCATE ROUND FLOOR CEILING - SQRT EXP LOG SIN COS &ATAN))) - -(define (all-constants? expressions) - (or (null? expressions) - (and (scode-constant? (car expressions)) - (all-constants? (cdr expressions))))) - -(set! combination-size -(lambda (combination) - (cond ((primitive-type? p-type-0 combination) - 1) - ((or (primitive-type? type-1 combination) - (primitive-type? p-type-1 combination)) - 2) - ((or (primitive-type? type-2 combination) - (primitive-type? p-type-2 combination)) - 3) - ((primitive-type? p-type-3 combination) - 4) - ((primitive-type? type-N combination) - (&vector-size combination)) - (else - (error "Not a combination -- COMBINATION-SIZE" combination))))) - -(set! combination-operator -(lambda (combination) - (cond ((primitive-type? p-type-0 combination) - (primitive-set-type p-type combination)) - ((or (primitive-type? type-1 combination) - (primitive-type? p-type-1 combination)) - (&pair-car combination)) - ((or (primitive-type? type-2 combination) - (primitive-type? p-type-2 combination)) - (&triple-first combination)) - ((or (primitive-type? p-type-3 combination) - (primitive-type? type-N combination)) - (&vector-ref combination 0)) - (else - (error "Not a combination -- COMBINATION-OPERATOR" - combination))))) - -(set! combination-operands -(lambda (combination) - (cond ((primitive-type? p-type-0 combination) - '()) - ((or (primitive-type? type-1 combination) - (primitive-type? p-type-1 combination)) - (list (&pair-cdr combination))) - ((or (primitive-type? type-2 combination) - (primitive-type? p-type-2 combination)) - (list (&triple-second combination) - (&triple-third combination))) - ((or (primitive-type? p-type-3 combination) - (primitive-type? type-N combination)) - (&subvector-to-list combination 1 (&vector-size combination))) - (else - (error "Not a combination -- COMBINATION-OPERANDS" - combination))))) - -(set! combination-components -(lambda (combination receiver) - (cond ((primitive-type? p-type-0 combination) - (receiver (primitive-set-type p-type combination) - '())) - ((or (primitive-type? type-1 combination) - (primitive-type? p-type-1 combination)) - (receiver (&pair-car combination) - (list (&pair-cdr combination)))) - ((or (primitive-type? type-2 combination) - (primitive-type? p-type-2 combination)) - (receiver (&triple-first combination) - (list (&triple-second combination) - (&triple-third combination)))) - ((or (primitive-type? p-type-3 combination) - (primitive-type? type-N combination)) - (receiver (&vector-ref combination 0) - (&subvector-to-list combination 1 - (&vector-size combination)))) - (else - (error "Not a combination -- COMBINATION-COMPONENTS" - combination))))) - -) - -;;;; UNASSIGNED? - -(define unassigned??) -(define make-unassigned?) -(define unbound??) -(define make-unbound?) -(let () - -(define ((envop-characteristic envop) object) - (and (combination? object) - (combination-components object - (lambda (operator operands) - (and (eq? operator envop) - (the-environment? (first operands)) - (symbol? (second operands))))))) - -(define ((envop-maker envop) name) - (make-combination envop - (list (make-the-environment) name))) - -(set! unassigned?? - (envop-characteristic lexical-unassigned?)) - -(set! make-unassigned? - (envop-maker lexical-unassigned?)) - -(set! unbound?? - (envop-characteristic lexical-unbound?)) - -(set! make-unbound? - (envop-maker lexical-unbound?)) - -) - -(define (unassigned?-name unassigned?) - (second (combination-operands unassigned?))) - -(define (unassigned?-components unassigned? receiver) - (receiver (unassigned?-name unassigned?))) - -(define unbound?-name unassigned?-name) -(define unbound?-components unassigned?-components) \ No newline at end of file diff --git a/v7/src/runtime/sdata.scm b/v7/src/runtime/sdata.scm deleted file mode 100644 index b0e1d36af..000000000 --- a/v7/src/runtime/sdata.scm +++ /dev/null @@ -1,233 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sdata.scm,v 13.42 1987/04/03 00:52:12 jinx Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Abstract Data Field - -(declare (usual-integrations)) - -(define unbound-object?) -(define make-unbound-object) - -(define unassigned-object?) -(define make-unassigned-object) - -(define &typed-singleton-cons) -(define &singleton-element) -(define &singleton-set-element!) - -(define &typed-pair-cons) -(define &pair-car) -(define &pair-set-car!) -(define &pair-cdr) -(define &pair-set-cdr!) - -(define &typed-triple-cons) -(define &triple-first) -(define &triple-set-first!) -(define &triple-second) -(define &triple-set-second!) -(define &triple-third) -(define &triple-set-third!) - -(define &typed-vector-cons) -(define &list-to-vector) -(define &vector-size) -(define &vector-ref) -(define &vector-to-list) -(define &subvector-to-list) - -(let ((&unbound-object '(&UNBOUND-OBJECT)) - (&unbound-datum 2) - (&unassigned-object '(&UNASSIGNED-OBJECT)) - (&unassigned-datum 0) - (&unassigned-type (microcode-type 'UNASSIGNED)) - (&make-object (make-primitive-procedure '&MAKE-OBJECT)) - (hunk3-cons (make-primitive-procedure 'HUNK3-CONS))) - - (define (map-unassigned object) - (cond ((eq? object &unbound-object) - (&make-object &unassigned-type &unbound-datum)) - ((eq? object &unassigned-object) - (&make-object &unassigned-type &unassigned-datum)) - (else object))) - - ;; This is no longer really right, given the other traps. - (define (map-from-unassigned datum) - (if (eq? datum &unassigned-datum) ;**** cheat for speed. - &unassigned-object - &unbound-object)) - - (define (map-unassigned-list list) - (if (null? list) - '() - (cons (map-unassigned (car list)) - (map-unassigned-list (cdr list))))) - -(set! make-unbound-object - (lambda () - &unbound-object)) - -(set! unbound-object? - (lambda (object) - (eq? object &unbound-object))) - -(set! make-unassigned-object - (lambda () - &unassigned-object)) - -(set! unassigned-object? - (let ((microcode-unassigned-object - (vector-ref (get-fixed-objects-vector) - (fixed-objects-vector-slot 'NON-OBJECT)))) - (lambda (object) - (or (eq? object &unassigned-object) - (eq? object microcode-unassigned-object))))) - -(set! &typed-singleton-cons - (lambda (type element) - (system-pair-cons type - (map-unassigned element) - #!NULL))) - -(set! &singleton-element - (lambda (singleton) - (if (primitive-type? &unassigned-type (system-pair-car singleton)) - (map-from-unassigned (primitive-datum (system-pair-car singleton))) - (system-pair-car singleton)))) - -(set! &singleton-set-element! - (lambda (singleton new-element) - (system-pair-set-car! singleton (map-unassigned new-element)))) - -(set! &typed-pair-cons - (lambda (type car cdr) - (system-pair-cons type - (map-unassigned car) - (map-unassigned cdr)))) - -(set! &pair-car - (lambda (pair) - (if (primitive-type? &unassigned-type (system-pair-car pair)) - (map-from-unassigned (primitive-datum (system-pair-car pair))) - (system-pair-car pair)))) - -(set! &pair-set-car! - (lambda (pair new-car) - (system-pair-set-car! pair (map-unassigned new-car)))) - -(set! &pair-cdr - (lambda (pair) - (if (primitive-type? &unassigned-type (system-pair-cdr pair)) - (map-from-unassigned (primitive-datum (system-pair-cdr pair))) - (system-pair-cdr pair)))) - -(set! &pair-set-cdr! - (lambda (pair new-cdr) - (system-pair-set-cdr! pair (map-unassigned new-cdr)))) - -(set! &typed-triple-cons - (lambda (type first second third) - (primitive-set-type type - (hunk3-cons (map-unassigned first) - (map-unassigned second) - (map-unassigned third))))) - -(set! &triple-first - (lambda (triple) - (if (primitive-type? &unassigned-type (system-hunk3-cxr0 triple)) - (map-from-unassigned (primitive-datum (system-hunk3-cxr0 triple))) - (system-hunk3-cxr0 triple)))) - -(set! &triple-set-first! - (lambda (triple new-first) - (system-hunk3-set-cxr0! triple (map-unassigned new-first)))) - -(set! &triple-second - (lambda (triple) - (if (primitive-type? &unassigned-type (system-hunk3-cxr1 triple)) - (map-from-unassigned (primitive-datum (system-hunk3-cxr1 triple))) - (system-hunk3-cxr1 triple)))) - -(set! &triple-set-second! - (lambda (triple new-second) - (system-hunk3-set-cxr0! triple (map-unassigned new-second)))) - -(set! &triple-third - (lambda (triple) - (if (primitive-type? &unassigned-type (system-hunk3-cxr2 triple)) - (map-from-unassigned (primitive-datum (system-hunk3-cxr2 triple))) - (system-hunk3-cxr2 triple)))) - -(set! &triple-set-third! - (lambda (triple new-third) - (system-hunk3-set-cxr0! triple (map-unassigned new-third)))) - -(set! &typed-vector-cons - (lambda (type elements) - (system-list-to-vector type (map-unassigned-list elements)))) - -(set! &list-to-vector - list->vector) - -(set! &vector-size - system-vector-size) - -(set! &vector-ref - (lambda (vector index) - (if (primitive-type? &unassigned-type (system-vector-ref vector index)) - (map-from-unassigned - (primitive-datum (system-vector-ref vector index))) - (system-vector-ref vector index)))) - -(set! &vector-to-list - (lambda (vector) - (&subvector-to-list vector 0 (system-vector-size vector)))) - -(set! &subvector-to-list - (lambda (vector start stop) - (let loop ((sublist (system-subvector-to-list vector start stop))) - (if (null? sublist) - '() - (cons (if (primitive-type? &unassigned-type (car sublist)) - (map-from-unassigned (primitive-datum (car sublist))) - (car sublist)) - (loop (cdr sublist))))))) - -) -) \ No newline at end of file diff --git a/v7/src/runtime/sfile.scm b/v7/src/runtime/sfile.scm deleted file mode 100644 index 638966419..000000000 --- a/v7/src/runtime/sfile.scm +++ /dev/null @@ -1,68 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sfile.scm,v 13.41 1987/01/23 00:19:51 jinx Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Simple File Operations - -(declare (usual-integrations)) - -(define copy-file - (let ((p-copy-file (make-primitive-procedure 'COPY-FILE))) - (named-lambda (copy-file from to) - (p-copy-file (canonicalize-input-filename from) - (canonicalize-output-filename to))))) - -(define rename-file - (let ((p-rename-file (make-primitive-procedure 'RENAME-FILE))) - (named-lambda (rename-file from to) - (p-rename-file (canonicalize-input-filename from) - (canonicalize-output-filename to))))) - -(define delete-file - (let ((p-delete-file (make-primitive-procedure 'REMOVE-FILE))) - (named-lambda (delete-file name) - (p-delete-file (canonicalize-input-filename name))))) - -(define file-exists? - (let ((p-file-exists? (make-primitive-procedure 'FILE-EXISTS?))) - (named-lambda (file-exists? name) - (let ((pathname (->pathname name))) - (if (eq? 'NEWEST (pathname-version pathname)) - (pathname-newest pathname) - (p-file-exists? - (pathname->string (pathname->absolute-pathname pathname)))))))) diff --git a/v7/src/runtime/stream.scm b/v7/src/runtime/stream.scm deleted file mode 100644 index f00030a13..000000000 --- a/v7/src/runtime/stream.scm +++ /dev/null @@ -1,184 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/stream.scm,v 13.41 1987/01/23 00:20:30 jinx Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Stream Utilities - -(declare (usual-integrations)) - -;;;; General Streams - -(define (nth-stream n s) - (cond ((empty-stream? s) - (error "Empty stream -- NTH-STREAM" n)) - ((= n 0) - (head s)) - (else - (nth-stream (- n 1) (tail s))))) - -(define (accumulate combiner initial-value stream) - (if (empty-stream? stream) - initial-value - (combiner (head stream) - (accumulate combiner - initial-value - (tail stream))))) - -(define (filter pred stream) - (cond ((empty-stream? stream) - the-empty-stream) - ((pred (head stream)) - (cons-stream (head stream) - (filter pred (tail stream)))) - (else - (filter pred (tail stream))))) - -(define (map-stream proc stream) - (if (empty-stream? stream) - the-empty-stream - (cons-stream (proc (head stream)) - (map-stream proc (tail stream))))) - -(define (map-stream-2 proc s1 s2) - (if (or (empty-stream? s1) - (empty-stream? s2)) - the-empty-stream - (cons-stream (proc (head s1) (head s2)) - (map-stream-2 proc (tail s1) (tail s2))))) - -(define (append-streams s1 s2) - (if (empty-stream? s1) - s2 - (cons-stream (head s1) - (append-streams (tail s1) s2)))) - -(define (enumerate-fringe tree) - (if (pair? tree) - (append-streams (enumerate-fringe (car tree)) - (enumerate-fringe (cdr tree))) - (cons-stream tree the-empty-stream))) - -;;;; Numeric Streams - -(define (add-streams s1 s2) - (cond ((empty-stream? s1) s2) - ((empty-stream? s2) s1) - (else - (cons-stream (+ (head s1) (head s2)) - (add-streams (tail s1) (tail s2)))))) - -(define (scale-stream c s) - (map-stream (lambda (x) (* c x)) s)) - -(define (enumerate-interval n1 n2) - (if (> n1 n2) - the-empty-stream - (cons-stream n1 (enumerate-interval (1+ n1) n2)))) - -(define (integers-from n) - (cons-stream n (integers-from (1+ n)))) - -(define integers - (integers-from 0)) - -;;;; Some Hairier Stuff - -(define (merge s1 s2) - (cond ((empty-stream? s1) s2) - ((empty-stream? s2) s1) - (else - (let ((h1 (head s1)) - (h2 (head s2))) - (cond ((< h1 h2) - (cons-stream h1 - (merge (tail s1) - s2))) - ((> h1 h2) - (cons-stream h2 - (merge s1 - (tail s2)))) - (else - (cons-stream h1 - (merge (tail s1) - (tail s2))))))))) - -;;;; Printing - -(define print-stream - (let () - (define (iter s) - (if (empty-stream? s) - (write-string "}") - (begin (write-string " ") - (write (head s)) - (iter (tail s))))) - (lambda (s) - (newline) - (write-string "{") - (if (empty-stream? s) - (write-string "}") - (begin (write (head s)) - (iter (tail s))))))) - -;;;; Support for COLLECT - -(define (flatmap f s) - (flatten (map-stream f s))) - -(define (flatten stream) - (accumulate-delayed interleave-delayed - the-empty-stream - stream)) - -(define (accumulate-delayed combiner initial-value stream) - (if (empty-stream? stream) - initial-value - (combiner (head stream) - (delay (accumulate-delayed combiner - initial-value - (tail stream)))))) - -(define (interleave-delayed s1 delayed-s2) - (if (empty-stream? s1) - (force delayed-s2) - (cons-stream (head s1) - (interleave-delayed (force delayed-s2) - (delay (tail s1)))))) - -(define ((spread-tuple procedure) tuple) - (apply procedure tuple)) diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm deleted file mode 100644 index 93f2260ec..000000000 --- a/v7/src/runtime/string.scm +++ /dev/null @@ -1,424 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/string.scm,v 13.41 1987/01/23 00:20:37 jinx Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Character String Operations - -(declare (usual-integrations)) - -;;;; Primitives - -(in-package system-global-environment -(let-syntax () - (define-macro (define-primitives . names) - `(BEGIN ,@(map (lambda (name) - `(DEFINE ,name ,(make-primitive-procedure name))) - names))) - - (define-primitives - string-allocate string? string-ref string-set! - string-length string-maximum-length set-string-length! - substring=? substring-ci=? substringascii char))) - -(define (substring-find-next-char string start end char) - (vector-8b-find-next-char string start end (char->ascii char))) - -(define (substring-find-previous-char string start end char) - (vector-8b-find-previous-char string start end (char->ascii char))) - -(define (substring-find-next-char-ci string start end char) - (vector-8b-find-next-char-ci string start end (char->ascii char))) - -(define (substring-find-previous-char-ci string start end char) - (vector-8b-find-previous-char-ci string start end (char->ascii char))) - -;;; Special, not implemented in microcode. - -(define (substring-ci? string1 string2) - (substring? string1 string2) - (substring-ci=? string1 string2) - (not (substring=? string1 string2) - (not (substring-cistring chars) - (let ((result (string-allocate (length chars)))) - (define (loop index chars) - (if (null? chars) - result - (begin (string-set! result index (car chars)) - (loop (1+ index) (cdr chars))))) - (loop 0 chars))) - -(define (char->string . chars) - (list->string chars)) - -(define (string->list string) - (substring->list string 0 (string-length string))) - -(define (substring->list string start end) - (define (loop index) - (if (= index end) - '() - (cons (string-ref string index) - (loop (1+ index))))) - (loop start)) - -(define (string-copy string) - (let ((size (string-length string))) - (let ((result (string-allocate size))) - (substring-move-right! string 0 size result 0) - result))) - -(define (string-append . strings) - (define (count strings) - (if (null? strings) - 0 - (+ (string-length (car strings)) - (count (cdr strings))))) - - (let ((result (string-allocate (count strings)))) - (define (move strings index) - (if (null? strings) - result - (let ((size (string-length (car strings)))) - (substring-move-right! (car strings) 0 size result index) - (move (cdr strings) (+ index size))))) - - (move strings 0))) - -;;;; Case - -(define (string-upper-case? string) - (substring-upper-case? string 0 (string-length string))) - -(define (substring-upper-case? string start end) - (define (find-upper start) - (and (not (= start end)) - ((if (char-upper-case? (string-ref string start)) - search-rest - find-upper) - (1+ start)))) - (define (search-rest start) - (or (= start end) - (and (not (char-lower-case? (string-ref string start))) - (search-rest (1+ start))))) - (find-upper start)) - -(define (string-upcase string) - (let ((string (string-copy string))) - (string-upcase! string) - string)) - -(define (string-upcase! string) - (substring-upcase! string 0 (string-length string))) - -(define (string-lower-case? string) - (substring-lower-case? string 0 (string-length string))) - -(define (substring-lower-case? string start end) - (define (find-lower start) - (and (not (= start end)) - ((if (char-lower-case? (string-ref string start)) - search-rest - find-lower) - (1+ start)))) - (define (search-rest start) - (or (= start end) - (and (not (char-upper-case? (string-ref string start))) - (search-rest (1+ start))))) - (find-lower start)) - -(define (string-downcase string) - (let ((string (string-copy string))) - (string-downcase! string) - string)) - -(define (string-downcase! string) - (substring-downcase! string 0 (string-length string))) - -(define (string-capitalized? string) - (substring-capitalized? string 0 (string-length string))) - -(define (substring-capitalized? string start end) - (and (not (= start end)) - (char-upper-case? (string-ref string 0)) - (substring-lower-case? string (1+ start) end))) - -(define (string-capitalize string) - (let ((string (string-copy string))) - (string-capitalize! string) - string)) - -(define (string-capitalize! string) - (let ((length (string-length string))) - (if (zero? length) (error "String must have non-zero length" string)) - (substring-upcase! string 0 1) - (substring-downcase! string 1 length))) - -;;;; Replace - -(define (string-replace string char1 char2) - (let ((string (string-copy string))) - (string-replace! string char1 char2) - string)) - -(define (substring-replace string start end char1 char2) - (let ((string (string-copy string))) - (substring-replace! string start end char1 char2) - string)) - -(define (string-replace! string char1 char2) - (substring-replace! string 0 (string-length string) char1 char2)) - -(define (substring-replace! string start end char1 char2) - (define (loop start) - (let ((index (substring-find-next-char string start end char1))) - (if index - (begin (string-set! string index char2) - (loop (1+ index)))))) - (loop start)) - -;;;; Compare - -(define (string-compare string1 string2 if= if< if>) - (let ((size1 (string-length string1)) - (size2 (string-length string2))) - (let ((match (substring-match-forward string1 0 size1 string2 0 size2))) - ((if (= match size1) - (if (= match size2) if= if<) - (if (= match size2) if> - (if (char))))))) - -(define (string-prefix? string1 string2) - (substring-prefix? string1 0 (string-length string1) - string2 0 (string-length string2))) - -(define (substring-prefix? string1 start1 end1 string2 start2 end2) - (and (<= (- end1 start1) (- end2 start2)) - (= (substring-match-forward string1 start1 end1 - string2 start2 end2) - end1))) - -(define (string-compare-ci string1 string2 if= if< if>) - (let ((size1 (string-length string1)) - (size2 (string-length string2))) - (let ((match (substring-match-forward-ci string1 0 size1 string2 0 size2))) - ((if (= match size1) - (if (= match size2) if= if<) - (if (= match size2) if> - (if (char-ci))))))) - -(define (string-prefix-ci? string1 string2) - (substring-prefix-ci? string1 0 (string-length string1) - string2 0 (string-length string2))) - -(define (substring-prefix-ci? string1 start1 end1 string2 start2 end2) - (and (<= (- end1 start1) (- end2 start2)) - (= (substring-match-forward-ci string1 start1 end1 - string2 start2 end2) - end1))) - -;;;; Trim/Pad - -(define (string-trim-left string #!optional char-set) - (if (unassigned? char-set) (set! char-set char-set:not-whitespace)) - (let ((index (string-find-next-char-in-set string char-set)) - (length (string-length string))) - (if (not index) - "" - (substring string index length)))) - -(define (string-trim-right string #!optional char-set) - (if (unassigned? char-set) (set! char-set char-set:not-whitespace)) - (let ((index (string-find-previous-char-in-set string char-set))) - (if (not index) - "" - (substring string 0 (1+ index))))) - -(define (string-trim string #!optional char-set) - (if (unassigned? char-set) (set! char-set char-set:not-whitespace)) - (let ((index (string-find-next-char-in-set string char-set))) - (if (not index) - "" - (substring string index - (1+ (string-find-previous-char-in-set string char-set)))))) - -(define (string-pad-right string n #!optional char) - (if (unassigned? char) (set! char #\Space)) - (let ((length (string-length string))) - (if (= length n) - string - (let ((result (string-allocate n))) - (if (> length n) - (substring-move-right! string 0 n result 0) - (begin (substring-move-right! string 0 length result 0) - (substring-fill! result length n char))) - result)))) - -(define (string-pad-left string n #!optional char) - (if (unassigned? char) (set! char #\Space)) - (let ((length (string-length string))) - (if (= length n) - string - (let ((result (string-allocate n)) - (i (- n length))) - (if (negative? i) - (substring-move-right! string 0 n result 0) - (begin (substring-fill! result 0 i char) - (substring-move-right! string 0 length result i))) - result)))) diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm deleted file mode 100644 index c37fcef09..000000000 --- a/v7/src/runtime/syntax.scm +++ /dev/null @@ -1,1015 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 13.44 1987/04/03 00:52:43 jinx Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; SYNTAX: S-Expressions -> SCODE - -(declare (usual-integrations)) - -(define lambda-tag:unnamed - (make-named-tag "UNNAMED-PROCEDURE")) - -(define *fluid-let-type* - 'SHALLOW) - -(define lambda-tag:shallow-fluid-let - (make-named-tag "SHALLOW-FLUID-LET-PROCEDURE")) - -(define lambda-tag:deep-fluid-let - (make-named-tag "DEEP-FLUID-LET-PROCEDURE")) - -(define lambda-tag:common-lisp-fluid-let - (make-named-tag "COMMON-LISP-FLUID-LET-PROCEDURE")) - -(define lambda-tag:let - (make-named-tag "LET-PROCEDURE")) - -(define lambda-tag:make-environment - (make-named-tag "MAKE-ENVIRONMENT-PROCEDURE")) - -(define syntax) -(define syntax*) -(define macro-spreader) - -(define enable-scan-defines!) -(define with-scan-defines-enabled) -(define disable-scan-defines!) -(define with-scan-defines-disabled) - -;; Enable shallow vs fluid binding for FLUID-LET -(define shallow-fluid-let!) -(define deep-fluid-let!) -(define common-lisp-fluid-let!) - -(define system-global-syntax-table) -(define syntax-table?) -(define make-syntax-table) -(define extend-syntax-table) -(define copy-syntax-table) -(define syntax-table-ref) -(define syntax-table-define) -(define syntax-table-shadow) -(define syntax-table-undefine) - -(define syntaxer-package) -(let ((external-make-sequence make-sequence) - (external-make-lambda make-lambda)) -(set! syntaxer-package (the-environment)) - -;;;; Dispatch Point - -(define (syntax-expression expression) - (cond ((pair? expression) - (let ((quantum (syntax-table-ref syntax-table (car expression)))) - (if quantum - (fluid-let ((saved-keyword (car expression))) - (quantum expression)) - (make-combination (syntax-expression (car expression)) - (syntax-expressions (cdr expression)))))) - ((symbol? expression) - (make-variable expression)) - (else - expression))) - -(define (syntax-expressions expressions) - (if (null? expressions) - '() - (cons (syntax-expression (car expressions)) - (syntax-expressions (cdr expressions))))) - -(define ((spread-arguments kernel) expression) - (apply kernel (cdr expression))) - -(define saved-keyword - (make-interned-symbol "")) - -(define (syntax-error message . irritant) - (error (string-append message - ": " - (symbol->string saved-keyword) - " SYNTAX") - (cond ((null? irritant) *the-non-printing-object*) - ((null? (cdr irritant)) (car irritant)) - (else irritant)))) - -(define (syntax-sequence subexpressions) - (if (null? subexpressions) - (syntax-error "No subforms in sequence") - (make-sequence (syntax-sequentially subexpressions)))) - -(define (syntax-sequentially expressions) - (if (null? expressions) - '() - ;; force eval order. - (let ((first (syntax-expression (car expressions)))) - (cons first - (syntax-sequentially (cdr expressions)))))) - -(define (syntax-bindings bindings receiver) - (cond ((null? bindings) - (receiver '() '())) - ((and (pair? (car bindings)) - (symbol? (caar bindings))) - (syntax-bindings (cdr bindings) - (lambda (names values) - (receiver (cons (caar bindings) names) - (cons (expand-binding-value (cdar bindings)) values))))) - (else - (syntax-error "Badly-formed binding" (car bindings))))) - -;;;; Expanders - -(define (expand-access chain cont) - (if (symbol? (car chain)) - (cont (if (null? (cddr chain)) - (syntax-expression (cadr chain)) - (expand-access (cdr chain) make-access)) - (car chain)) - (syntax-error "Non-symbolic variable" (car chain)))) - -(define (expand-binding-value rest) - (cond ((null? rest) unassigned-object) - ((null? (cdr rest)) (syntax-expression (car rest))) - (else (syntax-error "Too many forms in value" rest)))) - -(define expand-conjunction - (let () - (define (expander forms) - (if (null? (cdr forms)) - (syntax-expression (car forms)) - (make-conjunction (syntax-expression (car forms)) - (expander (cdr forms))))) - (named-lambda (expand-conjunction forms) - (if (null? forms) - true - (expander forms))))) - -(define expand-disjunction - (let () - (define (expander forms) - (if (null? (cdr forms)) - (syntax-expression (car forms)) - (make-disjunction (syntax-expression (car forms)) - (expander (cdr forms))))) - (named-lambda (expand-disjunction forms) - (if (null? forms) - false - (expander forms))))) - -(define (expand-lambda pattern actions receiver) - (define (loop pattern body) - (if (pair? (car pattern)) - (loop (car pattern) - (make-lambda (cdr pattern) body)) - (receiver pattern body))) - ((if (pair? pattern) loop receiver) pattern (syntax-lambda-body actions))) - -(define (syntax-lambda-body body) - (syntax-sequence - (if (and (not (null? body)) - (not (null? (cdr body))) - (string? (car body))) - (cdr body) ;discard documentation string. - body))) - -;;;; Quasiquote - -(define expand-quasiquote) -(let () - -(define (descend-quasiquote x level return) - (cond ((pair? x) (descend-quasiquote-pair x level return)) - ((vector? x) (descend-quasiquote-vector x level return)) - (else (return 'QUOTE x)))) - -(define (descend-quasiquote-pair x level return) - (define (descend-quasiquote-pair* level) - (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) - (if (and (eq? cdr-mode 'QUOTE) - (null? cdr-arg)) - (return 'UNQUOTE car-arg) - (return (system 'APPEND) - (list car-arg - (finalize-quasiquote cdr-mode cdr-arg))))) - ((and (eq? cdr-mode 'QUOTE) - (null? cdr-arg)) - (return 'LIST - (list (finalize-quasiquote car-mode car-arg)))) - ((and (eq? cdr-mode 'QUOTE) - (list? cdr-arg)) - (return 'LIST - (cons (finalize-quasiquote car-mode car-arg) - (map (lambda (el) - (finalize-quasiquote 'QUOTE el)) - cdr-arg)))) - ((memq cdr-mode '(LIST CONS)) - (return cdr-mode - (cons (finalize-quasiquote car-mode car-arg) - cdr-arg))) - (else - (return - 'CONS - (list (finalize-quasiquote car-mode car-arg) - (finalize-quasiquote cdr-mode cdr-arg)))))))))) - (case (car x) - ((QUASIQUOTE) (descend-quasiquote-pair* (1+ level))) - ((UNQUOTE UNQUOTE-SPLICING) - (if (zero? level) - (return (car x) (cadr x)) - (descend-quasiquote-pair* (- level 1)))) - (else (descend-quasiquote-pair* level)))) - -(define (descend-quasiquote-vector x level return) - (descend-quasiquote (vector->list x) level - (lambda (mode arg) - (case mode - ((QUOTE) - (return 'QUOTE x)) - ((LIST) - (return (system 'VECTOR) arg)) - (else - (return (system 'LIST->VECTOR) - (list (finalize-quasiquote mode arg)))))))) - -(define (finalize-quasiquote mode arg) - (case mode - ((QUOTE) `',arg) - ((UNQUOTE) arg) - ((UNQUOTE-SPLICING) (error ",@ in illegal context" arg)) - ((LIST) `(,(system 'LIST) ,@arg)) - ((CONS) - (if (= (length arg) 2) - `(,(system 'CONS) ,@arg) - `(,(system 'CONS*) ,@arg))) - (else `(,mode ,@arg)))) - -(define (system name) - `(ACCESS ,name #F)) - -(set! expand-quasiquote - (named-lambda (expand-quasiquote expression) - (syntax-expression (descend-quasiquote expression 0 finalize-quasiquote)))) - -) - -;;;; Basic Syntax - -(define syntax-SCODE-QUOTE-form - (spread-arguments - (lambda (expression) - (make-quotation (syntax-expression expression))))) - -(define syntax-QUOTE-form - (spread-arguments identity-procedure)) - -(define syntax-THE-ENVIRONMENT-form - (spread-arguments make-the-environment)) - -(define syntax-UNASSIGNED?-form - (spread-arguments make-unassigned?)) - -(define syntax-UNBOUND?-form - (spread-arguments make-unbound?)) - -(define syntax-ACCESS-form - (spread-arguments - (lambda chain - (expand-access chain make-access)))) - -(define syntax-SET!-form - (spread-arguments - (lambda (name . rest) - ((syntax-extended-assignment name) - (expand-binding-value rest))))) - -(define syntax-DEFINE-form - (spread-arguments - (lambda (pattern . rest) - (cond ((symbol? pattern) - (make-definition pattern - (expand-binding-value - (if (and (= (length rest) 2) - (string? (cadr rest))) - (list (car rest)) - rest)))) - ((pair? pattern) - (expand-lambda pattern rest - (lambda (pattern body) - (make-definition (car pattern) - (make-named-lambda (car pattern) (cdr pattern) - body))))) - (else - (syntax-error "Bad pattern" pattern)))))) - -(define syntax-SEQUENCE-form - (spread-arguments - (lambda actions - (syntax-sequence actions)))) - -(define syntax-IN-PACKAGE-form - (spread-arguments - (lambda (environment . body) - (make-in-package (syntax-expression environment) - (syntax-sequence body))))) - -(define syntax-DELAY-form - (spread-arguments - (lambda (expression) - (make-delay (syntax-expression expression))))) - -(define syntax-CONS-STREAM-form - (spread-arguments - (lambda (head tail) - (make-combination* cons - (syntax-expression head) - (make-delay (syntax-expression tail)))))) - -;;;; Conditionals - -(define syntax-IF-form - (spread-arguments - (lambda (predicate consequent . rest) - (make-conditional (syntax-expression predicate) - (syntax-expression consequent) - (cond ((null? rest) - false) - ((null? (cdr rest)) - (syntax-expression (car rest))) - (else - (syntax-error "Too many forms" (cdr rest)))))))) - -(define syntax-COND-form - (let () - (define (process-cond-clauses clause rest) - (cond ((eq? (car clause) 'ELSE) - (if (null? rest) - (syntax-sequence (cdr clause)) - (syntax-error "ELSE not last clause" rest))) - ((null? rest) - (if (cdr clause) - (make-conjunction (syntax-expression (car clause)) - (syntax-sequence (cdr clause))) - (syntax-expression (car clause)))) - ((null? (cdr clause)) - (make-disjunction (syntax-expression (car clause)) - (process-cond-clauses (car rest) - (cdr rest)))) - ((and (pair? (cdr clause)) - (eq? (cadr clause) '=>)) - (syntax-expression - `((ACCESS COND-=>-HELPER SYNTAXER-PACKAGE '()) - ,(car clause) - (DELAY ,@(cddr clause)) - (DELAY (COND ,@rest))))) - (else - (make-conditional (syntax-expression (car clause)) - (syntax-sequence (cdr clause)) - (process-cond-clauses (car rest) - (cdr rest)))))) - (spread-arguments - (lambda (clause . rest) - (process-cond-clauses clause rest))))) - -(define (cond-=>-helper form1-result thunk2 thunk3) - (if form1-result - ((force thunk2) form1-result) - (force thunk3))) - -(define (make-funcall name . args) - (make-combination (make-variable name) args)) - -(define syntax-CONJUNCTION-form - (spread-arguments - (lambda forms - (expand-conjunction forms)))) - -(define syntax-DISJUNCTION-form - (spread-arguments - (lambda forms - (expand-disjunction forms)))) - -;;;; Procedures - -(define syntax-LAMBDA-form - (spread-arguments - (lambda (pattern . body) - (make-lambda pattern (syntax-lambda-body body))))) - -(define syntax-NAMED-LAMBDA-form - (spread-arguments - (lambda (pattern . body) - (expand-lambda pattern body - (lambda (pattern body) - (make-named-lambda (car pattern) (cdr pattern) body)))))) - -(define syntax-LET-form - (spread-arguments - (lambda (name-or-pattern pattern-or-first . rest) - (if (symbol? name-or-pattern) - (syntax-bindings pattern-or-first - (lambda (names values) - (make-letrec (list name-or-pattern) - (list (make-named-lambda name-or-pattern names - (syntax-sequence rest))) - (make-combination (make-variable name-or-pattern) - values)))) - (syntax-bindings name-or-pattern - (lambda (names values) - (make-closed-block - lambda-tag:let names values - (syntax-sequence (cons pattern-or-first rest))))))))) - -(define syntax-MAKE-ENVIRONMENT-form - (spread-arguments - (lambda body - (make-closed-block - lambda-tag:make-environment '() '() - (if (null? body) - the-environment-object - (make-sequence* (syntax-sequence body) the-environment-object)))))) - -;;;; Syntax Extensions - -(define syntax-LET-SYNTAX-form - (spread-arguments - (lambda (bindings . body) - (syntax-bindings bindings - (lambda (names values) - (fluid-let ((syntax-table - (extend-syntax-table - (map (lambda (name value) - (cons name (syntax-eval value))) - names - values) - syntax-table))) - (syntax-sequence body))))))) - -(define syntax-USING-SYNTAX-form - (spread-arguments - (lambda (table . body) - (let ((table* (syntax-eval (syntax-expression table)))) - (if (not (syntax-table? table*)) - (syntax-error "Not a syntax table" table)) - (fluid-let ((syntax-table table*)) - (syntax-sequence body)))))) - -(define syntax-DEFINE-SYNTAX-form - (spread-arguments - (lambda (name value) - (cond ((symbol? name) - (syntax-table-define syntax-table name - (syntax-eval (syntax-expression value))) - name) - ((and (pair? name) (symbol? (car name))) - (syntax-table-define syntax-table (car name) - (let ((transformer - (syntax-eval (syntax-NAMED-LAMBDA-form - `(NAMED-LAMBDA ,name ,value))))) - (lambda (expression) - (apply transformer (cdr expression))))) - (car name)) - (else (syntax-error "Bad syntax description" name)))))) - -(define (syntax-MACRO-form expression) - (make-combination* (expand-access '(MACRO-SPREADER '()) make-access) - (syntax-LAMBDA-form expression))) - -(define (syntax-DEFINE-MACRO-form expression) - (syntax-table-define syntax-table (caadr expression) - (macro-spreader (syntax-eval (syntax-NAMED-LAMBDA-form expression)))) - (caadr expression)) - -(set! macro-spreader -(named-lambda ((macro-spreader transformer) expression) - (syntax-expression (apply transformer (cdr expression))))) - -;;;; Grab Bag - -(define (syntax-ERROR-LIKE-form procedure-name) - (spread-arguments - (lambda (message . rest) - (make-combination* (make-variable procedure-name) - (syntax-expression message) - (cond ((null? rest) - ;; Slightly crockish, but prevents - ;; hidden variable reference. - (make-access (make-null) - '*THE-NON-PRINTING-OBJECT*)) - ((null? (cdr rest)) - (syntax-expression (car rest))) - (else - (make-combination - (make-access (make-null) 'LIST) - (syntax-expressions rest)))) - (make-the-environment))))) - -(define syntax-ERROR-form - (syntax-ERROR-LIKE-form 'ERROR-PROCEDURE)) - -(define syntax-BKPT-form - (syntax-ERROR-LIKE-form 'BREAKPOINT-PROCEDURE)) - -(define syntax-QUASIQUOTE-form - (spread-arguments expand-quasiquote)) - -;;;; FLUID-LET - -(define syntax-FLUID-LET-form-shallow - (let () - - (define (syntax-fluid-bindings bindings receiver) - (if (null? bindings) - (receiver '() '() '() '()) - (syntax-fluid-bindings (cdr bindings) - (lambda (names values transfers-in transfers-out) - (let ((binding (car bindings))) - (if (pair? binding) - (let ((transfer - (let ((assignment - (syntax-extended-assignment (car binding)))) - (lambda (target source) - (make-assignment - target - (assignment - (make-assignment source - unassigned-object)))))) - (value (expand-binding-value (cdr binding))) - (inside-name - (string->uninterned-symbol "INSIDE-PLACEHOLDER")) - (outside-name - (string->uninterned-symbol "OUTSIDE-PLACEHOLDER"))) - (receiver (cons* inside-name outside-name names) - (cons* value unassigned-object values) - (cons (transfer outside-name inside-name) - transfers-in) - (cons (transfer inside-name outside-name) - transfers-out))) - (syntax-error "Binding not a pair" binding))))))) - - (spread-arguments - (lambda (bindings . body) - (if (null? bindings) - (syntax-sequence body) - (syntax-fluid-bindings bindings - (lambda (names values transfers-in transfers-out) - (make-closed-block - lambda-tag:shallow-fluid-let names values - (make-combination* - (make-variable 'DYNAMIC-WIND) - (make-thunk (make-sequence transfers-in)) - (make-thunk (syntax-sequence body)) - (make-thunk (make-sequence transfers-out))))))))))) - -(define syntax-FLUID-LET-form-deep) -(define syntax-FLUID-LET-form-common-lisp) -(let () - -(define (make-fluid-let primitive procedure-tag) - ;; (FLUID-LET (( ) ...) . ) => - ;; (WITH-SAVED-FLUID-BINDINGS - ;; (LAMBDA () - ;; (ADD-FLUID! (THE-ENVIRONMENT) ) - ;; ... - ;; )) - (let ((with-saved-fluid-bindings - (make-primitive-procedure 'WITH-SAVED-FLUID-BINDINGS #t))) - (spread-arguments - (lambda (bindings . body) - (syntax-fluid-bindings bindings - (lambda (names values) - (make-combination - (internal-make-lambda procedure-tag '() '() '() - (make-combination - with-saved-fluid-bindings - (list - (make-thunk - (make-sequence - (map* - (list (syntax-sequence body)) - (lambda (name-or-access value) - (cond ((variable? name-or-access) - (make-combination - primitive - (list the-environment-object - (make-quotation name-or-access) - value))) - ((access? name-or-access) - (access-components name-or-access - (lambda (env name) - (make-combination primitive - (list env name value))))) - (else - (syntax-error - "Target of FLUID-LET not a symbol or ACCESS form" - name-or-access)))) - names values)))))) - '()))))))) - -(define (syntax-fluid-bindings bindings receiver) - (if (null? bindings) - (receiver '() '()) - (syntax-fluid-bindings - (cdr bindings) - (lambda (names values) - (let ((binding (car bindings))) - (if (pair? binding) - (receiver (cons (let ((name (syntax-expression (car binding)))) - (if (or (variable? name) - (access? name)) - name - (syntax-error "Binding name illegal" - (car binding)))) - names) - (cons (expand-binding-value (cdr binding)) values)) - (syntax-error "Binding not a pair" binding))))))) - -(set! syntax-FLUID-LET-form-deep - (make-fluid-let (make-primitive-procedure 'ADD-FLUID-BINDING! #t) - lambda-tag:deep-fluid-let)) - -(set! syntax-FLUID-LET-form-common-lisp - ;; This -- groan -- is for Common Lisp support - (make-fluid-let (make-primitive-procedure 'MAKE-FLUID-BINDING! #t) - lambda-tag:common-lisp-fluid-let)) - -;;; end special FLUID-LETs. -) - -;;;; Extended Assignment Syntax - -(define (syntax-extended-assignment expression) - (invert-expression (syntax-expression expression))) - -(define (invert-expression target) - (cond ((variable? target) - (invert-variable (variable-name target))) - ((access? target) - (access-components target invert-access)) - (else - (syntax-error "Bad target" target)))) - -(define ((invert-variable name) value) - (make-assignment name value)) - -(define ((invert-access environment name) value) - (make-combination* lexical-assignment environment name value)) - -;;;; Declarations - -;;; All declarations are syntactically checked; the resulting -;;; DECLARATION objects all contain lists of standard declarations. -;;; Each standard declaration is a proper list with symbolic keyword. - -(define syntax-LOCAL-DECLARE-form - (spread-arguments - (lambda (declarations . body) - (make-declaration (process-declarations declarations) - (syntax-sequence body))))) - -(define syntax-DECLARE-form - (spread-arguments - (lambda declarations - (make-block-declaration (map process-declaration declarations))))) - -;;; These two procedures use `error' instead of `syntax-error' because -;;; they are called when the syntaxer is not running. - -(define (process-declarations declarations) - (if (list? declarations) - (map process-declaration declarations) - (error "SYNTAX: Illegal declaration list" declarations))) - -(define (process-declaration declaration) - (cond ((symbol? declaration) - (list declaration)) - ((and (list? declaration) - (not (null? declaration)) - (symbol? (car declaration))) - declaration) - (else - (error "SYNTAX: Illegal declaration" declaration)))) - -;;;; SCODE Constructors - -(define unassigned-object - (make-unassigned-object)) - -(define the-environment-object - (make-the-environment)) - -(define (make-conjunction first second) - (make-conditional first second false)) - -(define (make-combination* operator . operands) - (make-combination operator operands)) - -(define (make-sequence* . operands) - (make-sequence operands)) - -(define (make-sequence operands) - (internal-make-sequence operands)) - -(define (make-thunk body) - (make-lambda '() body)) - -(define (make-lambda pattern body) - (make-named-lambda lambda-tag:unnamed pattern body)) - -(define (make-named-lambda name pattern body) - (if (not (symbol? name)) - (syntax-error "Name of lambda expression must be a symbol" name)) - (parse-lambda-list pattern - (lambda (required optional rest) - (internal-make-lambda name required optional rest body)))) - -(define (make-closed-block tag names values body) - (make-combination (internal-make-lambda tag names '() '() body) - values)) - -(define (make-letrec names values body) - (make-closed-block lambda-tag:let '() '() - (make-sequence (append! (map make-definition names values) - (list body))))) - -;;;; Lambda List Parser - -(define (parse-lambda-list lambda-list receiver) - (let ((required (list '())) - (optional (list '()))) - (define (parse-parameters cell) - (define (loop pattern) - (cond ((null? pattern) (finish false)) - ((symbol? pattern) (finish pattern)) - ((not (pair? pattern)) (bad-lambda-list pattern)) - ((eq? (car pattern) (access lambda-rest-tag lambda-package)) - (if (and (pair? (cdr pattern)) (null? (cddr pattern))) - (cond ((symbol? (cadr pattern)) (finish (cadr pattern))) - ((and (pair? (cadr pattern)) - (symbol? (caadr pattern))) - (finish (caadr pattern))) - (else (bad-lambda-list (cdr pattern)))) - (bad-lambda-list (cdr pattern)))) - ((eq? (car pattern) (access lambda-optional-tag lambda-package)) - (if (eq? cell required) - ((parse-parameters optional) (cdr pattern)) - (bad-lambda-list pattern))) - ((symbol? (car pattern)) - (set-car! cell (cons (car pattern) (car cell))) - (loop (cdr pattern))) - ((and (pair? (car pattern)) (symbol? (caar pattern))) - (set-car! cell (cons (caar pattern) (car cell))) - (loop (cdr pattern))) - (else (bad-lambda-list pattern)))) - loop) - - (define (finish rest) - (receiver (reverse! (car required)) - (reverse! (car optional)) - rest)) - - (define (bad-lambda-list pattern) - (syntax-error "Illegally-formed lambda-list" pattern)) - - ((parse-parameters required) lambda-list))) - -;;;; Scan Defines - -(define no-scan-make-sequence - external-make-sequence) - -(define (scanning-make-sequence actions) - (scan-defines (external-make-sequence actions) - make-open-block)) - -(define (no-scan-make-lambda name required optional rest body) - (external-make-lambda name required optional rest '() '() body)) - -(define scanning-make-lambda - make-lambda*) - -(define internal-make-sequence) -(define internal-make-lambda) - -(set! enable-scan-defines! -(named-lambda (enable-scan-defines!) - (set! internal-make-sequence scanning-make-sequence) - (set! internal-make-lambda scanning-make-lambda))) - -(set! with-scan-defines-enabled -(named-lambda (with-scan-defines-enabled thunk) - (fluid-let ((internal-make-sequence scanning-make-sequence) - (internal-make-lambda scanning-make-lambda)) - (thunk)))) - -(set! disable-scan-defines! -(named-lambda (disable-scan-defines!) - (set! internal-make-sequence no-scan-make-sequence) - (set! internal-make-lambda no-scan-make-lambda))) - -(set! with-scan-defines-disabled -(named-lambda (with-scan-defines-disabled thunk) - (fluid-let ((internal-make-sequence no-scan-make-sequence) - (internal-make-lambda no-scan-make-lambda)) - (thunk)))) - -(define ((fluid-let-maker marker which-kind) #!optional name) - (if (unassigned? name) (set! name 'FLUID-LET)) - (if (eq? name 'FLUID-LET) (set! *fluid-let-type* marker)) - (add-syntax! name which-kind)) - -(set! shallow-fluid-let! - (fluid-let-maker 'SHALLOW syntax-fluid-let-form-shallow)) -(set! deep-fluid-let! - (fluid-let-maker 'DEEP syntax-fluid-let-form-deep)) -(set! common-lisp-fluid-let! - (fluid-let-maker 'COMMON-LISP syntax-fluid-let-form-common-lisp)) - -;;;; Top Level Syntaxers - -(define syntax-table) - -(define syntax-environment - (in-package system-global-environment - (make-environment))) - -;;; The top level procedures, when not given an argument, use whatever -;;; the current syntax table is. This is reasonable only while inside -;;; a syntaxer quantum, since at other times there is current table. - -(define ((make-syntax-top-level syntaxer) expression #!optional table) - (if (unassigned? table) - (syntaxer expression) - (begin (check-syntax-table table 'SYNTAX) - (fluid-let ((syntax-table table)) - (syntaxer expression))))) - -(set! syntax (make-syntax-top-level syntax-expression)) -(set! syntax* (make-syntax-top-level syntax-sequence)) - -(define (syntax-eval scode) - (scode-eval scode syntax-environment)) - -;;;; Syntax Table - -(define syntax-table-tag - '(SYNTAX-TABLE)) - -(set! syntax-table? -(named-lambda (syntax-table? object) - (and (pair? object) - (eq? (car object) syntax-table-tag)))) - -(define (check-syntax-table table name) - (if (not (syntax-table? table)) - (error "Not a syntax table" name table))) - -(set! make-syntax-table -(named-lambda (make-syntax-table #!optional parent) - (cons syntax-table-tag - (cons '() - (if (unassigned? parent) - '() - (cdr parent)))))) - -(set! extend-syntax-table -(named-lambda (extend-syntax-table alist #!optional table) - (if (unassigned? table) (set! table (current-syntax-table))) - (check-syntax-table table 'EXTEND-SYNTAX-TABLE) - (cons syntax-table-tag (cons alist (cdr table))))) - -(set! copy-syntax-table -(named-lambda (copy-syntax-table #!optional table) - (if (unassigned? table) (set! table (current-syntax-table))) - (check-syntax-table table 'COPY-SYNTAX-TABLE) - (cons syntax-table-tag - (map (lambda (alist) - (map (lambda (pair) - (cons (car pair) (cdr pair))) - alist)) - (cdr table))))) - -(set! syntax-table-ref -(named-lambda (syntax-table-ref table name) - (define (loop frames) - (and (not (null? frames)) - (let ((entry (assq name (car frames)))) - (if entry - (cdr entry) - (loop (cdr frames)))))) - (check-syntax-table table 'SYNTAX-TABLE-REF) - (loop (cdr table)))) - -(set! syntax-table-define -(named-lambda (syntax-table-define table name quantum) - (check-syntax-table table 'SYNTAX-TABLE-DEFINE) - (let ((entry (assq name (cadr table)))) - (if entry - (set-cdr! entry quantum) - (set-car! (cdr table) - (cons (cons name quantum) - (cadr table))))))) - -(set! syntax-table-shadow -(named-lambda (syntax-table-shadow table name) - (check-syntax-table table 'SYNTAX-TABLE-SHADOW) - (let ((entry (assq name (cadr table)))) - (if entry - (set-cdr! entry false) - (set-car! (cdr table) - (cons (cons name false) - (cadr table))))))) - -(set! syntax-table-undefine -(named-lambda (syntax-table-undefine table name) - (check-syntax-table table 'SYNTAX-TABLE-UNDEFINE) - (if (assq name (cadr table)) - (set-car! (cdr table) - (del-assq! name (cadr table)))))) - -;;;; Default Syntax - -(enable-scan-defines!) - -(set! system-global-syntax-table - (cons syntax-table-tag - `(((ACCESS . ,syntax-ACCESS-form) - (AND . ,syntax-CONJUNCTION-form) - (BEGIN . ,syntax-SEQUENCE-form) - (BKPT . ,syntax-BKPT-form) - (COND . ,syntax-COND-form) - (CONS-STREAM . ,syntax-CONS-STREAM-form) - (DECLARE . ,syntax-DECLARE-form) - (DEFINE . ,syntax-DEFINE-form) - (DEFINE-SYNTAX . ,syntax-DEFINE-SYNTAX-form) - (DEFINE-MACRO . ,syntax-DEFINE-MACRO-form) - (DELAY . ,syntax-DELAY-form) - (ERROR . ,syntax-ERROR-form) - (FLUID-LET . ,syntax-FLUID-LET-form-shallow) - (IF . ,syntax-IF-form) - (IN-PACKAGE . ,syntax-IN-PACKAGE-form) - (LAMBDA . ,syntax-LAMBDA-form) - (LET . ,syntax-LET-form) - (LET-SYNTAX . ,syntax-LET-SYNTAX-form) - (LOCAL-DECLARE . ,syntax-LOCAL-DECLARE-form) - (MACRO . ,syntax-MACRO-form) - (MAKE-ENVIRONMENT . ,syntax-MAKE-ENVIRONMENT-form) - (NAMED-LAMBDA . ,syntax-NAMED-LAMBDA-form) - (OR . ,syntax-DISJUNCTION-form) - ;; The funniness here prevents QUASIQUOTE from being - ;; seen as a nested backquote. - (,'QUASIQUOTE . ,syntax-QUASIQUOTE-form) - (QUOTE . ,syntax-QUOTE-form) - (SCODE-QUOTE . ,syntax-SCODE-QUOTE-form) - (SEQUENCE . ,syntax-SEQUENCE-form) - (SET! . ,syntax-SET!-form) - (THE-ENVIRONMENT . ,syntax-THE-ENVIRONMENT-form) - (UNASSIGNED? . ,syntax-UNASSIGNED?-form) - (UNBOUND? . ,syntax-UNBOUND?-form) - (USING-SYNTAX . ,syntax-USING-SYNTAX-form) - )))) - -;;; end SYNTAXER-PACKAGE -) -) \ No newline at end of file diff --git a/v7/src/runtime/sysclk.scm b/v7/src/runtime/sysclk.scm deleted file mode 100644 index 6dcd2aee2..000000000 --- a/v7/src/runtime/sysclk.scm +++ /dev/null @@ -1,94 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sysclk.scm,v 13.41 1987/01/23 00:21:27 jinx Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; System Clock - -(declare (usual-integrations)) - -(define system-clock) -(define runtime) -(define measure-interval) -(define wait-interval) - -(let ((primitive-clock (make-primitive-procedure 'SYSTEM-CLOCK)) - (offset-time) - (non-runtime)) - -(define (clock) - (- (primitive-clock) offset-time)) - -(define (ticks->seconds ticks) - (/ ticks 100)) - -(define (seconds->ticks seconds) - (* seconds 100)) - -(define (reset-system-clock!) - (set! offset-time (primitive-clock)) - (set! non-runtime 0)) - -(reset-system-clock!) -(add-event-receiver! event:after-restore reset-system-clock!) - -(set! system-clock - (named-lambda (system-clock) - (ticks->seconds (clock)))) - -(set! runtime - (named-lambda (runtime) - (ticks->seconds (- (clock) non-runtime)))) - -(set! measure-interval - (named-lambda (measure-interval runtime? thunk) - (let ((start (clock))) - (let ((receiver (thunk (ticks->seconds start)))) - (let ((end (clock))) - (if (not runtime?) - (set! non-runtime (+ (- end start) non-runtime))) - (receiver (ticks->seconds end))))))) - -(set! wait-interval - (named-lambda (wait-interval number-of-seconds) - (let ((end (+ (clock) (seconds->ticks number-of-seconds)))) - (let wait-loop () - (if (< (clock) end) - (wait-loop)))))) - -;;; end LET. -) diff --git a/v7/src/runtime/system.scm b/v7/src/runtime/system.scm deleted file mode 100644 index 5ec8fdf1b..000000000 --- a/v7/src/runtime/system.scm +++ /dev/null @@ -1,280 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 13.45 1987/04/13 18:44:18 cph Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Systems - -(declare (usual-integrations)) - -;;; (DISK-SAVE filename #!optional identify) -;;; (DUMP-WORLD filename #!optional identify) -;;; Saves a world image in FILENAME. IDENTIFY has the following meaning: -;;; -;;; [] Not supplied => ^G on restore (normal for saving band). -;;; [] String => New world ID message, and ^G on restore. -;;; [] Otherwise => Returns normally (very useful for saving bugs!). -;;; -;;; The image saved by DISK-SAVE does not include the "microcode", the -;;; one saved by DUMP-WORLD does, and is an executable file. - -(define disk-save) -(define dump-world) -(define event:after-restore) -(define event:after-restart) -(define full-quit) -(define identify-world) -(define identify-system) -(define add-system!) -(define add-secondary-gc-daemon!) -(let () - -(define world-identification "Scheme") -(define known-systems '()) -(define secondary-gc-daemons '()) -(define date-world-saved) -(define time-world-saved) - -(define (restart-world) - (screen-clear) - (abort->top-level - (lambda () - (identify-world) - (event:after-restart)))) - -(define (setup-image save-image) - (lambda (filename #!optional identify) - (let ((d (date)) (t (time))) - (gc-flip) - ((access trigger-daemons garbage-collector-package) secondary-gc-daemons) - (save-image filename - (lambda (ie) - (set-interrupt-enables! ie) - (set! date-world-saved d) - (set! time-world-saved t) - *the-non-printing-object*) - (lambda (ie) - (set-interrupt-enables! ie) - (set! date-world-saved d) - (set! time-world-saved t) - (event:after-restore) - (cond ((unassigned? identify) - (restart-world)) - ((string? identify) - (set! world-identification identify) - (restart-world)) - (else - *the-non-printing-object*))))))) - -(set! disk-save - (setup-image save-world)) - -(set! dump-world - (setup-image - (let ((primitive (make-primitive-procedure 'DUMP-WORLD true))) - (lambda (filename after-dumping after-restoring) - (let ((ie (set-interrupt-enables! interrupt-mask-none))) - ((if (primitive filename) - after-restoring - after-dumping) - ie)))))) - -(set! event:after-restore (make-event-distributor)) -(set! event:after-restart (make-event-distributor)) - -(add-event-receiver! event:after-restart - (lambda () - (if (not (unassigned? init-file-pathname)) - (let ((file - (or (pathname->input-truename - (merge-pathnames init-file-pathname - (working-directory-pathname))) - (pathname->input-truename - (merge-pathnames init-file-pathname - (home-directory-pathname)))))) - (if (not (null? file)) - (load file user-initial-environment)))))) - -;; This is not the right place for this, but I don't know what is. - -(add-event-receiver! - event:after-restore - (lambda () - ((access reset! continuation-package)))) - -(set! full-quit -(named-lambda (full-quit) - (quit) - (restart-world))) - -(set! identify-world -(named-lambda (identify-world) - (newline) - (write-string world-identification) - (write-string " saved on ") - (write-string (apply date->string date-world-saved)) - (write-string " at ") - (write-string (apply time->string time-world-saved)) - (newline) - (write-string " Release ") - (write-string (access :release microcode-system)) - (for-each identify-system known-systems))) - -(set! identify-system -(named-lambda (identify-system system) - (newline) - (write-string " ") - (write-string (access :name system)) - (write-string " ") - (write (access :version system)) - (let ((mod (access :modification system))) - (if mod - (begin (write-string ".") - (write mod)))))) - -(set! add-system! -(named-lambda (add-system! system) - (set! known-systems (append! known-systems (list system))))) - -(set! add-secondary-gc-daemon! -(named-lambda (add-secondary-gc-daemon! daemon) - (if (not (memq daemon secondary-gc-daemons)) - (set! secondary-gc-daemons (cons daemon secondary-gc-daemons))))) - -) - -;;; Load the given system, which must have the following variables -;;; defined: -;;; -;;; :FILES which will be assigned the list of filenames actually -;;; loaded. -;;; -;;; :FILES-LISTS which should contain a list of pairs, the car of each -;;; pair being an environment, and the cdr a list of filenames. The -;;; files are loaded in the order specified, into the environments -;;; specified. COMPILED?, if false, means change all of the file -;;; types to "BIN". - -(define load-system!) -(let () - -(set! load-system! -(named-lambda (load-system! system #!optional compiled?) - (if (unassigned? compiled?) (set! compiled? (query "Load compiled"))) - (define (loop files) - (if (null? files) - '() - (split-list files 20 - (lambda (head tail) - (fasload-files head - (lambda (eval-list pure-list constant-list) - (if (not (null? pure-list)) - (begin (newline) (write-string "Purify") - (purify (list->vector pure-list) true))) - (if (not (null? constant-list)) - (begin (newline) (write-string "Constantify") - (purify (list->vector constant-list) false))) - (append! eval-list (loop tail)))))))) - (let ((files (format-files-list (access :files-lists system) compiled?))) - (set! (access :files system) - (map (lambda (file) (pathname->string (car file))) files)) - (for-each (lambda (file scode) - (newline) (write-string "Eval ") - (write (pathname->string (car file))) - (scode-eval scode (cdr file))) - files - (loop (map car files))) - (newline) - (write-string "Done")) - (add-system! system) - *the-non-printing-object*)) - -(define (split-list list n receiver) - (if (or (not (pair? list)) (zero? n)) - (receiver '() list) - (split-list (cdr list) (-1+ n) - (lambda (head tail) - (receiver (cons (car list) head) tail))))) - -(define (fasload-files pathnames receiver) - (if (null? pathnames) - (receiver '() '() '()) - (fasload-file (car pathnames) - (lambda (scode) - (fasload-files (cdr pathnames) - (lambda (eval-list pure-list constant-list) - (receiver (cons scode eval-list) - (cons scode pure-list) - constant-list)))) - (lambda (scode) - (fasload-files (cdr pathnames) - (lambda (eval-list pure-list constant-list) - (receiver (cons scode eval-list) - pure-list - (cons scode constant-list)))))))) - -(define (fasload-file pathname if-pure if-not-pure) - (let ((type (pathname-type pathname))) - (cond ((string-ci=? "bin" type) (if-pure (fasload pathname))) - ((string-ci=? "com" type) (if-not-pure (fasload pathname))) - (else (error "Unknown file type" type))))) - -(define (format-files-list files-lists compiled?) - (mapcan (lambda (files-list) - (map (lambda (filename) - (let ((pathname (->pathname filename))) - (cons (if compiled? - pathname - (pathname-new-type pathname "bin")) - (car files-list)))) - (cdr files-list))) - files-lists)) - -(define (query prompt) - (newline) - (write-string prompt) - (write-string " (Y or N)? ") - (let ((char (char-upcase (read-char)))) - (cond ((char=? #\Y char) - (write-string "Yes") - true) - ((char=? #\N char) - (write-string "No") - false) - (else (beep) (query prompt))))) - -) \ No newline at end of file diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm deleted file mode 100644 index 1a76f98eb..000000000 --- a/v7/src/runtime/unpars.scm +++ /dev/null @@ -1,304 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 13.42 1987/02/20 13:49:28 cph Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Unparser - -(declare (usual-integrations)) - -;;; Control Variables -(define *unparser-radix* #d10) -(define *unparser-list-breadth-limit* false) -(define *unparser-list-depth-limit* false) - -(define (unparse-with-brackets thunk) - (write-string "#[") - (thunk) - (write-char #\])) - -(define unparser-package - (make-environment - -(define *unparse-char) -(define *unparse-string) -(define *unparser-list-depth*) -(define *slashify*) - -(define (unparse-object object port #!optional slashify) - (if (unassigned? slashify) (set! slashify true)) - (fluid-let ((*unparse-char (access :write-char port)) - (*unparse-string (access :write-string port)) - (*unparser-list-depth* 0) - (*slashify* slashify)) - (*unparse-object-or-future object))) - -(define (*unparse-object-or-future object) - (if (future? object) - (unparse-with-brackets - (lambda () - (*unparse-string "FUTURE ") - (unparse-datum object))) - (*unparse-object object))) - -(define (*unparse-object object) - ((vector-ref dispatch-vector (primitive-type object)) object)) - -(define (*unparse-substring string start end) - (*unparse-string (substring string start end))) - -(define (unparse-default object) - (unparse-with-brackets - (lambda () - (*unparse-object (or (object-type object) - `(UNDEFINED-TYPE-CODE ,(primitive-type object)))) - (*unparse-char #\Space) - (unparse-datum object)))) - -(define dispatch-vector - (vector-cons number-of-microcode-types unparse-default)) - -(define (define-type type dispatcher) - (vector-set! dispatch-vector (microcode-type type) dispatcher)) - -(define-type 'NULL - (lambda (x) - (if (eq? x '()) - (*unparse-string "()") - (unparse-default x)))) - -(define-type 'TRUE - (lambda (x) - (if (eq? x true) - (*unparse-string "#T") - (unparse-default x)))) - -(define-type 'RETURN-ADDRESS - (lambda (return-address) - (unparse-with-brackets - (lambda () - (*unparse-string "RETURN-ADDRESS ") - (*unparse-object (return-address-name return-address)))))) - -(define (unparse-unassigned x) - (unparse-with-brackets - (lambda () - (*unparse-string "UNASSIGNED")))) - -(define (unparse-unbound x) - (unparse-with-brackets - (lambda () - (*unparse-string "UNBOUND")))) - -(define (unparse-symbol symbol) - (*unparse-string (symbol->string symbol))) - -(define-type 'INTERNED-SYMBOL - unparse-symbol) - -(define-type 'UNINTERNED-SYMBOL - (lambda (symbol) - (unparse-with-brackets - (lambda () - (*unparse-string "UNINTERNED ") - (unparse-symbol symbol) - (*unparse-char #\Space) - (*unparse-object (object-hash symbol)))))) - -(define-type 'CHARACTER - (lambda (character) - (if *slashify* - (begin (*unparse-string "#\\") - (*unparse-string (char->name character true))) - (*unparse-char character)))) - -(define-type 'STRING - (let ((delimiters (char-set #\" #\\ #\Tab char:newline #\Page))) - (lambda (string) - (if *slashify* - (begin (*unparse-char #\") - (let ((end (string-length string))) - (define (loop start) - (let ((index (substring-find-next-char-in-set - string start end delimiters))) - (if index - (begin (*unparse-substring string start index) - (*unparse-char #\\) - (*unparse-char - (let ((char (string-ref string index))) - (cond ((char=? char #\Tab) #\t) - ((char=? char char:newline) #\n) - ((char=? char #\Page) #\f) - (else char)))) - (loop (1+ index))) - (*unparse-substring string start end)))) - (if (substring-find-next-char-in-set string 0 end - delimiters) - (loop 0) - (*unparse-string string))) - (*unparse-char #\")) - (*unparse-string string))))) - -(define-type 'VECTOR - (lambda (vector) - (define (normal) - (*unparse-char #\#) - (unparse-list (vector->list vector))) - (cond ((zero? (vector-length vector)) (*unparse-string "#()")) - ((future? vector) (normal)) - (else - (let ((entry - (assq (vector-ref vector 0) *unparser-special-objects*))) - (if entry - ((cdr entry) vector) - (normal))))))) - -(define *unparser-special-objects* '()) - -(define (add-unparser-special-object! key unparser) - (set! *unparser-special-objects* - (cons (cons key unparser) - *unparser-special-objects*)) - *the-non-printing-object*) - -(define-type 'LIST - (lambda (object) - ((cond ((future? (car object)) unparse-list) - ((unassigned-object? object) unparse-unassigned) - ((unbound-object? object) unparse-unbound) - (else - (let ((entry (assq (car object) *unparser-special-pairs*))) - (if entry - (cdr entry) - unparse-list)))) - object))) - -(define *unparser-special-pairs* '()) - -(define (add-unparser-special-pair! key unparser) - (set! *unparser-special-pairs* - (cons (cons key unparser) - *unparser-special-pairs*)) - *the-non-printing-object*) - -(add-unparser-special-pair! 'QUOTE - (lambda (pair) - (if (and (pair? (cdr pair)) - (null? (cddr pair))) - (begin (*unparse-char #\') - (*unparse-object-or-future (cadr pair))) - (unparse-list pair)))) - -(define (unparse-list list) - (if *unparser-list-depth-limit* - (fluid-let ((*unparser-list-depth* (1+ *unparser-list-depth*))) - (if (> *unparser-list-depth* *unparser-list-depth-limit*) - (*unparse-string "...") - (begin (*unparse-char #\() - (*unparse-object-or-future (car list)) - (unparse-tail (cdr list) 2) - (*unparse-char #\))))) - (begin (*unparse-char #\() - (*unparse-object-or-future (car list)) - (unparse-tail (cdr list) 2) - (*unparse-char #\))))) - -(define (unparse-tail l n) - (cond ((pair? l) - (*unparse-char #\Space) - (*unparse-object-or-future (car l)) - (if (and *unparser-list-breadth-limit* - (>= n *unparser-list-breadth-limit*) - (not (null? (cdr l)))) - (*unparse-string " ...") - (unparse-tail (cdr l) (1+ n)))) - ((not (null? l)) - (*unparse-string " . ") - (*unparse-object-or-future l)))) - -;;;; Procedures and Environments - -(define (unparse-compound-procedure procedure) - (unparse-with-brackets - (lambda () - (*unparse-string "COMPOUND-PROCEDURE ") - (lambda-components* (procedure-lambda procedure) - (lambda (name required optional rest body) - (if (eq? name lambda-tag:unnamed) - (unparse-datum procedure) - (*unparse-object name))))))) - -(define-type 'PROCEDURE unparse-compound-procedure) -(define-type 'EXTENDED-PROCEDURE unparse-compound-procedure) - -(define (unparse-primitive-procedure proc) - (unparse-with-brackets - (lambda () - (*unparse-string "PRIMITIVE-PROCEDURE ") - (*unparse-object (primitive-procedure-name proc))))) - -(define-type 'PRIMITIVE unparse-primitive-procedure) -(define-type 'PRIMITIVE-EXTERNAL unparse-primitive-procedure) - -(define-type 'ENVIRONMENT - (lambda (environment) - (if (lexical-unreferenceable? environment ':PRINT-SELF) - (unparse-default environment) - ((access :print-self environment))))) - -(define-type 'VARIABLE - (lambda (variable) - (unparse-with-brackets - (lambda () - (*unparse-string "VARIABLE ") - (*unparse-object (variable-name variable)))))) - -(define (unparse-datum object) - (*unparse-string (number->string (primitive-datum object) 16))) - -(define (unparse-number object) - (*unparse-string (number->string object *unparser-radix*))) - -(define-type 'FIXNUM unparse-number) -(define-type 'BIGNUM unparse-number) -(define-type 'FLONUM unparse-number) -(define-type 'COMPLEX unparse-number) - -;;; end UNPARSER-PACKAGE. -)) - -)) \ No newline at end of file diff --git a/v7/src/runtime/unsyn.scm b/v7/src/runtime/unsyn.scm deleted file mode 100644 index 4c83c01a6..000000000 --- a/v7/src/runtime/unsyn.scm +++ /dev/null @@ -1,485 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 13.42 1987/03/17 18:54:23 cph Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; UNSYNTAX: SCODE -> S-Expressions - -(declare (usual-integrations)) - -(define unsyntax) -(define unsyntax-lambda-list) -(define make-unsyntax-table) -(define unsyntax-table?) -(define current-unsyntax-table) -(define set-current-unsyntax-table!) -(define with-unsyntax-table) - -(define unsyntaxer-package - (make-environment - -(set! unsyntax -(named-lambda (unsyntax scode #!optional unsyntax-table) - (let ((object (if (compound-procedure? scode) - (procedure-lambda scode) - scode))) - (if (unassigned? unsyntax-table) - (unsyntax-object object) - (with-unsyntax-table unsyntax-table - (lambda () - (unsyntax-object object))))))) - -(define (unsyntax-object object) - ((unsyntax-dispatcher object) object)) - -(define (unsyntax-objects objects) - (if (null? objects) - '() - (cons (unsyntax-object (car objects)) - (unsyntax-objects (cdr objects))))) - -;;;; Unsyntax Quanta - -(define (unsyntax-QUOTATION quotation) - `(SCODE-QUOTE ,(unsyntax-object (quotation-expression quotation)))) - -(define (unsyntax-constant object) - `(QUOTE ,object)) - -(define (unsyntax-VARIABLE-object object) - (variable-name object)) - -(define (unsyntax-ACCESS-object object) - `(ACCESS ,@(unexpand-access object))) - -(define (unexpand-access object) - (if (access? object) - (access-components object - (lambda (environment name) - `(,name ,@(unexpand-access environment)))) - `(,(unsyntax-object object)))) - -(define (unsyntax-UNBOUND?-object unbound?) - `(UNBOUND? ,(unbound?-name unbound?))) - -(define (unsyntax-UNASSIGNED?-object unassigned?) - `(UNASSIGNED? ,(unassigned?-name unassigned?))) - -(define (unsyntax-DEFINITION-object definition) - (definition-components definition unexpand-definition)) - -(define (unsyntax-ASSIGNMENT-object assignment) - (assignment-components assignment - (lambda (name value) - `(SET! ,name ,(unsyntax-object value))))) - -(define ((definition-unexpander key lambda-key) name value) - (if (lambda? value) - (lambda-components** value - (lambda (lambda-name required optional rest body) - (if (eq? lambda-name name) - `(,lambda-key (,name . ,(lambda-list required optional rest)) - ,@(unsyntax-sequence body)) - `(,key ,name ,@(unexpand-binding-value value))))) - `(,key ,name ,@(unexpand-binding-value value)))) - -(define (unexpand-binding-value value) - (if (unassigned-object? value) - '() - `(,(unsyntax-object value)))) - -(define unexpand-definition - (definition-unexpander 'DEFINE 'DEFINE)) - -(define (unsyntax-COMMENT-object comment) - (comment-components comment - (lambda (text expression) - `(COMMENT ,text ,(unsyntax-object expression))))) -(define (unsyntax-DECLARATION-object declaration) - (declaration-components declaration - (lambda (text expression) - `(LOCAL-DECLARE ,text ,(unsyntax-object expression))))) - -(define (unsyntax-SEQUENCE-object sequence) - `(BEGIN ,@(unsyntax-sequence sequence))) - -(define (unsyntax-sequence sequence) - (unsyntax-objects (sequence-actions sequence))) - -(define (unsyntax-OPEN-BLOCK-object open-block) - (open-block-components open-block - (lambda (auxiliary declarations expression) - `(OPEN-BLOCK ,auxiliary - ,declarations - ,@(unsyntax-sequence expression))))) - -(define (unsyntax-DELAY-object object) - `(DELAY ,(unsyntax-object (delay-expression object)))) - -(define (unsyntax-IN-PACKAGE-object in-package) - (in-package-components in-package - (lambda (environment expression) - `(IN-PACKAGE ,(unsyntax-object environment) - ,@(unsyntax-sequence expression))))) - -(define (unsyntax-THE-ENVIRONMENT-object object) - `(THE-ENVIRONMENT)) - -(define (unsyntax-CONDITIONAL-object conditional) - (conditional-components conditional unsyntax-conditional)) - -(define (unsyntax-conditional predicate consequent alternative) - (cond ((false? alternative) - (if (conditional? consequent) - `(AND ,@(unexpand-conjunction predicate consequent)) - `(IF ,(unsyntax-object predicate) - ,(unsyntax-object consequent)))) - ((conditional? alternative) - `(COND ,@(unsyntax-cond-conditional predicate - consequent - alternative))) - (else - `(IF ,(unsyntax-object predicate) - ,(unsyntax-object consequent) - ,(unsyntax-object alternative))))) - -(define (unsyntax-cond-conditional predicate consequent alternative) - `((,(unsyntax-object predicate) ,@(unsyntax-sequence consequent)) - ,@(unsyntax-cond-alternative alternative))) - -(define (unsyntax-cond-disjunction predicate alternative) - `((,(unsyntax-object predicate)) - ,@(unsyntax-cond-alternative alternative))) - -(define (unsyntax-cond-alternative alternative) - (cond ((false? alternative) '()) - ((disjunction? alternative) - (disjunction-components alternative unsyntax-cond-disjunction)) - ((conditional? alternative) - (conditional-components alternative unsyntax-cond-conditional)) - (else `((ELSE ,@(unsyntax-sequence alternative)))))) - -(define (unexpand-conjunction predicate consequent) - (if (conditional? consequent) - `(,(unsyntax-object predicate) - ,@(conditional-components consequent - (lambda (predicate consequent alternative) - (if (false? alternative) - (unexpand-conjunction predicate consequent) - `(,(unsyntax-conditional predicate - consequent - alternative)))))) - `(,(unsyntax-object predicate) ,(unsyntax-object consequent)))) - -(define (unsyntax-DISJUNCTION-object object) - `(OR ,@(disjunction-components object unexpand-disjunction))) - -(define (unexpand-disjunction predicate alternative) - `(,(unsyntax-object predicate) - ,@(if (disjunction? alternative) - (disjunction-components alternative unexpand-disjunction) - `(,(unsyntax-object alternative))))) - -;;;; Lambdas - -(define (unsyntax-LAMBDA-object lambda) - (lambda-components** lambda - (lambda (name required optional rest body) - (let ((bvl (lambda-list required optional rest)) - (body (unsyntax-sequence body))) - (if (eq? name lambda-tag:unnamed) - `(LAMBDA ,bvl ,@body) - `(NAMED-LAMBDA (,name . ,bvl) ,@body)))))) - -(set! unsyntax-lambda-list -(named-lambda (unsyntax-lambda-list lambda) - (if (not (lambda? lambda)) - (error "Must be a lambda expression" lambda)) - (lambda-components** lambda - (lambda (name required optional rest body) - (lambda-list required optional rest))))) - -(define (lambda-list required optional rest) - (cond ((null? rest) - (if (null? optional) - required - `(,@required ,(access lambda-optional-tag lambda-package) - ,@optional))) - ((null? optional) - `(,@required . ,rest)) - (else - `(,@required ,(access lambda-optional-tag lambda-package) - ,@optional . ,rest)))) - -(define (lambda-components** lambda receiver) - (lambda-components lambda - (lambda (name required optional rest auxiliary declarations body) - (receiver name required optional rest - (unscan-defines auxiliary declarations body))))) - -;;;; Combinations - -(define (unsyntax-COMBINATION-object combination) - (combination-components combination - (lambda (operator operands) - (cond ((and (or (eq? operator cons) - (and (variable? operator) - (eq? (variable-name operator) 'CONS))) - (= (length operands) 2) - (delay? (cadr operands))) - `(CONS-STREAM ,(unsyntax-object (car operands)) - ,(unsyntax-object - (delay-expression (cadr operands))))) - ((eq? operator error-procedure) - (unsyntax-error-like-form operands 'ERROR)) - ((variable? operator) - (let ((name (variable-name operator))) - (cond ((eq? name 'ERROR-PROCEDURE) - (unsyntax-error-like-form operands 'ERROR)) - ((eq? name 'BREAKPOINT-PROCEDURE) - (unsyntax-error-like-form operands 'BKPT)) - (else - (cons (unsyntax-object operator) - (unsyntax-objects operands)))))) - ((lambda? operator) - (lambda-components** operator - (lambda (name required optional rest body) - (if (and (null? optional) - (null? rest)) - (cond ((or (eq? name lambda-tag:unnamed) - (eq? name lambda-tag:let)) - `(LET ,(unsyntax-let-bindings required operands) - ,@(unsyntax-sequence body))) - ((eq? name lambda-tag:deep-fluid-let) - (unsyntax-deep-fluid-let required operands body)) - ((eq? name lambda-tag:shallow-fluid-let) - (unsyntax-shallow-fluid-let required operands - body)) - ((eq? name lambda-tag:common-lisp-fluid-let) - (unsyntax-common-lisp-fluid-let required operands - body)) - ((eq? name lambda-tag:make-environment) - (unsyntax-make-environment required operands body)) - (else - `(LET ,name - ,(unsyntax-let-bindings required operands) - ,@(unsyntax-sequence body)))) - (cons (unsyntax-object operator) - (unsyntax-objects operands)))))) - (else - (cons (unsyntax-object operator) - (unsyntax-objects operands))))))) - -(define (unsyntax-error-like-form operands name) - (cons* name - (unsyntax-object (first operands)) - (let ((operand (second operands))) - (cond ((and (access? operand) - (null? (access-environment operand)) - (eq? (access-name operand) '*THE-NON-PRINTING-OBJECT*)) - '()) - ((combination? operand) - (combination-components operand - (lambda (operator operands) - (if (and (access? operator) - (access-components operator - (lambda (environment name) - (and (eq? name 'LIST) - (null? environment))))) - (unsyntax-objects operands) - `(,(unsyntax-object operand)))))) - (else `(,(unsyntax-object operand))))))) - -(define (unsyntax-shallow-FLUID-LET names values body) - (combination-components body - (lambda (operator operands) - `(FLUID-LET ,(unsyntax-let-bindings - (map extract-transfer-var - (lambda-components** (car operands) - (lambda (name req opt rest body) - (sequence-actions body)))) - (every-other values)) - ,@(lambda-components** (cadr operands) - (lambda (name required optional rest body) - (unsyntax-sequence body))))))) - -(define (every-other list) - (if (null? list) - '() - (cons (car list) (every-other (cddr list))))) - -(define (extract-transfer-var assignment) - (assignment-components assignment - (lambda (name value) - (cond ((assignment? value) - (assignment-components value (lambda (name value) name))) - ((combination? value) - (combination-components value - (lambda (operator operands) - (cond ((eq? operator lexical-assignment) - `(ACCESS ,(cadr operands) - ,@(unexpand-access (car operands)))) - (else - (error "Unknown SCODE form" 'FLUID-LET - assignment)))))) - (else - (error "Unknown SCODE form" 'FLUID-LET assignment)))))) - -(define ((unsyntax-deep-or-common-FLUID-LET name prim) - ignored-required ignored-operands body) - (define (sequence->list seq) - (if (sequence? seq) - (sequence-actions seq) - (list seq))) - (define (unsyntax-fluid-bindings l) - (define (unsyntax-fluid-assignment combi) - (let ((operands (combination-operands combi))) - (let ((env (first operands)) - (name (second operands)) - (val (third operands))) - (cond ((symbol? name) - `((ACCESS ,name ,(unsyntax-object env)) - ,(unsyntax-object val))) - ((quotation? name) - (let ((var (quotation-expression name))) - (if (variable? var) - `(,(variable-name var) ,(unsyntax-object val)) - (error "FLUID-LET unsyntax: unexpected name" name)))) - (else - (error "FLUID-LET unsyntax: unexpected name" name)))))) - (let ((first (car l))) - (if (and (combination? first) - (eq? (combination-operator first) prim)) - (let ((remainder (unsyntax-fluid-bindings (cdr l)))) - (cons - (cons (unsyntax-fluid-assignment first) (car remainder)) - (cdr remainder))) - (cons '() (unsyntax-objects l))))) - - (let* ((thunk (car (combination-operands body))) - (real-body (lambda-body thunk)) - (seq-list (sequence->list real-body)) - (fluid-binding-list (unsyntax-fluid-bindings seq-list))) - `(,name ,(car fluid-binding-list) ,@(cdr fluid-binding-list)))) - -(define unsyntax-deep-FLUID-LET - (unsyntax-deep-or-common-FLUID-LET - 'FLUID-LET (make-primitive-procedure 'add-fluid-binding! true))) - -(define unsyntax-common-lisp-FLUID-LET - (unsyntax-deep-or-common-FLUID-LET - 'FLUID-BIND (make-primitive-procedure 'make-fluid-binding! true))) - -(define (unsyntax-MAKE-ENVIRONMENT names values body) - `(MAKE-ENVIRONMENT ,@(except-last-pair (unsyntax-sequence body)))) - -(define (unsyntax-let-bindings names values) - (map unsyntax-let-binding names values)) - -(define (unsyntax-let-binding name value) - `(,name ,@(unexpand-binding-value value))) - -;;;; Unsyntax Tables - -(define unsyntax-table-tag - '(UNSYNTAX-TABLE)) - -(set! make-unsyntax-table -(named-lambda (make-unsyntax-table alist) - (cons unsyntax-table-tag - (make-type-dispatcher alist identity-procedure)))) - -(set! unsyntax-table? -(named-lambda (unsyntax-table? object) - (and (pair? object) - (eq? (car object) unsyntax-table-tag)))) - -(set! current-unsyntax-table -(named-lambda (current-unsyntax-table) - *unsyntax-table)) - -(set! set-current-unsyntax-table! -(named-lambda (set-current-unsyntax-table! table) - (if (not (unsyntax-table? table)) - (error "Not an unsyntax table" 'SET-CURRENT-UNSYNTAX-TABLE! table)) - (set-table! table))) - -(set! with-unsyntax-table -(named-lambda (with-unsyntax-table table thunk) - (define old-table) - (if (not (unsyntax-table? table)) - (error "Not an unsyntax table" 'WITH-UNSYNTAX-TABLE table)) - (dynamic-wind (lambda () - (set! old-table (set-table! table))) - thunk - (lambda () - (set! table (set-table! old-table)))))) - -(define unsyntax-dispatcher) -(define *unsyntax-table) - -(define (set-table! table) - (set! unsyntax-dispatcher (cdr table)) - (set! *unsyntax-table table)) - -;;;; Default Unsyntax Table - -(set-table! - (make-unsyntax-table - `((,(microcode-type-object 'LIST) ,unsyntax-constant) - (,symbol-type ,unsyntax-constant) - (,variable-type ,unsyntax-VARIABLE-object) - (,unbound?-type ,unsyntax-UNBOUND?-object) - (,unassigned?-type ,unsyntax-UNASSIGNED?-object) - (,combination-type ,unsyntax-COMBINATION-object) - (,quotation-type ,unsyntax-QUOTATION) - (,access-type ,unsyntax-ACCESS-object) - (,definition-type ,unsyntax-DEFINITION-object) - (,assignment-type ,unsyntax-ASSIGNMENT-object) - (,conditional-type ,unsyntax-CONDITIONAL-object) - (,disjunction-type ,unsyntax-DISJUNCTION-object) - (,comment-type ,unsyntax-COMMENT-object) - (,declaration-type ,unsyntax-DECLARATION-object) - (,sequence-type ,unsyntax-SEQUENCE-object) - (,open-block-type ,unsyntax-OPEN-BLOCK-object) - (,delay-type ,unsyntax-DELAY-object) - (,in-package-type ,unsyntax-IN-PACKAGE-object) - (,the-environment-type ,unsyntax-THE-ENVIRONMENT-object) - (,lambda-type ,unsyntax-LAMBDA-object)))) - -;;; end UNSYNTAXER-PACKAGE -)) \ No newline at end of file diff --git a/v7/src/runtime/unxpth.scm b/v7/src/runtime/unxpth.scm deleted file mode 100644 index baaf66601..000000000 --- a/v7/src/runtime/unxpth.scm +++ /dev/null @@ -1,314 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxpth.scm,v 1.2 1987/03/17 18:54:38 cph Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Unix pathname parsing and unparsing. - -(declare (usual-integrations)) - -;;; A note about parsing of filename strings: the standard syntax for -;;; a filename string is "..". Since the Unix -;;; file system treats "." just like any other character, it is -;;; possible to give files strange names like "foo.bar.baz.mum". In -;;; this case, the resulting name would be "foo.bar.baz", and the -;;; resulting type would be "mum". In general, degenerate filenames -;;; (including names with non-numeric versions) are parsed such that -;;; the characters following the final "." become the type, while the -;;; characters preceding the final "." become the name. - -;;;; Parse - -(define (symbol->pathname symbol) - (string->pathname (string-downcase (symbol->string symbol)))) - -(define string->pathname) -(define home-directory-pathname) -(let () - -(set! string->pathname - (named-lambda (string->pathname string) - (parse-pathname string make-pathname))) - -(define (parse-pathname string receiver) - (let ((components (divide-into-components (string-trim string)))) - (if (null? components) - (receiver #F #F #F #F #F) - (let ((components - (append (expand-directory-prefixes (car components)) - (cdr components)))) - (parse-name (car (last-pair components)) - (lambda (name type version) - (receiver #F - (map (lambda (component) - (if (string=? "*" component) - 'WILD - component)) - (except-last-pair components)) - name type version))))))) - -(define (divide-into-components string) - (let ((end (string-length string))) - (define (loop start) - (let ((index (substring-find-next-char string start end #\/))) - (if index - (cons (substring string start index) - (loop (1+ index))) - (list (substring string start end))))) - (loop 0))) - -(define (expand-directory-prefixes string) - (if (string-null? string) - (list string) - (case (string-ref string 0) - ((#\$) - (divide-into-components - (get-environment-variable - (substring string 1 (string-length string))))) - ((#\~) - (let ((user-name (substring string 1 (string-length string)))) - (divide-into-components - (if (string-null? user-name) - (get-environment-variable "HOME") - (get-user-home-directory user-name))))) - (else (list string))))) - -(set! home-directory-pathname - (lambda () - (make-pathname #F - (divide-into-components (get-environment-variable "HOME")) - #F - #F - #F))) - -(define get-environment-variable - (let ((primitive (make-primitive-procedure 'GET-ENVIRONMENT-VARIABLE))) - (lambda (name) - (or (primitive name) - (error "GET-ENVIRONMENT-VARIABLE: Unbound name" name))))) - -(define get-user-home-directory - (let ((primitive (make-primitive-procedure 'GET-USER-HOME-DIRECTORY))) - (lambda (user-name) - (or (primitive user-name) - (error "User has no home directory" user-name))))) - -(define (digits->number digits weight accumulator) - (if (null? digits) - accumulator - (let ((value (char->digit (car digits) 10))) - (and value - (digits->number (cdr digits) - (* weight 10) - (+ (* weight value) accumulator)))))) - -(define (parse-name string receiver) - (let ((start 0) - (end (string-length string))) - (define (find-next-dot start) - (substring-find-next-char string start end #\.)) - - (define (find-previous-dot start) - (substring-find-previous-char string start end #\.)) - - (define (parse-version start) - (cond ((= start end) 'UNSPECIFIC) - ((substring=? string start end "*" 0 1) 'WILD) - ((substring-find-next-char string start end #\*) - (substring string start end)) - (else - (let ((n (digits->number (reverse! (substring->list string start - end)) - 1 0))) - (if (and n (>= n 0)) - (if (= n 0) 'NEWEST n) - (substring string start end)))))) - - (if (= start end) - (receiver #F #F #F) - (let ((index (find-next-dot start))) - (if index - (let ((start* (1+ index)) - (name (wildify string start index))) - (if (= start* end) - (receiver name 'UNSPECIFIC 'UNSPECIFIC) - (or (let ((index (find-next-dot start*))) - (and index - (let ((version (parse-version (1+ index)))) - (and (not (string? version)) - (receiver name - (wildify string start* index) - version))))) - (let ((index (find-previous-dot start))) - (receiver (wildify string start index) - (wildify string (1+ index) end) - #F))))) - (receiver (wildify string start end) #F #F)))))) - -(define (wildify string start end) - (if (substring=? string start end "*" 0 1) - 'WILD - (substring string start end))) - -;;; end LET. -) - -;;;; Unparse - -(define pathname-unparse) -(define pathname-unparse-name) -(let () - -(set! pathname-unparse - (named-lambda (pathname-unparse device directory name type version) - (unparse-device - device - (unparse-directory directory - (pathname-unparse-name name type version))))) - -(define (unparse-device device rest) - (let ((device-string (unparse-component device))) - (if device-string - (string-append device-string ":" rest) - rest))) - -(define (unparse-directory directory rest) - (cond ((null? directory) rest) - ((pair? directory) - (let loop ((directory directory)) - (let ((directory-string (unparse-component (car directory))) - (rest (if (null? (cdr directory)) - rest - (loop (cdr directory))))) - (if directory-string - (string-append directory-string "/" rest) - rest)))) - (else - (error "Unrecognizable directory" directory)))) - -(set! pathname-unparse-name - (named-lambda (pathname-unparse-name name type version) - (let ((name-string (unparse-component name)) - (type-string (unparse-component type)) - (version-string (unparse-version version))) - (cond ((not name-string) "") - ((not type-string) name-string) - ((eq? type-string 'UNSPECIFIC) (string-append name-string ".")) - ((not version-string) (string-append name-string "." type-string)) - ((eq? version-string 'UNSPECIFIC) - (string-append name-string "." type-string ".")) - (else - (string-append name-string "." type-string "." - version-string)))))) - -(define (unparse-version version) - (if (eq? version 'NEWEST) - "0" - (unparse-component version))) - -(define (unparse-component component) - (cond ((not component) #F) - ((eq? component 'UNSPECIFIC) component) - ((eq? component 'WILD) "*") - ((string? component) component) - ((and (integer? component) (> component 0)) - (list->string (number->digits component '()))) - (else (error "Unknown component" component)))) - -(define (number->digits number accumulator) - (if (zero? number) - accumulator - (let ((qr (integer-divide number 10))) - (number->digits (integer-divide-quotient qr) - (cons (digit->char (integer-divide-remainder qr)) - accumulator))))) - -;;; end LET. -) - -;;;; Utility for merge pathnames - -(define (simplify-directory directory) - (cond ((null? directory) directory) - ((string=? (car directory) ".") - (simplify-directory (cdr directory))) - ((null? (cdr directory)) directory) - ((string=? (cadr directory) "..") - (simplify-directory (cddr directory))) - (else - (cons (car directory) - (simplify-directory (cdr directory)))))) - -;;;; Working Directory - -(define working-directory-pathname) -(define set-working-directory-pathname!) - -(define working-directory-package - (make-environment - -(define primitive - (make-primitive-procedure 'WORKING-DIRECTORY-PATHNAME)) - -(define pathname) - -(define (reset!) - (set! pathname - (string->pathname - (let ((string (primitive))) - (let ((length (string-length string))) - (if (or (zero? length) - (not (char=? #\/ (string-ref string (-1+ length))))) - (string-append string "/") - string)))))) - -(set! working-directory-pathname - (named-lambda (working-directory-pathname) - pathname)) - -(set! set-working-directory-pathname! - (named-lambda (set-working-directory-pathname! name) - (set! pathname - (pathname-as-directory - (pathname->absolute-pathname (->pathname name)))) - pathname)) - -;;; end WORKING-DIRECTORY-PACKAGE -)) - -(define init-file-pathname - (make-pathname #F #F ".scheme" "init" #F)) \ No newline at end of file diff --git a/v7/src/runtime/utabs.scm b/v7/src/runtime/utabs.scm deleted file mode 100644 index 3a1c0a965..000000000 --- a/v7/src/runtime/utabs.scm +++ /dev/null @@ -1,349 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/utabs.scm,v 13.45 1987/04/15 05:07:31 cph Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Microcode Table Interface - -(declare (usual-integrations)) - -(define fixed-objects-vector-slot) - -(define number-of-microcode-types) -(define microcode-type-name) -(define microcode-type) -(define microcode-type-predicate) -(define object-type) - -(define number-of-microcode-returns) -(define microcode-return) -(define make-return-address) -(define return-address?) -(define return-address-code) -(define return-address-name) - -(define number-of-microcode-errors) -(define microcode-error) - -(define number-of-microcode-terminations) -(define microcode-termination) -(define microcode-termination-name) - -(define make-primitive-procedure) -(define primitive-procedure?) -(define primitive-procedure-name) -(define implemented-primitive-procedure?) - -(define microcode-identification-item) - -(define future?) - -(define microcode-system - (make-environment - -(define :name "Microcode") -(define :version) -(define :modification) -(define :identification) -(define :release) - -(let-syntax ((define-primitive - (macro (name) - `(DEFINE ,name ,(make-primitive-procedure name))))) - (define-primitive binary-fasload) - (define-primitive microcode-identify) - (define-primitive microcode-tables-filename) - (define-primitive map-machine-address-to-code) - (define-primitive map-code-to-machine-address) - (define-primitive get-external-counts) - (define-primitive get-external-number) - (define-primitive get-external-name)) - -;;;; Fixed Objects Vector - -(set! fixed-objects-vector-slot -(named-lambda (fixed-objects-vector-slot name) - (or (microcode-table-search 15 name) - (error "FIXED-OBJECTS-VECTOR-SLOT: Unknown name" name)))) - -(define fixed-objects) - -(define (microcode-table-search slot name) - (let ((vector (vector-ref fixed-objects slot))) - (let ((end (vector-length vector))) - (define (loop i) - (and (not (= i end)) - (let ((entry (vector-ref vector i))) - (if (if (pair? entry) - (memq name entry) - (eq? name entry)) - i - (loop (1+ i)))))) - (loop 0)))) - -(define (microcode-table-ref slot index) - (let ((vector (vector-ref fixed-objects slot))) - (and (< index (vector-length vector)) - (let ((entry (vector-ref vector index))) - (if (pair? entry) - (car entry) - entry))))) - -;;;; Microcode Type Codes - -(define types-slot) - -(define renamed-user-object-types - '((FIXNUM . NUMBER) - (BIGNUM . NUMBER) - (FLONUM . NUMBER) - (COMPLEX . NUMBER) - (INTERNED-SYMBOL . SYMBOL) - (UNINTERNED-SYMBOL . SYMBOL) - (EXTENDED-PROCEDURE . PROCEDURE) - (COMPILED-PROCEDURE . PROCEDURE) - (PRIMITIVE . PRIMITIVE-PROCEDURE) - (PRIMITIVE-EXTERNAL . PRIMITIVE-PROCEDURE) - (LEXPR . LAMBDA) - (EXTENDED-LAMBDA . LAMBDA) - (COMBINATION-1 . COMBINATION) - (COMBINATION-2 . COMBINATION) - (PRIMITIVE-COMBINATION-0 . COMBINATION) - (PRIMITIVE-COMBINATION-1 . COMBINATION) - (PRIMITIVE-COMBINATION-2 . COMBINATION) - (PRIMITIVE-COMBINATION-3 . COMBINATION) - (SEQUENCE-2 . SEQUENCE) - (SEQUENCE-3 . SEQUENCE))) - -(set! microcode-type-name -(named-lambda (microcode-type-name type) - (microcode-table-ref types-slot type))) - -(set! microcode-type -(named-lambda (microcode-type name) - (or (microcode-table-search types-slot name) - (error "MICROCODE-TYPE: Unknown name" name)))) - -(set! microcode-type-predicate -(named-lambda (microcode-type-predicate name) - (type-predicate (microcode-type name)))) - -(define ((type-predicate type) object) - (primitive-type? type object)) - -(set! object-type -(named-lambda (object-type object) - (let ((type (microcode-type-name (primitive-type object)))) - (let ((entry (assq type renamed-user-object-types))) - (if (not (null? entry)) - (cdr entry) - type))))) - -;;;; Microcode Return Codes - -(define returns-slot) -(define return-address-type) - -(set! microcode-return -(named-lambda (microcode-return name) - (microcode-table-search returns-slot name))) - -(set! make-return-address -(named-lambda (make-return-address code) - (map-code-to-machine-address return-address-type code))) - -(set! return-address? -(named-lambda (return-address? object) - (primitive-type? return-address-type object))) - -(set! return-address-code -(named-lambda (return-address-code return-address) - (map-machine-address-to-code return-address-type return-address))) - -(set! return-address-name -(named-lambda (return-address-name return-address) - (microcode-table-ref returns-slot (return-address-code return-address)))) - -;;;; Microcode Error Codes - -(define errors-slot) - -(set! microcode-error -(named-lambda (microcode-error name) - (microcode-table-search errors-slot name))) - -;;;; Microcode Termination Codes - -(define termination-vector-slot) - -(set! microcode-termination -(named-lambda (microcode-termination name) - (microcode-table-search termination-vector-slot name))) - -(set! microcode-termination-name -(named-lambda (microcode-termination-name type) - (code->name termination-vector-slot type))) - -(define identification-vector-slot) - -(set! microcode-identification-item - (lambda (name) - (vector-ref :identification - (or (microcode-table-search identification-vector-slot name) - (error "Unknown identification item" name))))) - -;;;; Microcode Primitives - -(define primitives-slot) -(define primitive-type-code) -(define external-type-code) - -(set! primitive-procedure? -(named-lambda (primitive-procedure? object) - (or (primitive-type? primitive-type-code object) - (primitive-type? external-type-code object)))) - -(set! make-primitive-procedure -(named-lambda (make-primitive-procedure name #!optional force?) - (let ((code (name->code primitives-slot 'PRIMITIVE name))) - (if code - (map-code-to-machine-address primitive-type-code code) - (or (get-external-number name (if (unassigned? force?) #f force?)) - (error "MAKE-PRIMITIVE-PROCEDURE: Unknown name" name)))))) - -(set! implemented-primitive-procedure? -(named-lambda (implemented-primitive-procedure? object) - (cond ((primitive-type? primitive-type-code object) true) - ((primitive-type? external-type-code object) - (get-external-number (external-code->name (primitive-datum object)) - false)) - (else - (error "Not a primitive procedure" implemented-primitive-procedure? - object))))) - -(set! primitive-procedure-name -(named-lambda (primitive-procedure-name primitive-procedure) - (cond ((primitive-type? primitive-type-code primitive-procedure) - (code->name primitives-slot - 'PRIMITIVE - (map-machine-address-to-code primitive-type-code - primitive-procedure))) - ((primitive-type? external-type-code primitive-procedure) - (external-code->name (primitive-datum primitive-procedure))) - (else - (error "Not a primitive procedure" primitive-procedure-name - primitive-procedure))))) - -(define (name->code slot type name) - (or (and (pair? name) - (eq? (car name) type) - (pair? (cdr name)) - (let ((x (cdr name))) - (and (integer? (car x)) - (not (negative? (car x))) - (null? (cdr x)) - (car x)))) - (microcode-table-search slot name))) - -(define (code->name slot type code) - (or (and (not (negative? code)) - (microcode-table-ref slot code)) - (list type code))) - -(define (external-code->name code) - (let ((current-counts (get-external-counts))) - (cond ((< code (car current-counts)) (get-external-name code)) - ((< code (+ (car current-counts) (cdr current-counts))) - (get-external-name code)) ;Maybe should warn about undefined - (else - (error "Not an external procedure name" external-code->name - code))))) - -;;;; Initialization - -(define microcode-tables-identification) - -(define (snarf-version) - (set! :identification (microcode-identify)) - - (set! microcode-tables-identification - (scode-eval (binary-fasload (microcode-tables-filename)) - system-global-environment)) - - (set! fixed-objects (get-fixed-objects-vector)) - - (set! types-slot (fixed-objects-vector-slot 'MICROCODE-TYPES-VECTOR)) - (set! number-of-microcode-types - (vector-length (vector-ref fixed-objects types-slot))) - - (set! returns-slot (fixed-objects-vector-slot 'MICROCODE-RETURNS-VECTOR)) - (set! return-address-type (microcode-type 'RETURN-ADDRESS)) - (set! number-of-microcode-returns - (vector-length (vector-ref fixed-objects returns-slot))) - - (set! errors-slot (fixed-objects-vector-slot 'MICROCODE-ERRORS-VECTOR)) - (set! number-of-microcode-errors - (vector-length (vector-ref fixed-objects errors-slot))) - - (set! primitives-slot - (fixed-objects-vector-slot 'MICROCODE-PRIMITIVES-VECTOR)) - (set! primitive-type-code (microcode-type 'PRIMITIVE)) - - (set! external-type-code (microcode-type 'PRIMITIVE-EXTERNAL)) - - (set! termination-vector-slot - (fixed-objects-vector-slot 'MICROCODE-TERMINATIONS-VECTOR)) - (set! number-of-microcode-terminations - (vector-length (vector-ref fixed-objects termination-vector-slot))) - - (set! identification-vector-slot - (fixed-objects-vector-slot 'MICROCODE-IDENTIFICATION-VECTOR)) - (set! :release (microcode-identification-item 'SYSTEM-RELEASE-STRING)) - (set! :version (microcode-identification-item 'MICROCODE-VERSION)) - (set! :modification (microcode-identification-item 'MICROCODE-MODIFICATION)) - - ;; Predicate to test if object is a future without touching it. - (set! future? - (let ((primitive (make-primitive-procedure 'FUTURE? true))) - (if (implemented-primitive-procedure? primitive) - primitive - (lambda (object) false))))) - -(snarf-version) - -;;; end MICROCODE-SYSTEM. -)) \ No newline at end of file diff --git a/v7/src/runtime/vector.scm b/v7/src/runtime/vector.scm deleted file mode 100644 index e69bffd72..000000000 --- a/v7/src/runtime/vector.scm +++ /dev/null @@ -1,165 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/vector.scm,v 13.42 1987/03/17 18:55:01 cph Exp $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Operations on Vectors - -(declare (usual-integrations)) - -;;; Standard Procedures - -(in-package system-global-environment -(let-syntax () - (define-macro (define-primitives . names) - `(BEGIN ,@(map (lambda (name) - `(DEFINE ,name ,(make-primitive-procedure name))) - names))) - (define-primitives - vector-length vector-ref vector-set! - list->vector vector-cons subvector->list))) - -(let-syntax () - (define-macro (define-type-predicate name type-name) - `(DEFINE (,name OBJECT) - (PRIMITIVE-TYPE? ,(microcode-type type-name) OBJECT))) - (define-type-predicate vector? vector)) - -(define (make-vector size #!optional fill) - (if (unassigned? fill) (set! fill false)) - (vector-cons size fill)) - -(define (vector . elements) - (list->vector elements)) - -(define (vector->list vector) - (subvector->list vector 0 (vector-length vector))) - -(define (vector-fill! vector value) - (subvector-fill! vector 0 (vector-length vector) value)) - -;;; Nonstandard Primitives - -(let-syntax ((check-type - (let ((type (microcode-type 'VECTOR))) - (macro (object) - `(IF (NOT (PRIMITIVE-TYPE? ,type ,object)) - (ERROR "Wrong type argument" ,object))))) - (check-target - (macro (object index) - `(BEGIN (CHECK-TYPE ,object) - (IF (NOT (AND (NOT (NEGATIVE? ,index)) - (<= ,index (VECTOR-LENGTH ,object)))) - (ERROR "Index out of range" ,index))))) - (check-subvector - (macro (object start end) - `(BEGIN (CHECK-TYPE ,object) - (IF (NOT (AND (NOT (NEGATIVE? ,start)) - (<= ,start ,end) - (<= ,end (VECTOR-LENGTH ,object)))) - (ERROR "Indices out of range" ,start ,end)))))) - -(define (subvector-move-right! vector1 start1 end1 vector2 start2) - (define (loop index1 index2) - (if (<= start1 index1) - (begin (vector-set! vector2 index2 (vector-ref vector1 index1)) - (loop (-1+ index1) (-1+ index2))))) - (check-subvector vector1 start1 end1) - (check-target vector2 start2) - (loop (-1+ end1) (-1+ (+ start2 (- end1 start1))))) - -(define (subvector-move-left! vector1 start1 end1 vector2 start2) - (define (loop index1 index2) - (if (< index1 end1) - (begin (vector-set! vector2 index2 (vector-ref vector1 index1)) - (loop (1+ index1) (1+ index2))))) - (check-subvector vector1 start1 end1) - (check-target vector2 start2) - (loop start1 start2)) - -(define (subvector-fill! vector start end value) - (define (loop index) - (if (< index end) - (begin (vector-set! vector index value) - (loop (1+ index))))) - (check-subvector vector start end) - (loop start)) - -) - -;;; Nonstandard Procedures - -(define (vector-copy vector) - (let ((length (vector-length vector))) - (let ((new-vector (make-vector length))) - (subvector-move-right! vector 0 length new-vector 0) - new-vector))) - -(define (make-initialized-vector length initialization) - (let ((vector (make-vector length))) - (define (loop n) - (if (= n length) - vector - (begin (vector-set! vector n (initialization n)) - (loop (1+ n))))) - (loop 0))) - -(define (vector-map vector procedure) - (let ((length (vector-length vector))) - (if (zero? length) - vector - (let ((result (make-vector length))) - (define (loop i) - (vector-set! result i (procedure (vector-ref vector i))) - (if (zero? i) - result - (loop (-1+ i)))) - (loop (-1+ length)))))) - -(define (vector-grow vector length) - (let ((new-vector (make-vector length))) - (subvector-move-right! vector 0 (vector-length vector) new-vector 0) - new-vector)) - -(define (vector-first vector) (vector-ref vector 0)) -(define (vector-second vector) (vector-ref vector 1)) -(define (vector-third vector) (vector-ref vector 2)) -(define (vector-fourth vector) (vector-ref vector 3)) -(define (vector-fifth vector) (vector-ref vector 4)) -(define (vector-sixth vector) (vector-ref vector 5)) -(define (vector-seventh vector) (vector-ref vector 6)) -(define (vector-eighth vector) (vector-ref vector 7)) \ No newline at end of file diff --git a/v7/src/runtime/where.scm b/v7/src/runtime/where.scm deleted file mode 100644 index 6a260a672..000000000 --- a/v7/src/runtime/where.scm +++ /dev/null @@ -1,258 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 13.42 1987/03/17 18:55:18 cph Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Environment Inspector - -(in-package debugger-package - -(declare (usual-integrations)) - -(define env-package - (let ((env) - (current-frame) - (current-frame-depth) - (env-commands (make-command-set 'WHERE-COMMANDS))) - -(define (define-where-command letter function help-text) - (define-letter-command env-commands letter function help-text)) - -;;; Basic Commands - -(define-where-command #\? (standard-help-command env-commands) - "Help, list command letters") - -(define-where-command #\Q standard-exit-command - "Quit (exit from Where)") - -;;; Lexpr since it can take one or no arguments - -(define (where #!optional env-spec) - (if (unassigned? env-spec) (set! env-spec (rep-environment))) - (let ((environment - (cond ((or (eq? env-spec system-global-environment) - (environment? env-spec)) - env-spec) - ((compound-procedure? env-spec) - (procedure-environment env-spec)) - ((delayed? env-spec) - (if (delayed-evaluation-forced? env-spec) - (error "Not a valid environment, already forced" - (list where env-spec)) - (delayed-evaluation-environment env-spec))) - (else - (error "Not a legal environment object" 'WHERE - env-spec))))) - (environment-warning-hook environment) - (fluid-let ((env environment) - (current-frame environment) - (current-frame-depth 0)) - (letter-commands env-commands - (standard-rep-message "Environment Inspector") - (standard-rep-prompt "Where-->"))))) - -;;;; Display Commands - -(define (show) - (show-frame current-frame current-frame-depth)) - -(define (show-all) - (let s1 ((env env) - (depth 0)) - (if (eq? system-global-environment env) - *the-non-printing-object* - (begin (show-frame env depth) - (if (environment-has-parent? env) - (s1 (environment-parent env) (1+ depth)) - *the-non-printing-object*))))) - -(define (show-frame frame depth) - (if (eq? system-global-environment frame) - (begin (newline) - (write-string "This frame is the system global environment")) - (begin (newline) (write-string "Frame created by ") - (print-user-friendly-name frame) - (if (>= depth 0) - (begin (newline) - (write-string "Depth (relative to starting frame): ") - (write depth))) - (newline) - (let ((bindings (environment-bindings frame))) - (if (null? bindings) - (write-string "Has no bindings") - (begin (write-string "Has bindings:") - (newline) - (for-each print-binding bindings)))))) - (newline)) - -(define print-user-friendly-name - (let ((rename-list - `((,lambda-tag:unnamed . LAMBDA) - (,(access internal-lambda-tag lambda-package) . LAMBDA) - (,(access internal-lexpr-tag lambda-package) . LAMBDA) - (,lambda-tag:let . LET) - (,lambda-tag:shallow-fluid-let . FLUID-LET) - (,lambda-tag:deep-fluid-let . FLUID-LET) - (,lambda-tag:common-lisp-fluid-let . FLUID-BIND) - (,lambda-tag:make-environment . MAKE-ENVIRONMENT)))) - (lambda (frame) - (let ((name (environment-name frame))) - (let ((rename (assq name rename-list))) - (if rename - (begin (write-string "a ") - (write (cdr rename)) - (write-string " special form")) - (begin (write-string "the procedure ") - (write name)))))))) - -(define (print-binding binding) - (define line-width 79) - (define name-width 40) - (define (truncate str length) - (set-string-length! str (- length 4)) - (string-append str " ...")) - (newline) - (let ((s (write-to-string (car binding) name-width))) - (if (car s) ; Name was truncated - (set! s (truncate (cdr s) name-width)) - (set! s (cdr s))) - (if (null? (cdr binding)) - (set! s (string-append s " is unassigned")) - (let ((s1 (write-to-string (cadr binding) - (- line-width (string-length s))))) - (set! s (string-append s " = " (cdr s1))); - (if (car s1) ; Value truncated - (set! s (truncate s line-width))))) - (write-string s))) - -(define-where-command #\C show - "Display the bindings in the current frame") - -(define-where-command #\A show-all - "Display the bindings of all the frames in the current chain") - -;;;; Motion Commands - -(define (parent) - (cond ((eq? system-global-environment current-frame) - (newline) - (write-string -"The current frame is the system global environment, it has no parent.")) - ((environment-has-parent? current-frame) - (set! current-frame (environment-parent current-frame)) - (set! current-frame-depth (1+ current-frame-depth)) - (show)) - (else - (newline) - (write-string "The current frame has no parent.")))) - - -(define (son) - (cond ((eq? current-frame env) - (newline) - (write-string "This is the original frame. Its children cannot be found.")) - (else - (let son-1 ((prev env) - (prev-depth 0) - (next (environment-parent env))) - (if (eq? next current-frame) - (begin (set! current-frame prev) - (set! current-frame-depth prev-depth)) - (son-1 next - (1+ prev-depth) - (environment-parent next)))) - (show)))) - -(define (recursive-where) - (write-string "; Object to eval and examine-> ") - (let ((inp (read))) - (write-string "New where!") - (where (eval inp current-frame)))) - -(define-where-command #\P parent - "Find the parent frame of the current one") - -(define-where-command #\S son - "Find the son of the current environment in the current chain") - -(define-where-command #\W recursive-where - "Eval an expression in the current frame and do WHERE on it") - -;;;; Relative Evaluation Commands - -(define (show-object) - (write-string "; Object to eval and print-> ") - (let ((inp (read))) - (newline) - (write (eval inp current-frame)) - (newline))) - -(define (enter) - (read-eval-print current-frame - "You are now in the desired environment" - "Eval-in-env-->")) - -(define-where-command #\V show-object - "Eval an expression in the current frame and print the result") - -(define-where-command #\E enter - "Create a read-eval-print loop in the current environment") - -;;;; Miscellaneous Commands - -(define (name) - (newline) - (write-string "This frame was created by ") - (print-user-friendly-name current-frame)) - -(define-where-command #\N name - "Name of procedure which created current environment") - -;;; end ENV-PACKAGE. -(the-environment))) - -(define print-user-friendly-name - (access print-user-friendly-name env-package)) - -;;; end IN-PACKAGE DEBUGGER-PACKAGE. -) - -;;;; Exports - -(define where - (access where env-package debugger-package)) \ No newline at end of file diff --git a/v7/src/runtime/wind.scm b/v7/src/runtime/wind.scm deleted file mode 100644 index ab5d64ce1..000000000 --- a/v7/src/runtime/wind.scm +++ /dev/null @@ -1,99 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wind.scm,v 13.42 1987/02/15 15:46:23 cph Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; State Space Model - -(declare (usual-integrations) - (integrate-primitive-procedures set-fixed-objects-vector!)) - -(vector-set! (get-fixed-objects-vector) - (fixed-objects-vector-slot 'STATE-SPACE-TAG) - "State Space") - -(vector-set! (get-fixed-objects-vector) - (fixed-objects-vector-slot 'STATE-POINT-TAG) - "State Point") - -(set-fixed-objects-vector! (get-fixed-objects-vector)) - -(define make-state-space - (let ((prim (make-primitive-procedure 'MAKE-STATE-SPACE))) - (named-lambda (make-state-space #!optional mutable?) - (if (unassigned? mutable?) (set! mutable? #T)) - (prim mutable?)))) - -(define execute-at-new-state-point - (make-primitive-procedure 'EXECUTE-AT-NEW-STATE-POINT)) - -(define translate-to-state-point - (make-primitive-procedure 'TRANSLATE-TO-STATE-POINT)) - -;;; The following code implements the current model of DYNAMIC-WIND as -;;; a special case of the more general concept. - -(define system-state-space - (make-state-space #F)) - -(define current-dynamic-state - (let ((prim (make-primitive-procedure 'current-dynamic-state))) - (named-lambda (current-dynamic-state #!optional state-space) - (prim (if (unassigned? state-space) - system-state-space - state-space))))) - -(define set-current-dynamic-state! - (make-primitive-procedure 'set-current-dynamic-state!)) - -;; NOTICE that the "before" thunk is executed IN THE NEW STATE, -;; the "after" thunk is executed IN THE OLD STATE. It is hard to -;; imagine why anyone would care about this. - -(define (dynamic-wind before during after) - (execute-at-new-state-point system-state-space - before - during - after)) - -;; This is so the microcode can find the base state point. - -(let ((fov (get-fixed-objects-vector))) - (vector-set! fov - (fixed-objects-vector-slot 'STATE-SPACE-ROOT) - (current-dynamic-state)) - (set-fixed-objects-vector! fov)) \ No newline at end of file diff --git a/v7/src/sf/cgen.scm b/v7/src/sf/cgen.scm deleted file mode 100644 index 19d55ecb3..000000000 --- a/v7/src/sf/cgen.scm +++ /dev/null @@ -1,195 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/cgen.scm,v 3.3 1987/03/20 23:49:11 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; SCode Optimizer: Generate SCode from Expression - -(declare (usual-integrations)) - -(define (cgen/external quotation) - (fluid-let ((flush-declarations? true)) - (cgen/top-level quotation))) - -(define (cgen/external-with-declarations expression) - (fluid-let ((flush-declarations? false)) - (cgen/expression (list false) expression))) - -(define (cgen/top-level quotation) - (let ((block (quotation/block quotation)) - (expression (quotation/expression quotation))) - (cgen/declaration (block/declarations block) - (cgen/expression (list block) expression)))) - -(define (cgen/declaration declarations expression) - (let ((declarations (maybe-flush-declarations declarations))) - (if (null? declarations) - expression - (make-declaration declarations expression)))) - -(define flush-declarations?) - -(define (maybe-flush-declarations declarations) - (if (null? declarations) - '() - (let ((declarations (declarations/original declarations))) - (if flush-declarations? - (begin (for-each (lambda (declaration) - (if (not (declarations/known? declaration)) - (warn "Unused declaration" declaration))) - declarations) - '()) - declarations)))) - -(define (cgen/expressions interns expressions) - (map (lambda (expression) - (cgen/expression interns expression)) - expressions)) - -(define (cgen/expression interns expression) - ((expression/method dispatch-vector expression) interns expression)) - -(define dispatch-vector - (expression/make-dispatch-vector)) - -(define define-method/cgen - (expression/make-method-definer dispatch-vector)) - -(define (cgen/variable interns variable) - (cdr (or (assq variable (cdr interns)) - (let ((association - (cons variable (make-variable (variable/name variable))))) - (set-cdr! interns (cons association (cdr interns))) - association)))) - -(define-method/cgen 'ACCESS - (lambda (interns expression) - (make-access (cgen/expression interns (access/environment expression)) - (access/name expression)))) - -(define-method/cgen 'ASSIGNMENT - (lambda (interns expression) - (make-assignment-from-variable - (cgen/variable interns (assignment/variable expression)) - (cgen/expression interns (assignment/value expression))))) - -(define-method/cgen 'COMBINATION - (lambda (interns expression) - (make-combination - (cgen/expression interns (combination/operator expression)) - (cgen/expressions interns (combination/operands expression))))) - -(define-method/cgen 'CONDITIONAL - (lambda (interns expression) - (make-conditional - (cgen/expression interns (conditional/predicate expression)) - (cgen/expression interns (conditional/consequent expression)) - (cgen/expression interns (conditional/alternative expression))))) - -(define-method/cgen 'CONSTANT - (lambda (interns expression) - (constant/value expression))) - -(define-method/cgen 'DECLARATION - (lambda (interns expression) - (cgen/declaration (declaration/declarations expression) - (cgen/expression interns - (declaration/expression expression))))) - -(define-method/cgen 'DELAY - (lambda (interns expression) - (make-delay (cgen/expression interns (delay/expression expression))))) - -(define-method/cgen 'DISJUNCTION - (lambda (interns expression) - (make-disjunction - (cgen/expression interns (disjunction/predicate expression)) - (cgen/expression interns (disjunction/alternative expression))))) - -(define-method/cgen 'IN-PACKAGE - (lambda (interns expression) - (make-in-package - (cgen/expression interns (in-package/environment expression)) - (cgen/top-level (in-package/quotation expression))))) - -(define-method/cgen 'PROCEDURE - (lambda (interns procedure) - (make-lambda* (procedure/name procedure) - (map variable/name (procedure/required procedure)) - (map variable/name (procedure/optional procedure)) - (let ((rest (procedure/rest procedure))) - (and rest (variable/name rest))) - (let ((block (procedure/block procedure))) - (make-open-block - '() - (maybe-flush-declarations (block/declarations block)) - (cgen/expression (list block) - (procedure/body procedure))))))) - -(define-method/cgen 'OPEN-BLOCK - (lambda (interns expression) - (let ((block (open-block/block expression))) - (make-open-block '() - (maybe-flush-declarations (block/declarations block)) - (cgen/body (list block) expression))))) - -(define (cgen/body interns open-block) - (make-sequence - (let loop - ((variables (open-block/variables open-block)) - (values (open-block/values open-block)) - (actions (open-block/actions open-block))) - (cond ((null? variables) (cgen/expressions interns actions)) - ((null? actions) (error "Extraneous auxiliaries")) - ((eq? (car actions) open-block/value-marker) - (cons (make-definition (variable/name (car variables)) - (cgen/expression interns (car values))) - (loop (cdr variables) (cdr values) (cdr actions)))) - (else - (cons (cgen/expression interns (car actions)) - (loop variables values (cdr actions)))))))) - -(define-method/cgen 'QUOTATION - (lambda (interns expression) - (make-quotation (cgen/top-level expression)))) - -(define-method/cgen 'REFERENCE - (lambda (interns expression) - (cgen/variable interns (reference/variable expression)))) - -(define-method/cgen 'SEQUENCE - (lambda (interns expression) - (make-sequence (cgen/expressions interns (sequence/actions expression))))) - -(define-method/cgen 'THE-ENVIRONMENT - (lambda (interns expression) - (make-the-environment))) \ No newline at end of file diff --git a/v7/src/sf/chtype.scm b/v7/src/sf/chtype.scm deleted file mode 100644 index 157deca2c..000000000 --- a/v7/src/sf/chtype.scm +++ /dev/null @@ -1,137 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/chtype.scm,v 1.1 1987/03/21 00:23:49 cph Rel $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; SCode Optimizer: Intern object types - -(declare (usual-integrations)) - -(define (change-type/external block expression) - (change-type/block block) - (change-type/expression expression) - (return-2 expression (block/bound-variables block))) - -(define (change-type/block block) - (change-type/object enumeration/random block) - (for-each (lambda (variable) - (change-type/object enumeration/random variable)) - (block/bound-variables block)) - (for-each change-type/block (block/children block))) - -(define (change-type/expressions expressions) - (for-each change-type/expression expressions)) - -(define (change-type/expression expression) - (change-type/object enumeration/expression expression) - ((expression/method dispatch-vector expression) expression)) - -(define dispatch-vector - (expression/make-dispatch-vector)) - -(define define-method/change-type - (expression/make-method-definer dispatch-vector)) - -(define (change-type/object enumeration object) - (object/set-enumerand! - object - (enumeration/name->enumerand enumeration - (enumerand/name (object/enumerand object))))) - -(define-method/change-type 'ACCESS - (lambda (expression) - (change-type/expression (access/environment expression)))) - -(define-method/change-type 'ASSIGNMENT - (lambda (expression) - (change-type/expression (assignment/value expression)))) - -(define-method/change-type 'COMBINATION - (lambda (expression) - (change-type/expression (combination/operator expression)) - (change-type/expressions (combination/operands expression)))) - -(define-method/change-type 'CONDITIONAL - (lambda (expression) - (change-type/expression (conditional/predicate expression)) - (change-type/expression (conditional/consequent expression)) - (change-type/expression (conditional/alternative expression)))) - -(define-method/change-type 'CONSTANT - (lambda (expression) - 'DONE)) - -(define-method/change-type 'DECLARATION - (lambda (expression) - (change-type/expression (declaration/expression expression)))) - -(define-method/change-type 'DELAY - (lambda (expression) - (change-type/expression (delay/expression expression)))) - -(define-method/change-type 'DISJUNCTION - (lambda (expression) - (change-type/expression (disjunction/predicate expression)) - (change-type/expression (disjunction/alternative expression)))) - -(define-method/change-type 'IN-PACKAGE - (lambda (expression) - (change-type/expression (in-package/environment expression)) - (change-type/quotation (in-package/quotation expression)))) - -(define-method/change-type 'PROCEDURE - (lambda (expression) - (change-type/expression (procedure/body expression)))) - -(define-method/change-type 'OPEN-BLOCK - (lambda (expression) - (change-type/expressions (open-block/values expression)) - (change-type/expressions (open-block/actions expression)))) - -(define-method/change-type 'QUOTATION - (lambda (expression) - (change-type/quotation expression))) - -(define (change-type/quotation quotation) - (change-type/expression (quotation/expression quotation))) - -(define-method/change-type 'REFERENCE - (lambda (expression) - 'DONE)) - -(define-method/change-type 'SEQUENCE - (lambda (expression) - (change-type/expressions (sequence/actions expression)))) - -(define-method/change-type 'THE-ENVIRONMENT - (lambda (expression) - 'DONE)) \ No newline at end of file diff --git a/v7/src/sf/copy.scm b/v7/src/sf/copy.scm deleted file mode 100644 index d9efd13ea..000000000 --- a/v7/src/sf/copy.scm +++ /dev/null @@ -1,277 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/copy.scm,v 3.3 1987/03/20 23:49:22 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; SCode Optimizer: Copy Expression - -(declare (usual-integrations)) - -(define root-block) - -(define (copy/external/intern block expression uninterned) - (fluid-let ((root-block block) - (copy/variable/free copy/variable/free/intern) - (copy/declarations copy/declarations/intern)) - (copy/expression root-block - (environment/rebind block (environment/make) uninterned) - expression))) - -(define (copy/external/extern expression) - (fluid-let ((root-block (block/make false false)) - (copy/variable/free copy/variable/free/extern) - (copy/declarations copy/declarations/extern)) - (let ((expression - (copy/expression root-block (environment/make) expression))) - (return-2 root-block expression)))) - -(define (copy/expressions block environment expressions) - (map (lambda (expression) - (copy/expression block environment expression)) - expressions)) - -(define (copy/expression block environment expression) - ((expression/method dispatch-vector expression) - block environment expression)) - -(define dispatch-vector - (expression/make-dispatch-vector)) - -(define define-method/copy - (expression/make-method-definer dispatch-vector)) - -(define (copy/quotation quotation) - (fluid-let ((root-block false)) - (let ((block (quotation/block quotation))) - (quotation/make block - (copy/expression block - (environment/make) - (quotation/expression quotation)))))) - -(define (copy/block parent environment block) - (let ((result (block/make parent (block/safe? block))) - (old-bound (block/bound-variables block))) - (let ((new-bound - (map (lambda (variable) - (variable/make result (variable/name variable))) - old-bound))) - (let ((environment (environment/bind environment old-bound new-bound))) - (block/set-bound-variables! result new-bound) - (block/set-declarations! - result - (copy/declarations block environment (block/declarations block))) - (return-2 result environment))))) - -(define copy/variable/free) - -(define (copy/variable block environment variable) - (environment/lookup environment variable - identity-procedure - (copy/variable/free variable))) - -(define (copy/variable/free/intern variable) - (lambda () - (let ((name (variable/name variable))) - (let loop ((block root-block)) - (let ((variable* (variable/assoc name (block/bound-variables block)))) - (cond ((eq? variable variable*) - variable) - ((not (block/parent block)) - (error "Unable to find free variable during copy" name)) - ((not variable*) - (loop (block/parent block))) - ((block/safe? (variable/block variable*)) - (variable/set-name! variable* (rename-symbol name)) - (loop (block/parent block))) - (else - (error "Integration requires renaming unsafe variable" - name)))))))) - -(define (rename-symbol symbol) - (string->uninterned-symbol (symbol->string symbol))) - -(define (copy/variable/free/extern variable) - (lambda () - (block/lookup-name root-block (variable/name variable)))) - -(define copy/declarations) - -(define (copy/declarations/intern block environment declarations) - (if (null? declarations) - '() - (declarations/map declarations - (lambda (variable) - (environment/lookup environment variable - identity-procedure - (lambda () variable))) - identity-procedure))) - -(define (copy/declarations/extern block environment declarations) - (if (null? declarations) - '() - (declarations/map declarations - (lambda (variable) - (environment/lookup environment variable - identity-procedure - (lambda () - (block/lookup-name root-block variable)))) - (lambda (expression) - (copy/expression block environment expression))))) - -(define (environment/make) - '()) - -(define (environment/bind environment variables values) - (map* environment cons variables values)) - -(define (environment/lookup environment variable if-found if-not) - (let ((association (assq variable environment))) - (if association - (if-found (cdr association)) - (if-not)))) - -(define (environment/rebind block environment variables) - (environment/bind environment - variables - (map (lambda (variable) - (block/lookup-name block (variable/name variable))) - variables))) - -(define (make-renamer environment) - (lambda (variable) - (environment/lookup environment variable - identity-procedure - (lambda () (error "Missing variable during copy operation" variable))))) - -(define-method/copy 'ACCESS - (lambda (block environment expression) - (access/make (copy/expression block environment - (access/environment expression)) - (access/name expression)))) - -(define-method/copy 'ASSIGNMENT - (lambda (block environment expression) - (assignment/make - block - (copy/variable block environment (assignment/variable expression)) - (copy/expression block environment (assignment/value expression))))) - -(define-method/copy 'COMBINATION - (lambda (block environment expression) - (combination/make - (copy/expression block environment (combination/operator expression)) - (copy/expressions block environment (combination/operands expression))))) - -(define-method/copy 'CONDITIONAL - (lambda (block environment expression) - (conditional/make - (copy/expression block environment (conditional/predicate expression)) - (copy/expression block environment (conditional/consequent expression)) - (copy/expression block environment - (conditional/alternative expression))))) - -(define-method/copy 'CONSTANT - (lambda (block environment expression) - expression)) - -(define-method/copy 'DECLARATION - (lambda (block environment expression) - (declaration/make - (copy/declarations block environment - (declaration/declarations expression)) - (copy/expression block environment (declaration/expression expression))))) - -(define-method/copy 'DELAY - (lambda (block environment expression) - (delay/make - (copy/expression block environment (delay/expression expression))))) - -(define-method/copy 'DISJUNCTION - (lambda (block environment expression) - (disjunction/make - (copy/expression block environment (disjunction/predicate expression)) - (copy/expression block environment - (disjunction/alternative expression))))) - -(define-method/copy 'IN-PACKAGE - (lambda (block environment expression) - (in-package/make - (copy/expression block environment (in-package/environment expression)) - (copy/quotation (in-package/quotation expression))))) - -(define-method/copy 'PROCEDURE - (lambda (block environment procedure) - (transmit-values (copy/block block environment (procedure/block procedure)) - (lambda (block environment) - (let ((rename (make-renamer environment))) - (procedure/make block - (procedure/name procedure) - (map rename (procedure/required procedure)) - (map rename (procedure/optional procedure)) - (let ((rest (procedure/rest procedure))) - (and rest (rename rest))) - (copy/expression block environment - (procedure/body procedure)))))))) - -(define-method/copy 'OPEN-BLOCK - (lambda (block environment expression) - (transmit-values - (copy/block block environment (open-block/block expression)) - (lambda (block environment) - (open-block/make - block - (map (make-renamer environment) (open-block/variables expression)) - (copy/expressions block environment (open-block/values expression)) - (map (lambda (action) - (if (eq? action open-block/value-marker) - action - (copy/expression block environment action))) - (open-block/actions expression))))))) - -(define-method/copy 'QUOTATION - (lambda (block environment expression) - (copy/quotation expression))) - -(define-method/copy 'REFERENCE - (lambda (block environment expression) - (reference/make block - (copy/variable block environment - (reference/variable expression))))) - -(define-method/copy 'SEQUENCE - (lambda (block environment expression) - (sequence/make - (copy/expressions block environment (sequence/actions expression))))) - -(define-method/copy 'THE-ENVIRONMENT - (lambda (block environment expression) - (error "Attempt to integrate expression containing (THE-ENVIRONMENT)"))) \ No newline at end of file diff --git a/v7/src/sf/emodel.scm b/v7/src/sf/emodel.scm deleted file mode 100644 index 2032dab2c..000000000 --- a/v7/src/sf/emodel.scm +++ /dev/null @@ -1,59 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/emodel.scm,v 3.2 1987/03/13 04:12:19 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; SCode Optimizer: Environment Model - -(declare (usual-integrations)) - -(define variable/assoc - (association-procedure eq? variable/name)) - -(define (block/unsafe! block) - (if (block/safe? block) - (begin (block/set-safe?! block false) - (if (block/parent block) - (block/unsafe! (block/parent block)))))) - -(define (block/lookup-name block name) - (let search ((block block)) - (or (variable/assoc name (block/bound-variables block)) - (let ((parent (block/parent block))) - (if (not parent) - (variable/make&bind! block name) - (search parent)))))) - -(define (block/lookup-names block names) - (map (lambda (name) - (block/lookup-name block name)) - names)) \ No newline at end of file diff --git a/v7/src/sf/free.scm b/v7/src/sf/free.scm deleted file mode 100644 index 82cb45a88..000000000 --- a/v7/src/sf/free.scm +++ /dev/null @@ -1,128 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/free.scm,v 3.2 1987/03/13 04:12:30 cph Rel $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; SCode Optimizer: Free Variable Analysis - -(declare (usual-integrations)) - -(define (free/expressions expressions) - (if (null? expressions) - eq?-set/null - (eq?-set/union (free/expression (car expressions)) - (free/expressions (cdr expressions))))) - -(define (free/expression expression) - ((expression/method dispatch-vector expression) expression)) - -(define dispatch-vector - (expression/make-dispatch-vector)) - -(define define-method/free - (expression/make-method-definer dispatch-vector)) - -(define-method/free 'ACCESS - (lambda (expression) - (free/expression (access/environment expression)))) - -(define-method/free 'ASSIGNMENT - (lambda (expression) - (eq?-set/adjoin (assignment/variable expression) - (free/expression (assignment/value expression))))) - -(define-method/free 'COMBINATION - (lambda (expression) - (eq?-set/union (free/expression (combination/operator expression)) - (free/expressions (combination/operands expression))))) - -(define-method/free 'CONDITIONAL - (lambda (expression) - (eq?-set/union - (free/expression (conditional/predicate expression)) - (eq?-set/union (free/expression (conditional/consequent expression)) - (free/expression (conditional/alternative expression)))))) - -(define-method/free 'CONSTANT - (lambda (expression) - eq?-set/null)) - -(define-method/free 'DECLARATION - (lambda (expression) - (free/expression (declaration/expression expression)))) - -(define-method/free 'DELAY - (lambda (expression) - (free/expression (delay/expression expression)))) - -(define-method/free 'DISJUNCTION - (lambda (expression) - (eq?-set/union (free/expression (disjunction/predicate expression)) - (free/expression (disjunction/alternative expression))))) - -(define-method/free 'IN-PACKAGE - (lambda (expression) - (free/expression (in-package/environment expression)))) - -(define-method/free 'PROCEDURE - (lambda (expression) - (eq?-set/difference (free/expression (procedure/body expression)) - (block/bound-variables (procedure/block expression))))) - -(define-method/free 'OPEN-BLOCK - (lambda (expression) - (eq?-set/difference - (eq?-set/union (free/expressions (open-block/values expression)) - (let loop ((actions (open-block/actions expression))) - (cond ((null? actions) eq?-set/null) - ((eq? (car actions) open-block/value-marker) - (loop (cdr actions))) - (else - (eq?-set/union (free/expression (car actions)) - (loop (cdr actions))))))) - (block/bound-variables (open-block/block expression))))) - -(define-method/free 'QUOTATION - (lambda (expression) - eq?-set/null)) - -(define-method/free 'REFERENCE - (lambda (expression) - (eq?-set/singleton (reference/variable expression)))) - -(define-method/free 'SEQUENCE - (lambda (expression) - (free/expressions (sequence/actions expression)))) - -(define-method/free 'THE-ENVIRONMENT - (lambda (expression) - eq?-set/null)) \ No newline at end of file diff --git a/v7/src/sf/gconst.scm b/v7/src/sf/gconst.scm deleted file mode 100644 index 523b68311..000000000 --- a/v7/src/sf/gconst.scm +++ /dev/null @@ -1,119 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/gconst.scm,v 3.0 1987/03/10 13:24:58 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; SCode Optimizer: Global Constants List - -(declare (usual-integrations)) - -;;; This is a list of names that are bound in the global environment. -;;; Normally the compiler will replace references to one of these -;;; names with the value of that name, which is a constant. - -(define global-constant-objects - '(TRUE FALSE SYSTEM-GLOBAL-ENVIRONMENT - - SCODE-EVAL FORCE WITH-THREADED-CONTINUATION - SET-INTERRUPT-ENABLES! WITH-INTERRUPT-MASK WITH-INTERRUPTS-REDUCED - GET-FIXED-OBJECTS-VECTOR WITH-HISTORY-DISABLED - PRIMITIVE-PROCEDURE-ARITY NOT FALSE? - STRING->SYMBOL ERROR-PROCEDURE - - ;; Environment - LEXICAL-REFERENCE LEXICAL-ASSIGNMENT LOCAL-ASSIGNMENT - LEXICAL-UNASSIGNED? LEXICAL-UNBOUND? LEXICAL-UNREFERENCEABLE? - - ;; Pointers - EQ? - PRIMITIVE-SET-TYPE MAKE-NON-POINTER-OBJECT - PRIMITIVE-TYPE? PRIMITIVE-TYPE PRIMITIVE-DATUM - OBJECT-DANGEROUS? MAKE-OBJECT-SAFE MAKE-OBJECT-DANGEROUS - - ;; Numbers - ZERO? POSITIVE? NEGATIVE? 1+ -1+ - INTEGER-DIVIDE INTEGER-DIVIDE-QUOTIENT INTEGER-DIVIDE-REMAINDER - TRUNCATE ROUND FLOOR CEILING - SQRT EXP LOG SIN COS - - ;; Basic Compound Datatypes - CONS PAIR? CAR CDR SET-CAR! SET-CDR! GENERAL-CAR-CDR - NULL? LENGTH MEMQ ASSQ FIRST HEAD EMPTY-STREAM? - - VECTOR-CONS VECTOR-LENGTH VECTOR-REF VECTOR-SET! - LIST->VECTOR SUBVECTOR->LIST - - ;; Strings - STRING-ALLOCATE STRING? STRING-REF STRING-SET! - STRING-LENGTH STRING-MAXIMUM-LENGTH SET-STRING-LENGTH! - SUBSTRING=? SUBSTRING-CI=? SUBSTRINGUNSIGNED-INTEGER UNSIGNED-INTEGER->BIT-STRING - READ-BITS! WRITE-BITS! - - MAKE-CELL CELL? CELL-CONTENTS SET-CELL-CONTENTS! - - ;; Characters - MAKE-CHAR CHAR-CODE CHAR-BITS - CHAR-ASCII? ASCII->CHAR CHAR->ASCII - INTEGER->CHAR CHAR->INTEGER - CHAR-UPCASE CHAR-DOWNCASE - - ;; System Compound Datatypes - SYSTEM-PAIR-CONS SYSTEM-PAIR? - SYSTEM-PAIR-CAR SYSTEM-PAIR-SET-CAR! - SYSTEM-PAIR-CDR SYSTEM-PAIR-SET-CDR! - - SYSTEM-HUNK3-CXR0 SYSTEM-HUNK3-SET-CXR0! - SYSTEM-HUNK3-CXR1 SYSTEM-HUNK3-SET-CXR1! - SYSTEM-HUNK3-CXR2 SYSTEM-HUNK3-SET-CXR2! - - SYSTEM-LIST-TO-VECTOR SYSTEM-SUBVECTOR-TO-LIST SYSTEM-VECTOR? - SYSTEM-VECTOR-SIZE SYSTEM-VECTOR-REF SYSTEM-VECTOR-SET! - )) \ No newline at end of file diff --git a/v7/src/sf/make.scm b/v7/src/sf/make.scm deleted file mode 100644 index 0b1699b2f..000000000 --- a/v7/src/sf/make.scm +++ /dev/null @@ -1,118 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 3.4 1987/03/20 23:50:32 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; SCode Optimizer: System Construction - -(in-package system-global-environment -(declare (usual-integrations)) - -(define sf) -(define sf/set-file-syntax-table!) -(define sf/add-file-declarations!) -(load "$zcomp/base/load" system-global-environment) - -(load-system system-global-environment - 'PACKAGE/SCODE-OPTIMIZER - '(SYSTEM-GLOBAL-ENVIRONMENT) - '( - (PACKAGE/SCODE-OPTIMIZER - "mvalue" ;Multiple Value Support - "eqsets" ;Set Data Abstraction - - "object" ;Data Structures - "emodel" ;Environment Model - "gconst" ;Global Primitives List - "usicon" ;Usual Integrations: Constants - "tables" ;Table Abstractions - "packag" ;Global packaging - ) - - (PACKAGE/TOP-LEVEL - "toplev" ;Top Level - ) - - (PACKAGE/TRANSFORM - "xform" ;SCode -> Internal - ) - - (PACKAGE/INTEGRATE - "subst" ;Beta Substitution Optimizer - ) - - (PACKAGE/CGEN - "cgen" ;Internal -> SCode - ) - - (PACKAGE/EXPANSION - "usiexp" ;Usual Integrations: Expanders - ) - - (PACKAGE/DECLARATIONS - "pardec" ;Declaration Parser - ) - - (PACKAGE/COPY - "copy" ;Copy Expressions - ) - - (PACKAGE/FREE - "free" ;Free Variable Analysis - ) - - (PACKAGE/SAFE? - "safep" ;Safety Analysis - ) - - (PACKAGE/CHANGE-TYPE - "chtype" ;Type interning - ) - - )) - -(in-package package/scode-optimizer - (define integrations - "$zcomp/source/object") - - (define scode-optimizer/system - (make-environment - (define :name "SF") - (define :version 3) - (define :modification 3))) - - (add-system! scode-optimizer/system) - - (scode-optimizer/initialize!)) - -;;; end IN-PACKAGE SYSTEM-GLOBAL-ENVIRONMENT -) \ No newline at end of file diff --git a/v7/src/sf/object.scm b/v7/src/sf/object.scm deleted file mode 100644 index 8bf2f284d..000000000 --- a/v7/src/sf/object.scm +++ /dev/null @@ -1,257 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/object.scm,v 3.1 1987/03/13 04:12:53 cph Rel $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; SCode Optimizer: Data Types - -(declare (usual-integrations)) - -(let-syntax () - -(define-syntax define-type - (macro (name enumeration slots) - (let ((enumerand (symbol-append name '/ENUMERAND))) - `(BEGIN - (DEFINE ,enumerand - (ENUMERATION/NAME->ENUMERAND ,(symbol-append 'ENUMERATION/ - enumeration) - ',name)) - ((ACCESS ADD-UNPARSER-SPECIAL-OBJECT! UNPARSER-PACKAGE) ,enumerand - (LAMBDA (OBJECT) - (UNPARSE-WITH-BRACKETS - (LAMBDA () - (WRITE ',name) - (WRITE-STRING " ") - (WRITE (HASH OBJECT)))))) - (DEFINE ,(symbol-append name '?) (OBJECT/PREDICATE ,enumerand)) - ,@(let loop ((slots slots) (index 1)) - (if (null? slots) - '() - (let ((slot (car slots))) - (let ((ref-name (symbol-append name '/ slot)) - (set-name (symbol-append name '/SET- slot '!))) - `((DECLARE (INTEGRATE-OPERATOR ,ref-name ,set-name)) - (DEFINE (,ref-name ,name) - (DECLARE (INTEGRATE ,name)) - (VECTOR-REF ,name ,index)) - (DEFINE (,set-name ,name ,slot) - (DECLARE (INTEGRATE ,name ,slot)) - (VECTOR-SET! ,name ,index ,slot)) - ,@(loop (cdr slots) (1+ index))))))))))) - -(define-syntax define-simple-type - (macro (name enumeration slots) - (let ((make-name (symbol-append name '/MAKE))) - `(BEGIN (DECLARE (INTEGRATE-OPERATOR ,make-name)) - (DEFINE (,make-name ,@slots) - (DECLARE (INTEGRATE ,@slots)) - (OBJECT/ALLOCATE ,(symbol-append name '/ENUMERAND) ,@slots)) - (DEFINE-TYPE ,name ,enumeration ,slots))))) - -;;;; Objects - -(declare (integrate object/allocate) - (integrate-operator object/enumerand object/set-enumerand!)) - -(define object/allocate vector) - -(define (object/enumerand object) - (declare (integrate object)) - (vector-ref object 0)) - -(define (object/set-enumerand! object enumerand) - (declare (integrate object enumerand)) - (vector-set! object 0 enumerand)) - -(define (object/predicate enumerand) - (lambda (object) - (and (vector? object) - (not (zero? (vector-length object))) - (eq? enumerand (vector-ref object 0))))) - -;;;; Enumerations - -(define (enumeration/make names) - (let ((enumerands - (let loop ((names names) (index 0)) - (if (null? names) - '() - (cons (vector false (car names) index) - (loop (cdr names) (1+ index))))))) - (let ((enumeration - (cons (list->vector enumerands) - (map (lambda (enumerand) - (cons (enumerand/name enumerand) enumerand)) - enumerands)))) - (for-each (lambda (enumerand) - (vector-set! enumerand 0 enumeration)) - enumerands) - enumeration))) - -(declare (integrate-operator enumerand/enumeration enumerand/name - enumerand/index enumeration/cardinality - enumeration/index->enumerand)) - -(define (enumerand/enumeration enumerand) - (declare (integrate enumerand)) - (vector-ref enumerand 0)) - -(define (enumerand/name enumerand) - (declare (integrate enumerand)) - (vector-ref enumerand 1)) - -(define (enumerand/index enumerand) - (declare (integrate enumerand)) - (vector-ref enumerand 2)) - -(define (enumeration/cardinality enumeration) - (declare (integrate enumeration)) - (vector-length (car enumeration))) - -(define (enumeration/index->enumerand enumeration index) - (declare (integrate enumeration index)) - (vector-ref (car enumeration) index)) - -(define (enumeration/name->enumerand enumeration name) - (cdr (or (assq name (cdr enumeration)) - (error "Unknown enumeration name" name)))) - -(define (enumeration/name->index enumeration name) - (enumerand/index (enumeration/name->enumerand enumeration name))) - -;;;; Random Types - -(define enumeration/random - (enumeration/make - '(BLOCK - DELAYED-INTEGRATION - VARIABLE - ))) - -(define-type block random - (parent children safe? declarations bound-variables)) - -(define (block/make parent safe?) - (let ((block - (object/allocate block/enumerand parent '() safe? - (declarations/make-null) '()))) - (if parent - (block/set-children! parent (cons block (block/children parent)))) - block)) - -(define-type delayed-integration random - (state environment operations value)) - -(declare (integrate-operator delayed-integration/make)) - -(define (delayed-integration/make operations expression) - (declare (integrate operations expression)) - (object/allocate delayed-integration/enumerand 'NOT-INTEGRATED false - operations expression)) - -(define-simple-type variable random - (block name)) - -(define (variable/make&bind! block name) - (let ((variable (variable/make block name))) - (block/set-bound-variables! block - (cons variable - (block/bound-variables block))) - variable)) - -(define open-block/value-marker - ;; This must be an interned object because we will fasdump it and - ;; fasload it back in. - (make-named-tag "open-block/value-marker")) - -;;;; Expression Types - -(define enumeration/expression - (enumeration/make - '(ACCESS - ASSIGNMENT - COMBINATION - CONDITIONAL - CONSTANT - DECLARATION - DELAY - DISJUNCTION - IN-PACKAGE - OPEN-BLOCK - PROCEDURE - QUOTATION - REFERENCE - SEQUENCE - THE-ENVIRONMENT - ))) - -(define (expression/make-dispatch-vector) - (make-vector (enumeration/cardinality enumeration/expression))) - -(define (expression/make-method-definer dispatch-vector) - (lambda (type-name method) - (vector-set! dispatch-vector - (enumeration/name->index enumeration/expression type-name) - method))) - -(declare (integrate-operator expression/method name->method)) - -(define (expression/method dispatch-vector expression) - (declare (integrate dispatch-vector expression)) - (vector-ref dispatch-vector (enumerand/index (object/enumerand expression)))) - -(define (name->method dispatch-vector name) - ;; Useful for debugging - (declare (integrate dispatch-vector name)) - (vector-ref dispatch-vector - (enumeration/name->index enumeration/expression name))) - -(define-simple-type access expression (environment name)) -(define-simple-type assignment expression (block variable value)) -(define-simple-type combination expression (operator operands)) -(define-simple-type conditional expression (predicate consequent alternative)) -(define-simple-type constant expression (value)) -(define-simple-type declaration expression (declarations expression)) -(define-simple-type delay expression (expression)) -(define-simple-type disjunction expression (predicate alternative)) -(define-simple-type in-package expression (environment quotation)) -(define-simple-type open-block expression (block variables values actions)) -(define-simple-type procedure expression - (block name required optional rest body)) -(define-simple-type quotation expression (block expression)) -(define-simple-type reference expression (block variable)) -(define-simple-type sequence expression (actions)) -(define-simple-type the-environment expression (block)) - -;;; end LET-SYNTAX -) \ No newline at end of file diff --git a/v7/src/sf/pardec.scm b/v7/src/sf/pardec.scm deleted file mode 100644 index 487ac5094..000000000 --- a/v7/src/sf/pardec.scm +++ /dev/null @@ -1,307 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 3.3 1987/03/19 17:19:06 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; SCode Optimizer: Parse Declarations - -(declare (usual-integrations)) - -(define (declarations/make-null) - (declarations/make '() '() '())) - -(define (declarations/parse block declarations) - (transmit-values - (accumulate - (lambda (declaration bindings) - (let ((association (assq (car declaration) known-declarations))) - (if (not association) - bindings - (transmit-values (cdr association) - (lambda (before-bindings? parser) - (let ((block - (if before-bindings? - (let ((block (block/parent block))) - (if (block/parent block) - (warn "Declaration not at top level" - declaration)) - block) - block))) - (parser block - (bindings/cons block before-bindings?) - bindings - (cdr declaration)))))))) - (return-2 '() '()) - declarations) - (lambda (before after) - (declarations/make declarations before after)))) - -(define (bindings/cons block before-bindings?) - (lambda (bindings global? operation export? names values) - (let ((result - (binding/make global? operation export? - (if global? names (block/lookup-names block names)) - values))) - (transmit-values bindings - (lambda (before after) - (if before-bindings? - (return-2 (cons result before) after) - (return-2 before (cons result after)))))))) - -(define (bind/values table/cons table operation export? names values) - (table/cons table (not export?) operation export? names values)) - -(define (bind/no-values table/cons table operation export? names) - (table/cons table false operation export? names 'NO-VALUES)) - -(define (declarations/known? declaration) - (assq (car declaration) known-declarations)) - -(define (define-declaration name before-bindings? parser) - (let ((entry (assq name known-declarations))) - (if entry - (set-cdr! entry (return-2 before-bindings? parser)) - (set! known-declarations - (cons (cons name (return-2 before-bindings? parser)) - known-declarations))))) - -(define known-declarations - '()) - -(define (accumulate cons table items) - (let loop ((table table) (items items)) - (if (null? items) - table - (loop (cons (car items) table) (cdr items))))) - -(define (declarations/binders declarations) - (let ((procedure - (lambda (bindings) - (lambda (operations) - (accumulate (lambda (binding operations) - ((if (binding/global? binding) - operations/bind-global - operations/bind) - operations - (binding/operation binding) - (binding/export? binding) - (binding/names binding) - (binding/values binding))) - operations - bindings))))) - (return-2 (procedure (declarations/before declarations)) - (procedure (declarations/after declarations))))) - -(define (declarations/for-each-variable declarations procedure) - (declarations/for-each-binding declarations - (lambda (binding) - (if (not (binding/global? binding)) - (for-each procedure (binding/names binding)))))) - -(define (declarations/for-each-binding declarations procedure) - (let ((procedure - (lambda (bindings) - (for-each procedure bindings)))) - (procedure (declarations/before declarations)) - (procedure (declarations/after declarations)))) - -(define (declarations/map declarations per-name per-value) - (declarations/map-binding declarations - (lambda (binding) - (let ((global? (binding/global? binding)) - (names (binding/names binding)) - (values (binding/values binding))) - (binding/make global? - (binding/operation binding) - (binding/export? binding) - (if global? names (map per-name names)) - (if (eq? values 'NO-VALUES) - values - (map per-value values))))))) - -(define (declarations/map-binding declarations procedure) - (let ((procedure - (lambda (bindings) - (map procedure bindings)))) - (declarations/make (declarations/original declarations) - (procedure (declarations/before declarations)) - (procedure (declarations/after declarations))))) - -(declare (integrate-operator declarations/make declarations/original - declarations/before declarations/after)) - -(define (declarations/make original before after) - (declare (integrate original before after)) - (vector original before after)) - -(define (declarations/original declarations) - (declare (integrate declarations)) - (vector-ref declarations 0)) - -(define (declarations/before declarations) - (declare (integrate declarations)) - (vector-ref declarations 1)) - -(define (declarations/after declarations) - (declare (integrate declarations)) - (vector-ref declarations 2)) - -(declare (integrate-operator binding/make binding/global? binding/operation - binding/export? binding/names binding/values)) - -(define (binding/make global? operation export? names values) - (declare (integrate global? operation export? names values)) - (vector global? operation export? names values)) - -(define (binding/global? binding) - (declare (integrate binding)) - (vector-ref binding 0)) - -(define (binding/operation binding) - (declare (integrate binding)) - (vector-ref binding 1)) - -(define (binding/export? binding) - (declare (integrate binding)) - (vector-ref binding 2)) - -(define (binding/names binding) - (declare (integrate binding)) - (vector-ref binding 3)) - -(define (binding/values binding) - (declare (integrate binding)) - (vector-ref binding 4)) - -;;;; Integration of System Constants - -(define-declaration 'USUAL-INTEGRATIONS true - (lambda (block table/cons table deletions) - (let ((finish - (lambda (table operation names values) - (transmit-values - (if (null? deletions) - (return-2 names values) - (let deletion-loop ((names names) (values values)) - (cond ((null? names) (return-2 '() '())) - ((memq (car names) deletions) - (deletion-loop (cdr names) (cdr values))) - (else - (cons-multiple - (return-2 (car names) (car values)) - (deletion-loop (cdr names) (cdr values))))))) - (lambda (names values) - (bind/values table/cons table operation false names - values)))))) - (finish (finish table 'INTEGRATE - usual-integrations/constant-names - usual-integrations/constant-values) - 'EXPAND - usual-integrations/expansion-names - usual-integrations/expansion-values)))) - -(define-declaration 'INTEGRATE-PRIMITIVE-PROCEDURES false - (lambda (block table/cons table specifications) - (transmit-values - (let loop ((specifications specifications)) - (if (null? specifications) - (return-2 '() '()) - (cons-multiple (parse-primitive-specification - block - (car specifications)) - (loop (cdr specifications))))) - (lambda (names values) - (bind/values table/cons table 'INTEGRATE true names values))))) - -(define (parse-primitive-specification block specification) - (let ((finish - (lambda (variable-name primitive-name) - (return-2 variable-name - (constant->integration-info - (make-primitive-procedure primitive-name)))))) - (cond ((and (pair? specification) - (symbol? (car specification)) - (pair? (cdr specification)) - (symbol? (cadr specification)) - (null? (cddr specification))) - (finish (first specification) (second specification))) - ((symbol? specification) (finish specification specification)) - (else (error "Bad primitive specification" specification))))) - -;;;; Integration of User Code - -(define-declaration 'INTEGRATE false - (lambda (block table/cons table names) - (bind/no-values table/cons table 'INTEGRATE true names))) - -(define-declaration 'INTEGRATE-OPERATOR false - (lambda (block table/cons table names) - (bind/no-values table/cons table 'INTEGRATE-OPERATOR true names))) - -(define-declaration 'INTEGRATE-EXTERNAL true - (lambda (block table/cons table specifications) - (accumulate - (lambda (extern table) - (bind/values table/cons table (vector-ref extern 1) false - (list (vector-ref extern 0)) - (list - (intern-type (vector-ref extern 2) - (vector-ref extern 3))))) - table - (mapcan read-externs-file - (mapcan specification->pathnames specifications))))) - -(define (specification->pathnames specification) - (let ((value - (scode-eval (syntax specification system-global-syntax-table) - (access syntax-environment syntaxer-package)))) - (if (pair? value) - (map ->pathname value) - (list (->pathname value))))) - -(define (operations->external operations environment) - (operations/extract-external operations - (lambda (variable operation info if-ok if-not) - (let ((finish - (lambda (value) - (if-ok - (transmit-values (copy/expression/extern value) - (lambda (block expression) - (vector (variable/name variable) - operation - block - expression))))))) - (if info - (transmit-values info - (lambda (value uninterned) - (finish value))) - (variable/final-value variable environment finish if-not)))))) \ No newline at end of file diff --git a/v7/src/sf/subst.scm b/v7/src/sf/subst.scm deleted file mode 100644 index 3ffe3721c..000000000 --- a/v7/src/sf/subst.scm +++ /dev/null @@ -1,515 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/subst.scm,v 3.3 1987/03/20 23:49:33 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; SCode Optimizer: Beta Substitution - -(declare (usual-integrations)) - -(define (integrate/top-level block expression) - (let ((operations (operations/bind-block (operations/make) block)) - (environment (environment/make))) - (if (open-block? expression) - (transmit-values - (environment/recursive-bind operations environment - (open-block/variables expression) - (open-block/values expression)) - (lambda (environment values) - (return-3 operations - environment - (quotation/make block - (integrate/open-block operations - environment - expression - values))))) - (return-3 operations - environment - (quotation/make block - (integrate/expression operations - environment - expression)))))) - -(define (operations/bind-block operations block) - (let ((declarations (block/declarations block))) - (if (null? declarations) - (operations/shadow operations (block/bound-variables block)) - (transmit-values (declarations/binders declarations) - (lambda (before-bindings after-bindings) - (after-bindings - (operations/shadow (before-bindings operations) - (block/bound-variables block)))))))) - -(define (integrate/expressions operations environment expressions) - (map (lambda (expression) - (integrate/expression operations environment expression)) - expressions)) - -(define (integrate/expression operations environment expression) - ((expression/method dispatch-vector expression) - operations environment expression)) - -(define dispatch-vector - (expression/make-dispatch-vector)) - -(define define-method/integrate - (expression/make-method-definer dispatch-vector)) - -;;;; Lookup - -(define-method/integrate 'REFERENCE - (lambda (operations environment expression) - (operations/lookup operations (reference/variable expression) - (lambda (operation info) - (case operation - ((INTEGRATE-OPERATOR EXPAND) expression) - ((INTEGRATE) (integrate/name expression info environment)) - (else (error "Unknown operation" operation)))) - (lambda () expression)))) - -(define (integrate/reference-operator operations environment operator operands) - (let ((dont-integrate - (lambda () - (combination/make operator operands)))) - (operations/lookup operations (reference/variable operator) - (lambda (operation info) - (case operation - ((#F) (dont-integrate)) - ((INTEGRATE INTEGRATE-OPERATOR) - (integrate/combination operations - environment - (integrate/name operator info environment) - operands)) - ((EXPAND) - (info operands - identity-procedure ;expanded value can't be optimized further. - dont-integrate)) - (else (error "Unknown operation" operation)))) - dont-integrate))) - -(define-method/integrate 'ASSIGNMENT - (lambda (operations environment assignment) - (let ((variable (assignment/variable assignment))) - (operations/lookup operations variable - (lambda (operation info) - (case operation - ((INTEGRATE INTEGRATE-OPERATOR EXPAND) - (warn "Attempt to assign integrated name" - (variable/name variable))) - (else (error "Unknown operation" operation)))) - (lambda () 'DONE)) - (assignment/make (assignment/block assignment) - variable - (integrate/expression operations - environment - (assignment/value assignment)))))) - -;;;; Binding - -(define-method/integrate 'OPEN-BLOCK - (lambda (operations environment expression) - (let ((operations - (operations/bind-block operations (open-block/block expression)))) - (transmit-values - (environment/recursive-bind operations - environment - (open-block/variables expression) - (open-block/values expression)) - (lambda (environment values) - (integrate/open-block operations - environment - expression - values)))))) - -(define (integrate/open-block operations environment expression values) - (open-block/make (open-block/block expression) - (open-block/variables expression) - values - (map (lambda (action) - (if (eq? action open-block/value-marker) - action - (integrate/expression operations - environment - action))) - (open-block/actions expression)))) - -(define (integrate/procedure operations environment procedure) - (let ((block (procedure/block procedure))) - (procedure/make block - (procedure/name procedure) - (procedure/required procedure) - (procedure/optional procedure) - (procedure/rest procedure) - (integrate/expression (operations/bind-block operations - block) - environment - (procedure/body procedure))))) - -(define-method/integrate 'PROCEDURE - integrate/procedure) - -(define-method/integrate 'COMBINATION - (lambda (operations environment combination) - (integrate/combination - operations - environment - (combination/operator combination) - (integrate/expressions operations - environment - (combination/operands combination))))) - -(define (integrate/combination operations environment operator operands) - (if (reference? operator) - (integrate/reference-operator operations - environment - operator - operands) - (combination/optimizing-make - (if (procedure? operator) - (integrate/procedure-operator operations - environment - operator - operands) - (let ((operator - (integrate/expression operations environment operator))) - (if (procedure? operator) - (integrate/procedure-operator operations - environment - operator - operands) - operator))) - operands))) - -(define (integrate/procedure-operator operations environment procedure - operands) - (integrate/procedure operations - (simulate-application environment procedure operands) - procedure)) - -(define-method/integrate 'DECLARATION - (lambda (operations environment declaration) - (let ((declarations (declaration/declarations declaration))) - (declaration/make - declarations - (transmit-values (declarations/binders declarations) - (lambda (before-bindings after-bindings) - (integrate/expression (after-bindings (before-bindings operations)) - environment - (declaration/expression declaration)))))))) - -;;;; Easy Cases - -(define-method/integrate 'CONSTANT - (lambda (operations environment expression) - expression)) - -(define-method/integrate 'THE-ENVIRONMENT - (lambda (operations environment expression) - expression)) - -(define-method/integrate 'QUOTATION - (lambda (operations environment expression) - (integrate/quotation expression))) - -(define-method/integrate 'CONDITIONAL - (lambda (operations environment expression) - (conditional/make - (integrate/expression operations environment - (conditional/predicate expression)) - (integrate/expression operations environment - (conditional/consequent expression)) - (integrate/expression operations environment - (conditional/alternative expression))))) - -(define-method/integrate 'DISJUNCTION - (lambda (operations environment expression) - (disjunction/make - (integrate/expression operations environment - (disjunction/predicate expression)) - (integrate/expression operations environment - (disjunction/alternative expression))))) - -(define-method/integrate 'SEQUENCE - (lambda (operations environment expression) - (sequence/make - (integrate/expressions operations environment - (sequence/actions expression))))) - -(define-method/integrate 'ACCESS - (lambda (operations environment expression) - (access/make (integrate/expression operations environment - (access/environment expression)) - (access/name expression)))) - -(define-method/integrate 'DELAY - (lambda (operations environment expression) - (delay/make - (integrate/expression operations environment - (delay/expression expression))))) - -(define-method/integrate 'IN-PACKAGE - (lambda (operations environment expression) - (in-package/make (integrate/expression operations environment - (in-package/environment expression)) - (integrate/quotation (in-package/quotation expression))))) - -(define (integrate/quotation quotation) - (transmit-values (integrate/top-level (quotation/block quotation) - (quotation/expression quotation)) - (lambda (operations environment expression) - expression))) - -;;;; Environment - -(define (environment/recursive-bind operations environment variables values) - ;; Used to implement mutually-recursive definitions that can - ;; integrate one another. When circularities are detected within - ;; the definition-reference graph, integration is disabled. - (let ((values - (map (lambda (value) - (delayed-integration/make operations value)) - values))) - (let ((environment - (environment/bind-multiple environment variables values))) - (for-each (lambda (value) - (delayed-integration/set-environment! value environment)) - values) - (return-2 environment - (map delayed-integration/force values))))) - -(define (integrate/name reference info environment) - (let ((variable (reference/variable reference))) - (let ((finish - (lambda (value uninterned) - (copy/expression (reference/block reference) value uninterned)))) - (if info - (transmit-values info finish) - (environment/lookup environment variable - (lambda (value) - (if (delayed-integration? value) - (if (delayed-integration/in-progress? value) - reference - (finish (delayed-integration/force value) '())) - (finish value '()))) - (lambda () reference)))))) - -(define (variable/final-value variable environment if-value if-not) - (environment/lookup environment variable - (lambda (value) - (if (delayed-integration? value) - (if (delayed-integration/in-progress? value) - (error "Unfinished integration" value) - (if-value (delayed-integration/force value))) - (if-value value))) - (lambda () - (warn "Unable to integrate" (variable/name variable)) - (if-not)))) - -(define (simulate-application environment procedure operands) - - (define (match-required environment required operands) - (cond ((null? required) - (match-optional environment - (procedure/optional procedure) - operands)) - ((null? operands) - (error "Too few operands in call to procedure" procedure)) - (else - (match-required (environment/bind environment - (car required) - (car operands)) - (cdr required) - (cdr operands))))) - - (define (match-optional environment optional operands) - (cond ((null? optional) - (match-rest environment (procedure/rest procedure) operands)) - ((null? operands) - (match-rest environment (procedure/rest procedure) '())) - (else - (match-optional (environment/bind environment - (car optional) - (car operands)) - (cdr optional) - (cdr operands))))) - - (define (match-rest environment rest operands) - (cond (rest - ;; Other cases are too hairy -- don't bother. - (if (null? operands) - (environment/bind environment rest (constant/make '())) - environment)) - ((null? operands) - environment) - (else - (error "Too many operands in call to procedure" procedure)))) - - (match-required environment (procedure/required procedure) operands)) - -(define (environment/make) - '()) - -(define (environment/bind environment variable value) - (cons (cons variable value) environment)) - -(define (environment/bind-multiple environment variables values) - (map* environment cons variables values)) - -(define (environment/lookup environment variable if-found if-not) - (let ((association (assq variable environment))) - (if association - (if-found (cdr association)) - (if-not)))) - -(define (delayed-integration/in-progress? delayed-integration) - (eq? (delayed-integration/state delayed-integration) 'BEING-INTEGRATED)) - -(define (delayed-integration/force delayed-integration) - (case (delayed-integration/state delayed-integration) - ((NOT-INTEGRATED) - (let ((value - (let ((environment - (delayed-integration/environment delayed-integration)) - (operations - (delayed-integration/operations delayed-integration)) - (expression (delayed-integration/value delayed-integration))) - (delayed-integration/set-state! delayed-integration - 'BEING-INTEGRATED) - (delayed-integration/set-environment! delayed-integration false) - (delayed-integration/set-operations! delayed-integration false) - (delayed-integration/set-value! delayed-integration false) - (integrate/expression operations environment expression)))) - (delayed-integration/set-state! delayed-integration 'INTEGRATED) - (delayed-integration/set-value! delayed-integration value))) - ((INTEGRATED) 'DONE) - ((BEING-INTEGRATED) - (error "Attempt to re-force delayed integration" delayed-integration)) - (else - (error "Delayed integration has unknown state" delayed-integration))) - (delayed-integration/value delayed-integration)) - -;;;; Optimizations - -(define combination/optimizing-make) -(let () - -(set! combination/optimizing-make - (lambda (operator operands) - (if (and (procedure? operator) - (null? (procedure/optional operator)) - (not (procedure/rest operator)) - (block/safe? (procedure/block operator)) - (not (open-block? (procedure/body operator)))) - ;; Simple LET-like combination. Delete any unreferenced - ;; parameters. If no parameters remain, delete the - ;; combination and lambda. - (let ((body (procedure/body operator))) - (transmit-values ((delete-unused-parameters (free/expression body)) - (procedure/required operator) - operands) - (lambda (required operands) - (if (null? required) - body - (combination/make (procedure/make (procedure/block operator) - (procedure/name operator) - required '() false body) - operands))))) - (combination/make operator operands)))) - -(define (delete-unused-parameters referenced) - (define (loop parameters operands) - (if (null? parameters) - (return-2 '() operands) - (let ((rest (loop (cdr parameters) (cdr operands)))) - (if (memq (car parameters) referenced) - (transmit-values rest - (lambda (parameters* operands*) - (return-2 (cons (car parameters) parameters*) - (cons (car operands) operands*)))) - rest)))) - loop) - -;;; end COMBINATION/OPTIMIZING-MAKE -) - -#| This is too much of a pain to do now. Maybe later. - -(define procedure/optimizing-make) -(let () - -(set! procedure/optimizing-make - (lambda (block name required optional rest auxiliary body) - (if (and (not (null? auxiliary)) - optimize-open-blocks? - (block/safe? block)) - (let ((used - (used-auxiliaries (list-transform-positive auxiliary - variable-value) - (free/expression body)))) - (procedure/make block name required optional rest used - (delete-unused-definitions used body))) - (procedure/make block name required optional rest auxiliary body)))) - -(define (delete-unused-definitions used body) - ???) - -;;; A non-obvious program: (1) Collect all of the free references to -;;; the block's bound variables which occur in the body of the block. -;;; (2) Examine each of the values associated with that set of free -;;; references, and add any new free references to the collection. -;;; (3) Continue looping until no more free references are added. - -(define (used-auxiliaries auxiliary initial-used) - (let ((used (eq?-set/intersection auxiliary initial-used))) - (if (null? used) - '() - (let loop ((previous-used used) (new-used used)) - (for-each (lambda (value) - (for-each (lambda (variable) - (if (and (memq variable auxiliary) - (not (memq variable used))) - (set! used (cons variable used)))) - (free/expression value))) - (map variable/value new-used)) - (let ((diffs - (let note-diffs ((used used)) - (if (eq? used previous-used) - '() - (cons (cdar used) - (note-diffs (cdr used))))))) - (if (null? diffs) - used - (loop used diffs))))))) - -;;; end PROCEDURE/OPTIMIZING-MAKE -) -|# \ No newline at end of file diff --git a/v7/src/sf/tables.scm b/v7/src/sf/tables.scm deleted file mode 100644 index 50de2dbbd..000000000 --- a/v7/src/sf/tables.scm +++ /dev/null @@ -1,89 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/tables.scm,v 3.1 1987/03/13 04:14:10 cph Rel $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; SCode Optimizer: Tables - -(declare (usual-integrations)) - -;;;; Operations - -(define (operations/make) - (cons '() '())) - -(define (operations/lookup operations variable if-found if-not) - (let ((entry (assq variable (car operations))) - (finish - (lambda (entry) - (if-found (vector-ref (cdr entry) 1) - (vector-ref (cdr entry) 2))))) - (if entry - (if (cdr entry) (finish entry) (if-not)) - (let ((entry (assq (variable/name variable) (cdr operations)))) - (if entry (finish entry) (if-not)))))) - -(define (operations/shadow operations variables) - (cons (map* (car operations) - (lambda (variable) (cons variable false)) - variables) - (cdr operations))) - -(define (operations/bind-global operations operation export? names values) - (cons (car operations) - (map* (cdr operations) - (lambda (name value) - (cons name (vector export? operation value))) - names values))) - -(define (operations/bind operations operation export? names values) - (cons (let ((make-binding - (lambda (name value) - (cons name (vector export? operation value))))) - (if (eq? values 'NO-VALUES) - (map* (car operations) - (lambda (name) (make-binding name false)) - names) - (map* (car operations) make-binding names values))) - (cdr operations))) - -(define (operations/extract-external operations procedure) - (let loop ((elements (car operations))) - (if (null? elements) - '() - (let ((value (cdar elements)) (rest (loop (cdr elements)))) - (if (and value (vector-ref value 0)) - (procedure (caar elements) (vector-ref value 1) - (vector-ref value 2) - (lambda (value) (cons value rest)) - (lambda () rest)) - rest))))) \ No newline at end of file diff --git a/v7/src/sf/toplev.scm b/v7/src/sf/toplev.scm deleted file mode 100644 index 69f9c38f3..000000000 --- a/v7/src/sf/toplev.scm +++ /dev/null @@ -1,355 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 3.2 1987/03/19 17:23:08 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; SCode Optimizer: Top Level - -(declare (usual-integrations)) - -;;;; User Interface - -(define generate-unfasl-files? false - "Set this non-false to cause unfasl files to be generated by default.") - -(define optimize-open-blocks? false - "Set this non-false to eliminate unreferenced auxiliary definitions. -Currently this optimization is not implemented.") - -(define (integrate/procedure procedure declarations) - (if (compound-procedure? procedure) - (procedure-components procedure - (lambda (*lambda environment) - (scode-eval (integrate/scode *lambda declarations false) - environment))) - (error "INTEGRATE/PROCEDURE: Not a compound procedure" procedure))) - -(define (integrate/sexp s-expression syntax-table declarations receiver) - (integrate/simple (lambda (s-expressions) - (phase:syntax s-expressions syntax-table)) - (list s-expression) declarations receiver)) - -(define (integrate/scode scode declarations receiver) - (integrate/simple identity-procedure scode declarations receiver)) - -(define (sf input-string #!optional bin-string spec-string) - (if (unassigned? bin-string) (set! bin-string false)) - (if (unassigned? spec-string) (set! spec-string false)) - (syntax-file input-string bin-string spec-string)) - -(define (scold input-string #!optional bin-string spec-string) - "Use this only for syntaxing the cold-load root file. -Currently only the 68000 implementation needs this." - (if (unassigned? bin-string) (set! bin-string false)) - (if (unassigned? spec-string) (set! spec-string false)) - (fluid-let ((wrapping-hook wrap-with-control-point)) - (syntax-file input-string bin-string spec-string))) - -(define (sf/set-file-syntax-table! pathname syntax-table) - (let ((pathname (pathname->absolute-pathname (->pathname pathname)))) - (let ((association (find-file-info/assoc pathname))) - (if association - (set-cdr! association - (transmit-values (cdr association) - (lambda (ignore declarations) - (return-2 syntax-table declarations)))) - (set! file-info - (cons (cons pathname (return-2 syntax-table '())) - file-info)))))) - -(define (sf/add-file-declarations! pathname declarations) - (let ((pathname (pathname->absolute-pathname (->pathname pathname)))) - (let ((association (find-file-info/assoc pathname))) - (if association - (set-cdr! association - (transmit-values (cdr association) - (lambda (syntax-table declarations*) - (return-2 syntax-table - (append! declarations* - (list-copy declarations)))))) - (set! file-info - (cons (cons pathname (return-2 false declarations)) - file-info)))))) - -(define file-info - '()) - -(define (find-file-info pathname) - (let ((association - (find-file-info/assoc (pathname->absolute-pathname pathname)))) - (if association - (cdr association) - (return-2 false '())))) - -(define (find-file-info/assoc pathname) - (list-search-positive file-info - (lambda (entry) - (pathname=? (car entry) pathname)))) - -(define (pathname=? x y) - (and (equal? (pathname-device x) (pathname-device y)) - (equal? (pathname-directory x) (pathname-directory y)) - (equal? (pathname-name x) (pathname-name y)))) - -;;;; File Syntaxer - -(define sf/default-input-pathname - (make-pathname false false false "scm" 'NEWEST)) - -(define sf/default-externs-pathname - (make-pathname false false false "ext" 'NEWEST)) - -(define sf/output-pathname-type "bin") -(define sf/unfasl-pathname-type "unf") - -(define (syntax-file input-string bin-string spec-string) - (let ((eval-sf-expression - (lambda (input-string) - (let ((input-path - (pathname->input-truename - (merge-pathnames (->pathname input-string) - sf/default-input-pathname)))) - (if (not input-path) - (error "SF: File does not exist" input-string)) - (let ((bin-path - (let ((bin-path - (pathname-new-type input-path - sf/output-pathname-type))) - (if bin-string - (merge-pathnames (->pathname bin-string) bin-path) - bin-path)))) - (let ((spec-path - (and (or spec-string generate-unfasl-files?) - (let ((spec-path - (pathname-new-type bin-path - sf/unfasl-pathname-type))) - (if spec-string - (merge-pathnames (->pathname spec-string) - spec-path) - spec-path))))) - (syntax-file* input-path bin-path spec-path))))))) - (if (list? input-string) - (for-each (lambda (input-string) - (eval-sf-expression input-string)) - input-string) - (eval-sf-expression input-string))) - *the-non-printing-object*) - -(define (syntax-file* input-pathname bin-pathname spec-pathname) - (let ((start-date (date)) - (start-time (time)) - (input-filename (pathname->string input-pathname)) - (bin-filename (pathname->string bin-pathname)) - (spec-filename (and spec-pathname (pathname->string spec-pathname)))) - (newline) - (write-string "Syntax file: ") - (write input-filename) - (write-string " ") - (write bin-filename) - (write-string " ") - (write spec-filename) - (transmit-values - (transmit-values (find-file-info input-pathname) - (lambda (syntax-table declarations) - (integrate/file input-pathname syntax-table declarations - spec-pathname))) - (lambda (expression externs events) - (fasdump (wrapping-hook - (make-comment `((SOURCE-FILE . ,input-filename) - (DATE . ,start-date) - (TIME . ,start-time) - (FLUID-LET . ,*fluid-let-type*)) - (set! expression false))) - bin-pathname) - (write-externs-file (pathname-new-type - bin-pathname - (pathname-type sf/default-externs-pathname)) - (set! externs false)) - (if spec-pathname - (begin (newline) - (write-string "Writing ") - (write spec-filename) - (with-output-to-file spec-pathname - (lambda () - (newline) - (write `(DATE ,start-date ,start-time)) - (newline) - (write `(FLUID-LET ,*fluid-let-type*)) - (newline) - (write `(SOURCE-FILE ,input-filename)) - (newline) - (write `(BINARY-FILE ,bin-filename)) - (for-each (lambda (event) - (newline) - (write `(,(car event) - (RUNTIME ,(cdr event))))) - events))) - (write-string " -- done"))))))) - -(define (read-externs-file pathname) - (let ((pathname - (merge-pathnames (->pathname pathname) sf/default-externs-pathname))) - (if (file-exists? pathname) - (fasload pathname) - (begin (warn "Nonexistent externs file" (pathname->string pathname)) - '())))) - -(define (write-externs-file pathname externs) - (cond ((not (null? externs)) - (fasdump externs pathname)) - ((file-exists? pathname) - (delete-file pathname)))) - -(define (print-spec identifier names) - (newline) - (newline) - (write-string "(") - (write identifier) - (let loop - ((names - (sort names - (lambda (x y) - (stringstring x) - (symbol->string y)))))) - (if (not (null? names)) - (begin (newline) - (write (car names)) - (loop (cdr names))))) - (write-string ")")) - -(define (wrapping-hook scode) - scode) - -(define control-point-tail - `(3 ,(primitive-set-type (microcode-type 'NULL) (* 4 4)) - () () () () () () () () () () () () () () ())) - -(define (wrap-with-control-point scode) - (system-list-to-vector type-code-control-point - `(,return-address-restart-execution - ,scode - ,system-global-environment - ,return-address-non-existent-continuation - ,@control-point-tail))) - -(define type-code-control-point - (microcode-type 'CONTROL-POINT)) - -(define return-address-restart-execution - (make-return-address (microcode-return 'RESTART-EXECUTION))) - -(define return-address-non-existent-continuation - (make-return-address (microcode-return 'NON-EXISTENT-CONTINUATION))) - -;;;; Optimizer Top Level - -(define (integrate/file file-name syntax-table declarations compute-free?) - (integrate/kernel (lambda () - (phase:syntax (phase:read file-name) syntax-table)) - declarations)) - -(define (integrate/simple preprocessor input declarations receiver) - (transmit-values - (integrate/kernel (lambda () (preprocessor input)) declarations) - (or receiver - (lambda (expression externs events) - expression)))) - -(define (integrate/kernel get-scode declarations) - (fluid-let ((previous-time false) - (previous-name false) - (events '())) - (transmit-values - (transmit-values - (transmit-values - (phase:transform (canonicalize-scode (get-scode) declarations)) - phase:optimize) - phase:generate-scode) - (lambda (externs expression) - (end-phase) - (return-3 expression externs (reverse! events)))))) - -(define (canonicalize-scode scode declarations) - (let ((declarations - ((access process-declarations syntaxer-package) declarations))) - (if (null? declarations) - scode - (scan-defines (make-sequence - (list (make-block-declaration declarations) - scode)) - make-open-block)))) - -(define (phase:read filename) - (mark-phase "Read") - (read-file filename)) - -(define (phase:syntax s-expression #!optional syntax-table) - (if (or (unassigned? syntax-table) (not syntax-table)) - (set! syntax-table (make-syntax-table system-global-syntax-table))) - (mark-phase "Syntax") - (syntax* s-expression syntax-table)) - -(define (phase:transform scode) - (mark-phase "Transform") - (transform/expression scode)) - -(define (phase:optimize block expression) - (mark-phase "Optimize") - (integrate/expression block expression)) - -(define (phase:generate-scode operations environment expression) - (mark-phase "Generate SCode") - (return-2 (operations->external operations environment) - (cgen/expression expression))) - -(define previous-time) -(define previous-name) -(define events) - -(define (mark-phase this-name) - (end-phase) - (newline) - (write-string " ") - (write-string this-name) - (write-string "...") - (set! previous-name this-name)) - -(define (end-phase) - (let ((this-time (runtime))) - (if previous-time - (let ((dt (- this-time previous-time))) - (set! events (cons (cons previous-name dt) events)) - (newline) - (write-string " Time: ") - (write dt) - (write-string " seconds."))) - (set! previous-time this-time))) \ No newline at end of file diff --git a/v7/src/sf/usicon.scm b/v7/src/sf/usicon.scm deleted file mode 100644 index 6d475e222..000000000 --- a/v7/src/sf/usicon.scm +++ /dev/null @@ -1,60 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usicon.scm,v 3.1 1987/03/13 04:14:39 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; SCode Optimizer: Usual Integrations: Constants - -(declare (usual-integrations)) - -(define usual-integrations/constant-names) -(define usual-integrations/constant-values) - -(define (usual-integrations/delete-constant! name) - (set! global-constant-objects (delq! name global-constant-objects)) - (usual-integrations/cache!)) - -(define (usual-integrations/cache!) - (set! usual-integrations/constant-names - (list-copy global-constant-objects)) - (set! usual-integrations/constant-values - (map (lambda (name) - (let ((object - (lexical-reference system-global-environment name))) - (if (not (scode-constant? object)) - (error "USUAL-INTEGRATIONS: not a constant" name)) - (constant->integration-info object))) - usual-integrations/constant-names)) - 'DONE) - -(define (constant->integration-info constant) - (return-2 (constant/make constant) '())) \ No newline at end of file diff --git a/v7/src/sf/usiexp.scm b/v7/src/sf/usiexp.scm deleted file mode 100644 index d9ced17da..000000000 --- a/v7/src/sf/usiexp.scm +++ /dev/null @@ -1,307 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usiexp.scm,v 3.0 1987/03/10 13:25:31 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; SCode Optimizer: Usual Integrations: Combination Expansions - -(declare (usual-integrations)) - -;;;; N-ary Arithmetic Predicates - -(define (make-combination primitive operands) - (combination/make (constant/make primitive) operands)) - -(define (constant-eq? expression constant) - (and (constant? expression) - (eq? (constant/value expression) constant))) - -(define (pairwise-test binary-predicate if-left-zero if-right-zero) - (lambda (operands if-expanded if-not-expanded) - (cond ((or (null? operands) - (null? (cdr operands))) - (error "Too few operands" operands)) - ((null? (cddr operands)) - (if-expanded - (cond ((constant-eq? (car operands) 0) - (make-combination if-left-zero (list (cadr operands)))) - ((constant-eq? (cadr operands) 0) - (make-combination if-right-zero (list (car operands)))) - (else - (make-combination binary-predicate operands))))) - (else - (if-not-expanded))))) - -(define (pairwise-test-inverse inverse-expansion) - (lambda (operands if-expanded if-not-expanded) - (inverse-expansion operands - (lambda (expression) - (if-expanded (make-combination not (list expression)))) - if-not-expanded))) - -(define =-expansion - (pairwise-test (make-primitive-procedure '&=) zero? zero?)) - -(define <-expansion - (pairwise-test (make-primitive-procedure '&<) positive? negative?)) - -(define >-expansion - (pairwise-test (make-primitive-procedure '&>) negative? positive?)) - -(define <=-expansion - (pairwise-test-inverse >-expansion)) - -(define >=-expansion - (pairwise-test-inverse <-expansion)) - -;;;; N-ary Arithmetic Field Operations - -(define (right-accumulation identity make-binary) - (lambda (operands if-expanded if-not-expanded) - (let ((operands (delq identity operands))) - (let ((n (length operands))) - (cond ((zero? n) - (if-expanded (constant/make identity))) - ((< n 5) - (if-expanded - (let loop - ((first (car operands)) - (rest (cdr operands))) - (if (null? rest) - first - (make-binary first - (loop (car rest) (cdr rest))))))) - (else - (if-not-expanded))))))) - -(define +-expansion - (right-accumulation 0 - (let ((&+ (make-primitive-procedure '&+))) - (lambda (x y) - (cond ((constant-eq? x 1) (make-combination 1+ (list y))) - ((constant-eq? y 1) (make-combination 1+ (list x))) - (else (make-combination &+ (list x y)))))))) - -(define *-expansion - (right-accumulation 1 - (let ((&* (make-primitive-procedure '&*))) - (lambda (x y) - (make-combination &* (list x y)))))) - -(define (right-accumulation-inverse identity inverse-expansion make-binary) - (lambda (operands if-expanded if-not-expanded) - (let ((expand - (lambda (x y) - (if-expanded - (if (constant-eq? y identity) - x - (make-binary x y)))))) - (cond ((null? operands) - (error "Too few operands")) - ((null? (cdr operands)) - (expand (constant/make identity) (car operands))) - (else - (inverse-expansion (cdr operands) - (lambda (expression) - (expand (car operands) expression)) - if-not-expanded)))))) - -(define --expansion - (right-accumulation-inverse 0 +-expansion - (let ((&- (make-primitive-procedure '&-))) - (lambda (x y) - (if (constant-eq? y 1) - (make-combination -1+ (list x)) - (make-combination &- (list x y))))))) - -(define /-expansion - (right-accumulation-inverse 1 *-expansion - (let ((&/ (make-primitive-procedure '&/))) - (lambda (x y) - (make-combination &/ (list x y)))))) - -;;;; Miscellaneous Arithmetic - -(define (divide-component-expansion selector) - (lambda (operands if-expanded if-not-expanded) - (if-expanded - (make-combination selector - (list (make-combination integer-divide operands)))))) - -(define quotient-expansion - (divide-component-expansion car)) - -(define remainder-expansion - (divide-component-expansion cdr)) - -;;;; N-ary List Operations - -(define apply*-expansion - (let ((apply-primitive (make-primitive-procedure 'APPLY))) - (lambda (operands if-expanded if-not-expanded) - (let ((n (length operands))) - (cond ((< n 2) (error "APPLY*-EXPANSION: Too few arguments" n)) - ((< n 10) - (if-expanded - (make-combination - apply-primitive - (list (car operands) - (cons*-expansion-loop (cdr operands)))))) - (else (if-not-expanded))))))) - -(define (cons*-expansion operands if-expanded if-not-expanded) - (let ((n (length operands))) - (cond ((zero? n) (error "CONS*-EXPANSION: No arguments!")) - ((< n 9) (if-expanded (cons*-expansion-loop operands))) - (else (if-not-expanded))))) - -(define (cons*-expansion-loop rest) - (if (null? (cdr rest)) - (car rest) - (make-combination cons - (list (car rest) - (cons*-expansion-loop (cdr rest)))))) - -(define (list-expansion operands if-expanded if-not-expanded) - (if (< (length operands) 9) - (if-expanded (list-expansion-loop operands)) - (if-not-expanded))) - -(define (vector-expansion operands if-expanded if-not-expanded) - (if (< (length operands) 9) - (if-expanded (make-combination list->vector - (list (list-expansion-loop operands)))) - (if-not-expanded))) - -(define (list-expansion-loop rest) - (if (null? rest) - (constant/make '()) - (make-combination cons - (list (car rest) - (list-expansion-loop (cdr rest)))))) - -;;;; General CAR/CDR Encodings - -(define (general-car-cdr-expansion encoding) - (lambda (operands if-expanded if-not-expanded) - (if (= (length operands) 1) - (if-expanded - (make-combination general-car-cdr - (list (car operands) - (constant/make encoding)))) - (error "Wrong number of arguments" (length operands))))) - -(define caar-expansion (general-car-cdr-expansion #b111)) -(define cadr-expansion (general-car-cdr-expansion #b110)) -(define cdar-expansion (general-car-cdr-expansion #b101)) -(define cddr-expansion (general-car-cdr-expansion #b100)) - -(define caaar-expansion (general-car-cdr-expansion #b1111)) -(define caadr-expansion (general-car-cdr-expansion #b1110)) -(define cadar-expansion (general-car-cdr-expansion #b1101)) -(define caddr-expansion (general-car-cdr-expansion #b1100)) -(define cdaar-expansion (general-car-cdr-expansion #b1011)) -(define cdadr-expansion (general-car-cdr-expansion #b1010)) -(define cddar-expansion (general-car-cdr-expansion #b1001)) -(define cdddr-expansion (general-car-cdr-expansion #b1000)) - -(define caaaar-expansion (general-car-cdr-expansion #b11111)) -(define caaadr-expansion (general-car-cdr-expansion #b11110)) -(define caadar-expansion (general-car-cdr-expansion #b11101)) -(define caaddr-expansion (general-car-cdr-expansion #b11100)) -(define cadaar-expansion (general-car-cdr-expansion #b11011)) -(define cadadr-expansion (general-car-cdr-expansion #b11010)) -(define caddar-expansion (general-car-cdr-expansion #b11001)) -(define cadddr-expansion (general-car-cdr-expansion #b11000)) -(define cdaaar-expansion (general-car-cdr-expansion #b10111)) -(define cdaadr-expansion (general-car-cdr-expansion #b10110)) -(define cdadar-expansion (general-car-cdr-expansion #b10101)) -(define cdaddr-expansion (general-car-cdr-expansion #b10100)) -(define cddaar-expansion (general-car-cdr-expansion #b10011)) -(define cddadr-expansion (general-car-cdr-expansion #b10010)) -(define cdddar-expansion (general-car-cdr-expansion #b10001)) -(define cddddr-expansion (general-car-cdr-expansion #b10000)) - -(define second-expansion cadr-expansion) -(define third-expansion caddr-expansion) -(define fourth-expansion cadddr-expansion) -(define fifth-expansion (general-car-cdr-expansion #b110000)) -(define sixth-expansion (general-car-cdr-expansion #b1100000)) -(define seventh-expansion (general-car-cdr-expansion #b11000000)) -(define eighth-expansion (general-car-cdr-expansion #b110000000)) - -;;;; Miscellaneous - -(define (make-string-expansion operands if-expanded if-not-expanded) - (let ((n (length operands))) - (cond ((zero? n) - (error "MAKE-STRING-EXPANSION: No arguments")) - ((= n 1) - (if-expanded (make-combination string-allocate operands))) - (else - (if-not-expanded))))) - -(define (identity-procedure-expansion operands if-expanded if-not-expanded) - (if (not (= (length operands) 1)) - (error "IDENTITY-PROCEDURE-EXPANSION: wrong number of arguments" - (length operands))) - (if-expanded (car operands))) - -;;;; Tables - -(define usual-integrations/expansion-names - '(= < > <= >= + - * / quotient remainder - apply cons* list vector - caar cadr cdar cddr - caaar caadr cadar caddr cdaar cdadr cddar cdddr - caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr - cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr - second third fourth fifth sixth seventh eighth - make-string identity-procedure - )) - -(define usual-integrations/expansion-values - (list =-expansion <-expansion >-expansion <=-expansion >=-expansion - +-expansion --expansion *-expansion /-expansion - quotient-expansion remainder-expansion - apply*-expansion cons*-expansion list-expansion vector-expansion - caar-expansion cadr-expansion cdar-expansion cddr-expansion - caaar-expansion caadr-expansion cadar-expansion caddr-expansion - cdaar-expansion cdadr-expansion cddar-expansion cdddr-expansion - caaaar-expansion caaadr-expansion caadar-expansion caaddr-expansion - cadaar-expansion cadadr-expansion caddar-expansion cadddr-expansion - cdaaar-expansion cdaadr-expansion cdadar-expansion cdaddr-expansion - cddaar-expansion cddadr-expansion cdddar-expansion cddddr-expansion - second-expansion third-expansion fourth-expansion fifth-expansion - sixth-expansion seventh-expansion eighth-expansion - make-string-expansion identity-procedure-expansion - usual-integrations/expansion-values)) \ No newline at end of file diff --git a/v7/src/sf/xform.scm b/v7/src/sf/xform.scm deleted file mode 100644 index 70bf91727..000000000 --- a/v7/src/sf/xform.scm +++ /dev/null @@ -1,265 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/xform.scm,v 3.3 1987/03/20 23:49:46 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; SCode Optimizer: Transform Input Expression - -(declare (usual-integrations)) - -;;; GLOBAL-BLOCK is used to handle (USUAL-INTEGRATIONS), as follows. -;;; This declaration refers to a large group of names, which are -;;; normally defined in the global environment. Names in this group -;;; are supposed to be shadowed by top-level definitions in the user's -;;; program. - -;;; Normally we would intern the variable objects corresponding to -;;; those names in the block corresponding to the outermost -;;; environment in the user's program. However, if the user had a -;;; top-level definition which was intended to shadow one of those -;;; names, both the definition and the declaration would refer to the -;;; same variable object. So, instead we intern them in GLOBAL-BLOCK, -;;; which never has any user defined names in it. - -(define (transform/top-level expression) - (let ((block (block/make (block/make false false) false))) - (return-2 block (transform/top-level-1 block expression)))) - -(define (transform/top-level-1 block expression) - (fluid-let ((global-block - (let block/global-parent ((block block)) - (if (block/parent block) - (block/global-parent (block/parent block)) - block)))) - (let ((environment (environment/make))) - (if (scode-open-block? expression) - (open-block-components expression - (transform/open-block* block environment)) - (transform/expression block environment expression))))) - -(define (transform/expressions block environment expressions) - (map (lambda (expression) - (transform/expression block environment expression)) - expressions)) - -(define (transform/expression block environment expression) - ((transform/dispatch expression) block environment expression)) - -(define global-block) - -(define (environment/make) - '()) - -(define (environment/lookup environment name) - (let ((association (assq name environment))) - (if association - (cdr association) - (block/lookup-name global-block name)))) - -(define (environment/bind environment variables) - (map* environment - (lambda (variable) - (cons (variable/name variable) variable)) - variables)) - -(define (transform/open-block block environment expression) - (open-block-components expression - (transform/open-block* (block/make block true) environment))) - -(define ((transform/open-block* block environment) auxiliary declarations body) - (let ((variables (map (lambda (name) (variable/make block name)) auxiliary))) - (block/set-bound-variables! block - (append (block/bound-variables block) - variables)) - (block/set-declarations! block (declarations/parse block declarations)) - (let ((environment (environment/bind environment variables))) - - (define (loop variables actions) - (cond ((null? variables) - (return-2 '() (map transform actions))) - ((null? actions) - (error "Extraneous auxiliaries" variables)) - - ;; Because `scan-defines' returns the auxiliary names in a - ;; particular order, we can expect to encounter them in that - ;; same order when looking through the body's actions. - - ((and (scode-assignment? (car actions)) - (eq? (assignment-name (car actions)) - (variable/name (car variables)))) - (transmit-values (loop (cdr variables) (cdr actions)) - (lambda (values actions*) - (return-2 - (cons (transform (assignment-value (car actions))) values) - (cons open-block/value-marker actions*))))) - (else - (transmit-values (loop variables (cdr actions)) - (lambda (values actions*) - (return-2 values - (cons (transform (car actions)) actions*))))))) - - (define (transform subexpression) - (transform/expression block environment subexpression)) - - (transmit-values (loop variables (sequence-actions body)) - (lambda (values actions) - (open-block/make block variables values actions)))))) - -(define (transform/variable block environment expression) - (reference/make block - (environment/lookup environment (variable-name expression)))) - -(define (transform/assignment block environment expression) - (assignment-components expression - (lambda (name value) - (assignment/make block - (environment/lookup environment name) - (transform/expression block environment value))))) - -(define (transform/lambda block environment expression) - (lambda-components* expression - (lambda (name required optional rest body) - (let ((block (block/make block true))) - (transmit-values - (let ((name->variable (lambda (name) (variable/make block name)))) - (return-3 (map name->variable required) - (map name->variable optional) - (and rest (name->variable rest)))) - (lambda (required optional rest) - (let ((bound `(,@required ,@optional ,@(if rest `(,rest) '())))) - (block/set-bound-variables! block bound) - (procedure/make - block name required optional rest - (transform/procedure-body block - (environment/bind environment bound) - body))))))))) - -(define (transform/procedure-body block environment expression) - (if (scode-open-block? expression) - (open-block-components expression - (lambda (auxiliary declarations body) - (if (null? auxiliary) - (begin (block/set-declarations! - block - (declarations/parse block declarations)) - (transform/expression block environment body)) - (transform/open-block block environment expression)))) - (transform/expression block environment expression))) - -(define (transform/definition block environment expression) - (definition-components expression - (lambda (name value) - (error "Unscanned definition encountered. Unable to proceed." name)))) - -(define (transform/access block environment expression) - (access-components expression - (lambda (environment* name) - (access/make (transform/expression block environment environment*) - name)))) - -(define (transform/combination block environment expression) - (combination-components expression - (lambda (operator operands) - (combination/make (transform/expression block environment operator) - (transform/expressions block environment operands))))) - -(define (transform/comment block environment expression) - (transform/expression block (comment-expression environment expression))) - -(define (transform/conditional block environment expression) - (conditional-components expression - (lambda (predicate consequent alternative) - (conditional/make - (transform/expression block environment predicate) - (transform/expression block environment consequent) - (transform/expression block environment alternative))))) - -(define (transform/constant block environment expression) - (constant/make expression)) - -(define (transform/declaration block environment expression) - (declaration-components expression - (lambda (declarations expression) - (declaration/make (declarations/parse block declarations) - (transform/expression block environment expression))))) - -(define (transform/delay block environment expression) - (delay/make - (transform/expression block environment (delay-expression expression)))) - -(define (transform/disjunction block environment expression) - (disjunction-components expression - (lambda (predicate alternative) - (disjunction/make - (transform/expression block environment predicate) - (transform/expression block environment alternative))))) - -(define (transform/in-package block environment expression) - (in-package-components expression - (lambda (environment* expression) - (in-package/make (transform/expression block environment environment*) - (transform/quotation* expression))))) - -(define (transform/quotation block environment expression) - (transform/quotation* (quotation-expression expression))) - -(define (transform/quotation* expression) - (transmit-values (transform/top-level expression) - quotation/make)) - -(define (transform/sequence block environment expression) - (sequence/make - (transform/expressions block environment (sequence-actions expression)))) - -(define (transform/the-environment block environment expression) - (block/unsafe! block) - (the-environment/make block)) - -(define transform/dispatch - (make-type-dispatcher - `((,access-type ,transform/access) - (,assignment-type ,transform/assignment) - (,combination-type ,transform/combination) - (,comment-type ,transform/comment) - (,conditional-type ,transform/conditional) - (,declaration-type ,transform/declaration) - (,definition-type ,transform/definition) - (,delay-type ,transform/delay) - (,disjunction-type ,transform/disjunction) - (,in-package-type ,transform/in-package) - (,lambda-type ,transform/lambda) - (,open-block-type ,transform/open-block) - (,quotation-type ,transform/quotation) - (,sequence-type ,transform/sequence) - (,the-environment-type ,transform/the-environment) - (,variable-type ,transform/variable)) - transform/constant)) \ No newline at end of file diff --git a/v8/src/microcode/bintopsb.c b/v8/src/microcode/bintopsb.c deleted file mode 100644 index db968577e..000000000 --- a/v8/src/microcode/bintopsb.c +++ /dev/null @@ -1,838 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.25 1987/04/16 15:30:25 jinx Exp $ - * - * This File contains the code to translate internal format binary - * files to portable format. - * - */ - -/* Cheap renames */ - -#define Internal_File Input_File -#define Portable_File Output_File - -#include "translate.h" -#include "trap.h" - -static Boolean Shuffle_Bytes = false; -static Boolean upgrade_traps = false; - -static Pointer *Mem_Base; -static long Heap_Relocation, Constant_Relocation; -static long Free, Scan, Free_Constant, Scan_Constant; -static long Objects, Constant_Objects; -static long NFlonums, NIntegers, NStrings; -static long NBits, NChars; -static Pointer *Free_Objects, *Free_Cobjects; - -Load_Data(Count, To_Where) -long Count; -char *To_Where; -{ fread(To_Where, sizeof(Pointer), Count, Internal_File); -} - -#define Reloc_or_Load_Debug false - -#include "load.c" - -/* Utility macros and procedures - Pointer Objects handled specially in the portable format. -*/ - -#ifndef isalpha -/* Just in case the stdio library atypically contains the character - macros, just like the C book claims. */ -#include -#endif - -#ifndef ispunct -/* This is in some libraries but not others */ -static char punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!"; - -Boolean ispunct(c) -fast char c; -{ fast char *s = &punctuation[0]; - while (*s != '\0') if (*s++ == c) return true; - return false; -} -#endif - -#define OUT(s) \ -fprintf(Portable_File, s); \ -break - -void -print_a_char(c, name) - fast char c; - char *name; -{ - switch(c) - { case '\n': OUT("\\n"); - case '\t': OUT("\\t"); - case '\b': OUT("\\b"); - case '\r': OUT("\\r"); - case '\f': OUT("\\f"); - case '\\': OUT("\\\\"); - case '\0': OUT("\\0"); - case ' ' : OUT(" "); - default: - if ((isalpha(c)) || (isdigit(c)) || (ispunct(c))) - putc(c, Portable_File); - else - { fprintf(stderr, - "%s: %s: File may not be portable: c = 0x%x\n", - Program_Name, name, ((int) c)); - /* This does not follow C conventions, but eliminates ambiguity */ - fprintf(Portable_File, "\X%x ", ((int) c)); - } - } -} - -#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \ -{ \ - Old_Address += (Rel); \ - Old_Contents = *Old_Address; \ - if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ - Mem_Base[(Scn)] = \ - Make_New_Pointer((Code), Old_Contents); \ - else \ - { \ - fast long i; \ - \ - Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \ - *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \ - (Obj) += 1; \ - *(FObj)++ = Make_Non_Pointer(TC_CHARACTER_STRING, 0); \ - *(FObj)++ = Old_Contents; \ - i = Get_Integer(Old_Contents); \ - NStrings += 1; \ - NChars += pointer_to_char(i-1); \ - while(--i >= 0) \ - *(FObj)++ = *Old_Address++; \ - } \ -} - -void -print_a_string(from) - Pointer *from; -{ fast long len; - fast char *string; - long maxlen; - - maxlen = pointer_to_char((Get_Integer(*from++))-1); - len = Get_Integer(*from++); - fprintf(Portable_File, "%02x %ld %ld ", - TC_CHARACTER_STRING, - (Compact_P ? len : maxlen), - len); - string = ((char *) from); - if (Shuffle_Bytes) - { while(len > 0) - { - print_a_char(string[3], "print_a_string"); - if (len > 1) - print_a_char(string[2], "print_a_string"); - if (len > 2) - print_a_char(string[1], "print_a_string"); - if (len > 3) - print_a_char(string[0], "print_a_string"); - len -= 4; - string += 4; - } - } - else while(--len >= 0) print_a_char(*string++, "print_a_string"); - putc('\n', Portable_File); - return; -} - -void -print_a_fixnum(val) - long val; -{ - fast long size_in_bits; - fast unsigned long temp; - - temp = ((val < 0) ? -val : val); - for (size_in_bits = 0; temp != 0; size_in_bits += 1) - temp = temp >> 1; - fprintf(Portable_File, "%02x %c ", - TC_FIXNUM, - (val < 0 ? '-' : '+')); - if (val == 0) - fprintf(Portable_File, "0\n"); - else - { - fprintf(Portable_File, "%ld ", size_in_bits); - temp = ((val < 0) ? -val : val); - while (temp != 0) - { fprintf(Portable_File, "%01lx", (temp % 16)); - temp = temp >> 4; - } - fprintf(Portable_File, "\n"); - } - return; -} - -#define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj) \ -{ Old_Address += (Rel); \ - Old_Contents = *Old_Address; \ - if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ - Mem_Base[(Scn)] = \ - Make_New_Pointer((Code), Old_Contents); \ - else \ - { fast long length; \ - Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \ - NIntegers += 1; \ - NBits += bignum_to_bits(LEN(BIGNUM(Old_Address))); \ - *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \ - (Obj) += 1; \ - *(FObj)++ = Make_Non_Pointer(TC_BIG_FIXNUM, 0); \ - *(FObj)++ = Old_Contents; \ - for (length = Get_Integer(Old_Contents); \ - --length >= 0; ) \ - *(FObj)++ = *Old_Address++; \ - } \ -} - -void -print_a_bignum(from) - Pointer *from; -{ - fast bigdigit *the_number, *the_top; - fast long size_in_bits; - fast unsigned long temp; /* Potential signed problems */ - - the_number = BIGNUM(from); - temp = LEN(the_number); - if (temp == 0) - fprintf(Portable_File, "%02x + 0\n", - (Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM)); - else - { fast long tail; - for (size_in_bits = ((temp - 1) * SHIFT), - temp = ((long) (*Bignum_Top(the_number))); - temp != 0; - size_in_bits += 1) - temp = temp >> 1; - - fprintf(Portable_File, "%02x %c %ld ", - (Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM), - (NEG_BIGNUM(the_number) ? '-' : '+'), - size_in_bits); - tail = size_in_bits % SHIFT; - if (tail == 0) tail = SHIFT; - temp = 0; - size_in_bits = 0; - the_top = Bignum_Top(the_number); - for(the_number = Bignum_Bottom(the_number); - the_number <= the_top; - the_number += 1) - { temp |= (((unsigned long) (*the_number)) << size_in_bits); - for (size_in_bits += ((the_number != the_top) ? SHIFT : tail); - size_in_bits > 3; - size_in_bits -= 4) - { fprintf(Portable_File, "%01lx", temp % 16); - temp = temp >> 4; - } - } - if (size_in_bits > 0) fprintf(Portable_File, "%01lx\n", temp); - else fprintf(Portable_File, "\n"); - } - return; -} - -#define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj) \ -{ Old_Address += (Rel); \ - Old_Contents = *Old_Address; \ - if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ - Mem_Base[(Scn)] = \ - Make_New_Pointer((Code), Old_Contents); \ - else \ - { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \ - Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \ - (Obj) += 1; \ - *(FObj)++ = Make_Non_Pointer(TC_BIG_FLONUM, 0); \ - *((double *) (FObj)) = *((double *) Old_Address); \ - (FObj) += float_to_pointer; \ - NFlonums += 1; \ - } \ -} - -print_a_flonum(val) -double val; -{ fast long size_in_bits; - fast double mant, temp; - int expt; - extern double frexp(); - - fprintf(Portable_File, "%02x %c ", - TC_BIG_FLONUM, - ((val < 0.0) ? '-' : '+')); - if (val == 0.0) - { fprintf(Portable_File, "0\n"); - return; - } - mant = frexp(((val < 0.0) ? -val : val), &expt); - size_in_bits = 1; - for(temp = ((mant * 2.0) - 1.0); - temp != 0; - size_in_bits += 1) - { temp *= 2.0; - if (temp >= 1.0) temp -= 1.0; - } - fprintf(Portable_File, "%ld %ld ", expt, size_in_bits); - for (size_in_bits = hex_digits(size_in_bits); - size_in_bits > 0; - size_in_bits -= 1) - { fast unsigned int digit = 0; - for (expt = 4; --expt >= 0;) - { mant *= 2.0; - digit = digit << 1; - if (mant >= 1.0) - { mant -= 1.0; - digit += 1; - } - } - fprintf(Portable_File, "%01x", digit); - } - fprintf(Portable_File, "\n"); - return; -} - -/* Normal Objects */ - -#define Do_Cell(Code, Rel, Fre, Scn, Obj, FObj) \ -{ Old_Address += (Rel); \ - Old_Contents = *Old_Address; \ - if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ - Mem_Base[(Scn)] = \ - Make_New_Pointer(Type_Code(This), Old_Contents); \ - else \ - { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \ - Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \ - Mem_Base[(Fre)++] = Old_Contents; \ - } \ -} - -#define Do_Pair(Code, Rel, Fre, Scn, Obj, FObj) \ -{ Old_Address += (Rel); \ - Old_Contents = *Old_Address; \ - if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ - Mem_Base[(Scn)] = \ - Make_New_Pointer(Type_Code(This), Old_Contents); \ - else \ - { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \ - Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \ - Mem_Base[(Fre)++] = Old_Contents; \ - Mem_Base[(Fre)++] = *Old_Address++; \ - } \ -} - -#define Do_Triple(Code, Rel, Fre, Scn, Obj, FObj) \ -{ Old_Address += (Rel); \ - Old_Contents = *Old_Address; \ - if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ - Mem_Base[(Scn)] = \ - Make_New_Pointer(Type_Code(This), Old_Contents); \ - else \ - { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \ - Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \ - Mem_Base[(Fre)++] = Old_Contents; \ - Mem_Base[(Fre)++] = *Old_Address++; \ - Mem_Base[(Fre)++] = *Old_Address++; \ - } \ -} - -#define Do_Vector(Code, Rel, Fre, Scn, Obj, FObj) \ -{ Old_Address += (Rel); \ - Old_Contents = *Old_Address; \ - if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \ - Mem_Base[(Scn)] = \ - Make_New_Pointer(Type_Code(This), Old_Contents); \ - else \ - { fast long len = Get_Integer(Old_Contents); \ - *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \ - Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \ - Mem_Base[(Fre)++] = Old_Contents; \ - while (len > 0) \ - { Mem_Base[(Fre)++] = *Old_Address++; \ - len -= 1; \ - } \ - } \ -} - -/* Common Pointer Code */ - -#define Do_Pointer(Scn, Action) \ -Old_Address = Get_Pointer(This); \ -if (Datum(This) < Const_Base) \ - Action(HEAP_CODE, Heap_Relocation, Free, \ - Scn, Objects, Free_Objects) \ -else if (Datum(This) < Dumped_Constant_Top) \ -Action(CONSTANT_CODE, Constant_Relocation, Free_Constant, \ - Scn, Constant_Objects, Free_Cobjects) \ -else \ -{ fprintf(stderr, \ - "%s: File is not portable: Pointer to stack.\n", \ - Program_Name); \ - exit(1); \ -} \ -(Scn) += 1; \ -break - -/* Processing of a single area */ - -#define Do_Area(Code, Area, Bound, Obj, FObj) \ - Process_Area(Code, &Area, &Bound, &Obj, &FObj) - -Process_Area(Code, Area, Bound, Obj, FObj) -int Code; -fast long *Area, *Bound; -fast long *Obj; -fast Pointer **FObj; -{ fast Pointer This, *Old_Address, Old_Contents; - while(*Area != *Bound) - { This = Mem_Base[*Area]; - Switch_by_GC_Type(This) - { case TC_MANIFEST_NM_VECTOR: - if (Null_NMV) - { fast int i = Get_Integer(This); - *Area += 1; - for ( ; --i >= 0; *Area += 1) - Mem_Base[*Area] = NIL; - break; - } - /* else, Unknown object! */ - fprintf(stderr, "%s: File is not portable: NMH found\n", - Program_Name); - *Area += 1 + Get_Integer(This); - break; - - case TC_BROKEN_HEART: - /* [Broken Heart 0] is the cdr of fasdumped symbols. */ - if (Get_Integer(This) != 0) - { fprintf(stderr, "%s: Broken Heart found in scan.\n", - Program_Name); - exit(1); - } - *Area += 1; - break; - - case_compiled_entry_point: - fprintf(stderr, - "%s: File is not portable: Compiled code.\n", - Program_Name); - exit(1); - - case TC_FIXNUM: - NIntegers += 1; - NBits += fixnum_to_bits; - /* Fall Through */ - case TC_CHARACTER: - Process_Character: - Mem_Base[*Area] = Make_Non_Pointer(Code, *Obj); - *Obj += 1; - **FObj = This; - *FObj += 1; - /* Fall through */ - case TC_MANIFEST_SPECIAL_NM_VECTOR: - case TC_PRIMITIVE_EXTERNAL: - case_simple_Non_Pointer: - *Area += 1; - break; - - case_Cell: - Do_Pointer(*Area, Do_Cell); - - case TC_REFERENCE_TRAP: - { - long kind; - - kind = Datum(This); - - if (upgrade_traps) - { - /* It is an old UNASSIGNED object. */ - if (kind == 0) - { - Mem_Base[*Area] = UNASSIGNED_OBJECT; - *Area += 1; - break; - } - if (kind == 1) - { - Mem_Base[*Area] = UNBOUND_OBJECT; - *Area += 1; - break; - } - fprintf(stderr, - "%s: Bad old unassigned object. 0x%x.\n", - Program_Name, This); - exit(1); - } - if (kind <= TRAP_MAX_IMMEDIATE) - { - /* It is a non pointer. */ - - *Area += 1; - break; - } - } - /* Fall through */ - - case TC_WEAK_CONS: - case_Pair: - Do_Pointer(*Area, Do_Pair); - - case TC_VARIABLE: - case_Triple: - Do_Pointer(*Area, Do_Triple); - - case TC_BIG_FLONUM: - Do_Pointer(*Area, Do_Flonum); - - case TC_BIG_FIXNUM: - Do_Pointer(*Area, Do_Bignum); - - case TC_CHARACTER_STRING: - Do_Pointer(*Area, Do_String); - - case TC_ENVIRONMENT: - if (upgrade_traps) - { - fprintf(stderr, - "%s: Cannot upgrade environments.\n", - Program_Name); - exit(1); - } - /* Fall through */ - case TC_FUTURE: - case_simple_Vector: - Do_Pointer(*Area, Do_Vector); - - default: - Bad_Type: - fprintf(stderr, "%s: Unknown Type Code 0x%x found.\n", - Program_Name, Type_Code(This)); - exit(1); - } - } -} - -/* Output macros */ - -#define print_an_object(obj) \ -fprintf(Portable_File, "%02x %lx\n", \ - Type_Code(obj), Get_Integer(obj)) - -#define print_external_object(from) \ -{ switch(Type_Code(*from)) \ - { case TC_FIXNUM: \ - { long Value; \ - Sign_Extend(*from++, Value); \ - print_a_fixnum(Value); \ - break; \ - } \ - case TC_BIG_FIXNUM: \ - from += 1; \ - print_a_bignum(from); \ - from += 1 + Get_Integer(*from); \ - break; \ - case TC_CHARACTER_STRING: \ - from += 1; \ - print_a_string(from); \ - from += 1 + Get_Integer(*from); \ - break; \ - case TC_BIG_FLONUM: \ - print_a_flonum(*((double *) (from+1))); \ - from += 1 + float_to_pointer; \ - break; \ - case TC_CHARACTER: \ - fprintf(Portable_File, "%02x %03x\n", \ - TC_CHARACTER, (*from & MASK_EXTNDD_CHAR)); \ - from += 1; \ - break; \ - default: \ - fprintf(stderr, \ - "%s: Bad Object to print externally %lx\n", \ - Program_Name, *from); \ - exit(1); \ - } \ -} - -/* Debugging Aids and Consistency Checks */ - -#ifdef DEBUG - -When(what, message) -Boolean what; -char *message; -{ if (what) - { fprintf(stderr, "%s: Inconsistency: %s!\n", - Program_Name, (message)); - exit(1); - } - return; -} - -#define print_header(name, obj, format) \ -fprintf(Portable_File, (format), (obj)); \ -fprintf(stderr, "%s: ", (name)); \ -fprintf(stderr, (format), (obj)) - -#else - -#define When(what, message) - -#define print_header(name, obj, format) \ -fprintf(Portable_File, (format), (obj)) - -#endif - -/* The main program */ - -do_it() -{ Pointer *Heap; - long Initial_Free; - - /* Load the Data */ - - if (!Read_Header()) - { fprintf(stderr, - "%s: Input file does not appear to be in FASL format.\n", - Program_Name); - exit(1); - } - - if ((Version != FASL_FORMAT_VERSION) || - (Sub_Version > FASL_SUBVERSION) || - (Sub_Version < FASL_OLDEST_SUPPORTED) || - ((Machine_Type != FASL_INTERNAL_FORMAT) && (!Shuffle_Bytes))) - { fprintf(stderr, "%s:\n", Program_Name); - fprintf(stderr, - "FASL File Version %ld Subversion %ld Machine Type %ld\n", - Version, Sub_Version , Machine_Type); - fprintf(stderr, - "Expected: Version %d Subversion %d Machine Type %d\n", - FASL_FORMAT_VERSION, FASL_SUBVERSION, FASL_INTERNAL_FORMAT); - exit(1); - } - - if (Machine_Type == FASL_INTERNAL_FORMAT) - Shuffle_Bytes = false; - upgrade_traps = (Sub_Version < FASL_REFERENCE_TRAP); - - /* Constant Space not currently supported */ - - if (Const_Count != 0) - { fprintf(stderr, - "%s: Input file has a constant space area.\n", - Program_Name); - exit(1); - } - - { long Size = ((3 * (Heap_Count + Const_Count)) + NROOTS + 1); - Allocate_Heap_Space(Size + HEAP_BUFFER_SPACE); - if (Heap == NULL) - { fprintf(stderr, - "%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n", - Program_Name, Size); - exit(1); - } - } - Heap += HEAP_BUFFER_SPACE; - Initial_Align_Float(Heap); - Load_Data(Heap_Count, &Heap[0]); - Load_Data(Const_Count, &Heap[Heap_Count]); - Heap_Relocation = &Heap[0] - Get_Pointer(Heap_Base); - Constant_Relocation = &Heap[Heap_Count] - Get_Pointer(Const_Base); - -#ifdef DEBUG - fprintf(stderr, "Dumped Heap Base = 0x%08x\n", Heap_Base); - fprintf(stderr, "Dumped Constant Base = 0x%08x\n", Const_Base); - fprintf(stderr, "Dumped Constant Top = 0x%08x\n", Dumped_Constant_Top); - fprintf(stderr, "Heap Count = %6d\n", Heap_Count); - fprintf(stderr, "Constant Count = %6d\n", Const_Count); -#endif - - /* Reformat the data */ - - NFlonums = NIntegers = NStrings = NBits = NChars = 0; - Mem_Base = &Heap[Heap_Count + Const_Count]; - if (Ext_Prim_Vector == NIL) - { Mem_Base[0] = Make_Non_Pointer(TC_CELL, 2); - Mem_Base[1] = Make_New_Pointer(TC_CELL, Dumped_Object); - Mem_Base[2] = NIL; - Initial_Free = NROOTS + 1; - Scan = 1; - } - else - { Mem_Base[0] = Ext_Prim_Vector; /* Has CELL TYPE */ - Mem_Base[1] = Make_New_Pointer(TC_CELL, Dumped_Object); - Initial_Free = NROOTS; - Scan = 0; - } - Free = Initial_Free; - Free_Objects = &Mem_Base[Heap_Count + Initial_Free]; - Objects = 0; - - Free_Constant = (2 * Heap_Count) + Initial_Free; - Scan_Constant = Free_Constant; - Free_Cobjects = &Mem_Base[Const_Count + Free_Constant]; - Constant_Objects = 0; - -#if true - Do_Area(HEAP_CODE, Scan, Free, Objects, Free_Objects); -#else - /* When Constant Space finally becomes supported, - something like this must be done. */ - while (true) - { Do_Area(HEAP_CODE, Scan, Free, Objects, Free_Objects); - Do_Area(CONSTANT_CODE, Scan_Constant, - Free_Constant, Constant_Objects, Free_Cobjects); - Do_Area(PURE_CODE, Scan_Pure, Fre_Pure, Pure_Objects, Free_Pobjects); - if (Scan == Free) break; - } -#endif - - /* Consistency checks */ - - When(((Free - Initial_Free) > Heap_Count), "Free overran Heap"); - When(((Free_Objects - &Mem_Base[Initial_Free + Heap_Count]) > - Heap_Count), - "Free_Objects overran Heap Object Space"); - When(((Free_Constant - (Initial_Free + (2 * Heap_Count))) > Const_Count), - "Free_Constant overran Constant Space"); - When(((Free_Cobjects - &Mem_Base[Initial_Free + (2 * Heap_Count) + Const_Count]) > - Const_Count), - "Free_Cobjects overran Constant Object Space"); - - /* Output the data */ - - /* Header */ - - print_header("Portable Version", PORTABLE_VERSION, "%ld\n"); - print_header("Flags", Make_Flags(), "%ld\n"); - print_header("Version", FASL_FORMAT_VERSION, "%ld\n"); - print_header("Sub Version", FASL_SUBVERSION, "%ld\n"); - print_header("Heap Count", (Free - NROOTS), "%ld\n"); - print_header("Heap Base", NROOTS, "%ld\n"); - print_header("Heap Objects", Objects, "%ld\n"); - - /* Currently Constant and Pure not supported, but the header is ready */ - - print_header("Pure Count", 0, "%ld\n"); - print_header("Pure Base", Free_Constant, "%ld\n"); - print_header("Pure Objects", 0, "%ld\n"); - print_header("Constant Count", 0, "%ld\n"); - print_header("Constant Base", Free_Constant, "%ld\n"); - print_header("Constant Objects", 0, "%ld\n"); - - print_header("Number of flonums", NFlonums, "%ld\n"); - print_header("Number of integers", NIntegers, "%ld\n"); - print_header("Number of strings", NStrings, "%ld\n"); - print_header("Number of bits in integers", NBits, "%ld\n"); - print_header("Number of characters in strings", NChars, "%ld\n"); - print_header("& Dumped Object", (Get_Integer(Mem_Base[1])), "%ld\n"); - print_header("& Ext Prim Vector", (Get_Integer(Mem_Base[0])), "%ld\n"); - - /* External Objects */ - - /* Heap External Objects */ - - Free_Objects = &Mem_Base[Initial_Free + Heap_Count]; - for (; Objects > 0; Objects -= 1) - print_external_object(Free_Objects); - -#if false - /* Pure External Objects */ - - Free_Cobjects = &Mem_Base[Pure_Objects_Start]; - for (; Pure_Objects > 0; Pure_Objects -= 1) - print_external_object(Free_Cobjects); - - /* Constant External Objects */ - - Free_Cobjects = &Mem_Base[Constant_Objects_Start]; - for (; Constant_Objects > 0; Constant_Objects -= 1) - print_external_object(Free_Cobjects); - -#endif - - /* Pointer Objects */ - - /* Heap Objects */ - - Free_Cobjects = &Mem_Base[Free]; - for (Free_Objects = &Mem_Base[NROOTS]; - Free_Objects < Free_Cobjects; - Free_Objects += 1) - print_an_object(*Free_Objects); - -#if false - /* Pure Objects */ - - Free_Cobjects = &Mem_Base[Free_Pure]; - for (Free_Objects = &Mem_Base[Pure_Start]; - Free_Objects < Free_Cobjects; - Free_Objects += 1) - print_an_object(*Free_Objects); - - /* Constant Objects */ - - Free_Cobjects = &Mem_Base[Free_Constant]; - for (Free_Objects = &Mem_Base[Constant_Start]; - Free_Objects < Free_Cobjects; - Free_Objects += 1) - print_an_object(*Free_Objects); -#endif - - return; -} - -/* Top Level */ - -static int Noptions = 3; - -static struct Option_Struct Options[] = - {{"Do_Not_Compact", false, &Compact_P}, - {"Null_Out_NMVs", true, &Null_NMV}, - {"Swap_Bytes", true, &Shuffle_Bytes}}; - -main(argc, argv) -int argc; -char *argv[]; -{ Setup_Program(argc, argv, Noptions, Options); - return; -} diff --git a/v8/src/microcode/const.h b/v8/src/microcode/const.h deleted file mode 100644 index 7b70edcb1..000000000 --- a/v8/src/microcode/const.h +++ /dev/null @@ -1,170 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/const.h,v 9.24 1987/04/16 02:20:20 jinx Rel $ - * - * Named constants used throughout the interpreter - * - */ - -#if (CHAR_SIZE != 8) -#define MAX_CHAR ((1<> MACHINE_TYPE_LENGTH) & SUB_VERSION_MASK) -#define The_Version(P) Type_Code(P) -#define Make_Version(V, S, M) \ - Make_Non_Pointer((V), (((S) << MACHINE_TYPE_LENGTH) | (M))) - -#define WRITE_FLAG "w" -#define OPEN_FLAG "r" - -/* "Memorable" FASL versions -- ones where we modified something - and want to remain backwards compatible. -*/ - -/* Versions. */ - -#define FASL_FORMAT_ADDED_STACK 1 - -/* Subversions of highest numbered version. */ - -#define FASL_LONG_HEADER 3 -#define FASL_DENSE_TYPES 4 -#define FASL_PADDED_STRINGS 5 -#define FASL_REFERENCE_TRAP 6 - -/* Current parameters. */ - -#define FASL_FORMAT_VERSION FASL_FORMAT_ADDED_STACK -#define FASL_SUBVERSION FASL_REFERENCE_TRAP -#define FASL_OLDEST_SUPPORTED FASL_PADDED_STRINGS diff --git a/v8/src/microcode/fixobj.h b/v8/src/microcode/fixobj.h deleted file mode 100644 index 76757713c..000000000 --- a/v8/src/microcode/fixobj.h +++ /dev/null @@ -1,75 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/fixobj.h,v 9.24 1987/04/03 00:12:59 jinx Exp $ - * - * Declarations of user offsets into the Fixed Objects Vector. - * This should correspond to the file UTABMD.SCM - */ - -#define Non_Object 0x00 /* Used for unassigned variables */ -#define System_Interrupt_Vector 0x01 /* Handlers for interrups */ -#define System_Error_Vector 0x02 /* Handlers for errors */ -#define OBArray 0x03 /* Array for interning symbols */ -#define Types_Vector 0x04 /* Type number -> Name map */ -#define Returns_Vector 0x05 /* Return code -> Name map */ -#define Primitives_Vector 0x06 /* Primitive code -> Name map */ -#define Errors_Vector 0x07 /* Error code -> Name map */ -#define Identification_Vector 0x08 /* ID Vector index -> name map */ -#define GC_Daemon 0x0B /* Procedure to run after GC */ -#define Trap_Handler 0x0C /* Continue after disaster */ -#define Stepper_State 0x0E /* NOT IMPLEMENTED YET */ -#define Fixed_Objects_Slots 0x0F /* Names of these slots */ -#define External_Primitives 0x10 /* Names of external prims */ -#define State_Space_Tag 0x11 /* Tag for state spaces */ -#define State_Point_Tag 0x12 /* Tag for state points */ -#define Dummy_History 0x13 /* Empty history structure */ -#define Bignum_One 0x14 /* Cache for bignum one */ -#define System_Scheduler 0x15 /* Scheduler for touched futures */ -#define Termination_Vector 0x16 /* Names for terminations */ -#define Termination_Proc_Vector 0x17 /* Handlers for terminations */ -#define Me_Myself 0x18 /* The actual shared vector */ -/* The next slot is used only in multiprocessor mode */ -#define The_Work_Queue 0x19 /* Where work is stored */ -/* These two slots are only used if logging futures */ -#define Future_Logger 0x1A /* Routine to log touched futures */ -#define Touched_Futures 0x1B /* Vector of touched futures */ -#define Precious_Objects 0x1C /* Objects that should not be lost! */ -#define Error_Procedure 0x1D /* User invoked error handler */ -#define Unsnapped_Link 0x1E /* Handler for call to compiled code */ -#define Utilities_Vector 0x1F /* ??? */ -#define Compiler_Err_Procedure 0x20 /* ??? */ -#define Lost_Objects_Base 0x21 /* Free at the end of the "real" gc. */ -#define State_Space_Root 0x22 /* Root of state space */ - -#define NFixed_Objects 0x23 - diff --git a/v8/src/microcode/gctype.c b/v8/src/microcode/gctype.c deleted file mode 100644 index 465ff9d58..000000000 --- a/v8/src/microcode/gctype.c +++ /dev/null @@ -1,187 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/gctype.c,v 9.22 1987/04/03 00:14:08 jinx Exp $ - * - * This file contains the table which maps between Types and - * GC Types. - * - */ - - /*********************************/ - /* Mapping GC_Type to Type_Codes */ - /*********************************/ - -int GC_Type_Map[MAX_SAFE_TYPE + 1] = { - GC_Non_Pointer, /* TC_NULL,etc */ - GC_Pair, /* TC_LIST */ - GC_Non_Pointer, /* TC_CHARACTER */ - GC_Pair, /* TC_SCODE_QUOTE */ - GC_Triple, /* TC_PCOMB2 */ - GC_Pair, /* TC_UNINTERNED_SYMBOL */ - GC_Vector, /* TC_BIG_FLONUM */ - GC_Pair, /* TC_COMBINATION_1 */ - GC_Non_Pointer, /* TC_TRUE */ - GC_Pair, /* TC_EXTENDED_PROCEDURE */ - GC_Vector, /* TC_VECTOR */ - GC_Non_Pointer, /* TC_RETURN_CODE */ - GC_Triple, /* TC_COMBINATION_2 */ - GC_Pair, /* TC_COMPILED_PROCEDURE */ - GC_Vector, /* TC_BIG_FIXNUM */ - GC_Pair, /* TC_PROCEDURE */ - GC_Non_Pointer, /* TC_PRIMITIVE_EXTERNAL */ - GC_Pair, /* TC_DELAY */ - GC_Vector, /* TC_ENVIRONMENT */ - GC_Pair, /* TC_DELAYED */ - GC_Triple, /* TC_EXTENDED_LAMBDA */ - GC_Pair, /* TC_COMMENT */ - GC_Vector, /* TC_NON_MARKED_VECTOR */ - GC_Pair, /* TC_LAMBDA */ - GC_Non_Pointer, /* TC_PRIMITIVE */ - GC_Pair, /* TC_SEQUENCE_2 */ - GC_Non_Pointer, /* TC_FIXNUM */ - GC_Pair, /* TC_PCOMB1 */ - GC_Vector, /* TC_CONTROL_POINT */ - GC_Pair, /* TC_INTERNED_SYMBOL */ - GC_Vector, /* TC_CHARACTER_STRING,TC_VECTOR_8B */ - GC_Pair, /* TC_ACCESS */ - GC_Undefined, /* 0x20 */ - GC_Pair, /* TC_DEFINITION */ - GC_Special, /* TC_BROKEN_HEART */ - GC_Pair, /* TC_ASSIGNMENT */ - GC_Triple, /* TC_HUNK3 */ - GC_Pair, /* TC_IN_PACKAGE */ - -/* GC_Type_Map continues on next page */ - -/* GC_Type_Map continued */ - - GC_Vector, /* TC_COMBINATION */ - GC_Special, /* TC_MANIFEST_NM_VECTOR */ - GC_Compiled, /* TC_COMPILED_EXPRESSION */ - GC_Pair, /* TC_LEXPR */ - GC_Vector, /* TC_PCOMB3 */ - GC_Special, /* TC_MANIFEST_SPECIAL_NM_VECTOR */ - GC_Triple, /* TC_VARIABLE */ - GC_Non_Pointer, /* TC_THE_ENVIRONMENT */ - GC_Vector, /* TC_FUTURE */ - GC_Vector, /* TC_VECTOR_1B,TC_BIT_STRING */ - GC_Non_Pointer, /* TC_PCOMB0 */ - GC_Vector, /* TC_VECTOR_16B */ - GC_Special, /* TC_REFERENCE_TRAP */ - GC_Triple, /* TC_SEQUENCE_3 */ - GC_Triple, /* TC_CONDITIONAL */ - GC_Pair, /* TC_DISJUNCTION */ - GC_Cell, /* TC_CELL */ - GC_Pair, /* TC_WEAK_CONS */ - GC_Quadruple, /* TC_QUAD */ - GC_Compiled, /* TC_RETURN_ADDRESS */ - GC_Pair, /* TC_COMPILER_LINK */ - GC_Non_Pointer, /* TC_STACK_ENVIRONMENT */ - GC_Pair, /* TC_COMPLEX */ - GC_Undefined, /* 0x3D */ - GC_Undefined, /* 0x3E */ - GC_Undefined, /* 0x3F */ - GC_Undefined, /* 0x40 */ - GC_Undefined, /* 0x41 */ - GC_Undefined, /* 0x42 */ - GC_Undefined, /* 0x43 */ - GC_Undefined, /* 0x44 */ - GC_Undefined, /* 0x45 */ - GC_Undefined, /* 0x46 */ - GC_Undefined, /* 0x47 */ - GC_Undefined, /* 0x48 */ - GC_Undefined, /* 0x49 */ - GC_Undefined, /* 0x4A */ - GC_Undefined, /* 0x4B */ - GC_Undefined, /* 0x4C */ - GC_Undefined, /* 0x4D */ - GC_Undefined, /* 0x4E */ - GC_Undefined, /* 0x4F */ - GC_Undefined, /* 0x50 */ - GC_Undefined, /* 0x51 */ - GC_Undefined, /* 0x52 */ - GC_Undefined, /* 0x53 */ - GC_Undefined, /* 0x54 */ - -/* GC_Type_Map continues on next page */ - -/* GC_Type_Map continued */ - - GC_Undefined, /* 0x55 */ - GC_Undefined, /* 0x56 */ - GC_Undefined, /* 0x57 */ - GC_Undefined, /* 0x58 */ - GC_Undefined, /* 0x59 */ - GC_Undefined, /* 0x5A */ - GC_Undefined, /* 0x5B */ - GC_Undefined, /* 0x5C */ - GC_Undefined, /* 0x5D */ - GC_Undefined, /* 0x5E */ - GC_Undefined, /* 0x5F */ - GC_Undefined, /* 0x60 */ - GC_Undefined, /* 0x61 */ - GC_Undefined, /* 0x62 */ - GC_Undefined, /* 0x63 */ - GC_Undefined, /* 0x64 */ - GC_Undefined, /* 0x65 */ - GC_Undefined, /* 0x66 */ - GC_Undefined, /* 0x67 */ - GC_Undefined, /* 0x68 */ - GC_Undefined, /* 0x69 */ - GC_Undefined, /* 0x6A */ - GC_Undefined, /* 0x6B */ - GC_Undefined, /* 0x6C */ - GC_Undefined, /* 0x6D */ - GC_Undefined, /* 0x6E */ - GC_Undefined, /* 0x6F */ - GC_Undefined, /* 0x70 */ - GC_Undefined, /* 0x71 */ - GC_Undefined, /* 0x72 */ - GC_Undefined, /* 0x73 */ - GC_Undefined, /* 0x74 */ - GC_Undefined, /* 0x75 */ - GC_Undefined, /* 0x76 */ - GC_Undefined, /* 0x77 */ - GC_Undefined, /* 0x78 */ - GC_Undefined, /* 0x79 */ - GC_Undefined, /* 0x7A */ - GC_Undefined, /* 0x7B */ - GC_Undefined, /* 0x7C */ - GC_Undefined, /* 0x7D */ - GC_Undefined, /* 0x7E */ - GC_Undefined /* 0x7F */ - }; - -#if (MAX_SAFE_TYPE != 0x7F) -#include "gctype.c and scheme.h inconsistent -- GC_Type_Map" -#endif diff --git a/v8/src/microcode/interp.c b/v8/src/microcode/interp.c deleted file mode 100644 index c8cf5f2cf..000000000 --- a/v8/src/microcode/interp.c +++ /dev/null @@ -1,1780 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.23 1987/04/16 02:24:28 jinx Exp $ - * - * This file contains the heart of the Scheme Scode - * interpreter - * - */ - -#define In_Main_Interpreter true -#include "scheme.h" -#include "locks.h" -#include "trap.h" -#include "lookup.h" -#include "zones.h" - -/* In order to make the interpreter tail recursive (i.e. - * to avoid calling procedures and thus saving unnecessary - * state information), the main body of the interpreter - * is coded in a continuation passing style. - * - * Basically, this is done by dispatching on the type code - * for an Scode item. At each dispatch, some processing - * is done which may include setting the return address - * register, saving the current continuation (return address - * and current expression) and jumping to the start of - * the interpreter. - * - * It may be helpful to think of this program as being what - * you would get if you wrote the straightforward Scheme - * interpreter and then converted it into continuation - * passing style as follows. At every point where you would - * call EVAL to handle a sub-form, you put a jump back to - * Do_Expression. Now, if there was code after the call to - * EVAL you first push a "return code" (using Save_Cont) on - * the stack and move the code that used to be after the - * call down into the part of this file after the tag - * Pop_Return. - * - * Notice that because of the caller saves convention used - * here, all of the registers which are of interest have - * been SAVEd on the racks by the time interpretation arrives - * at Do_Expression (the top of EVAL). - * - * For notes on error handling and interrupts, see the file - * utils.c. - * - * This file is divided into two parts. The first - * corresponds is called the EVAL dispatch, and is ordered - * alphabetically by the SCode item handled. The second, - * called the return dispatch, begins at Pop_Return and is - * ordered alphabetically by return code name. - */ - -#define Interrupt(Masked_Code) \ -{ \ - Export_Registers(); \ - Setup_Interrupt(Masked_Code); \ - Import_Registers(); \ - goto Perform_Application; \ -} - -#define Immediate_GC(N) \ -{ \ - Request_GC(N); \ - Interrupt(IntCode & IntEnb); \ -} - -#define Prepare_Eval_Repeat() \ -{ \ - Will_Push(CONTINUATION_SIZE+1); \ - Push(Fetch_Env()); \ - Store_Return(RC_EVAL_ERROR); \ - Save_Cont(); \ - Pushed(); \ -} - -#define Eval_GC_Check(Amount) \ -if (GC_Check(Amount)) \ -{ \ - Prepare_Eval_Repeat(); \ - Immediate_GC(Amount); \ -} - -#define Eval_Error(Err) \ -{ \ - Export_Registers(); \ - Do_Micro_Error(Err, false); \ - Import_Registers(); \ - goto Internal_Apply; \ -} - -#define Pop_Return_Error(Err) \ -{ \ - Export_Registers(); \ - Do_Micro_Error(Err, true); \ - Import_Registers(); \ - goto Internal_Apply; \ -} - -#define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val) \ -{ \ - Store_Return(Return_Code); \ - Save_Cont(); \ - Store_Return(RC_RESTORE_VALUE); \ - Store_Expression(Contents_of_Val); \ - Save_Cont(); \ -} - -#define Reduces_To(Expr) \ - { Store_Expression(Expr); \ - New_Reduction(Fetch_Expression(), Fetch_Env()); \ - goto Do_Expression; \ - } - -#define Reduces_To_Nth(N) \ - Reduces_To(Fast_Vector_Ref(Fetch_Expression(), (N))) - -#define Do_Nth_Then(Return_Code, N, Extra) \ - { Store_Return(Return_Code); \ - Save_Cont(); \ - Store_Expression(Fast_Vector_Ref(Fetch_Expression(), (N))); \ - New_Subproblem(Fetch_Expression(), Fetch_Env()); \ - Extra; \ - goto Do_Expression; \ - } - -#define Do_Another_Then(Return_Code, N) \ - { Store_Return(Return_Code); \ - Save_Cont(); \ - Store_Expression(Fast_Vector_Ref(Fetch_Expression(), (N))); \ - Reuse_Subproblem(Fetch_Expression(), Fetch_Env()); \ - goto Do_Expression; \ - } - -#define Environment_P(Obj) (Obj == NIL || (Type_Code(Obj) == TC_ENVIRONMENT)) - -#define MAGIC_RESERVE_SIZE 6 /* See SPMD.SCM */ -#define Reserve_Stack_Space() Will_Eventually_Push(MAGIC_RESERVE_SIZE) - - /***********************/ - /* Macros for Stepping */ - /***********************/ - -#define Fetch_Trapper(field) \ - Vector_Ref(Get_Fixed_Obj_Slot(Stepper_State), (field)) - -#define Fetch_Eval_Trapper() Fetch_Trapper(HUNK_CXR0) -#define Fetch_Apply_Trapper() Fetch_Trapper(HUNK_CXR1) -#define Fetch_Return_Trapper() Fetch_Trapper(HUNK_CXR2) - -/* Macros for handling FUTUREs */ - -#ifdef COMPILE_FUTURES - -/* Arg_Type_Error handles the error returns from primitives which type check - their arguments and restarts them or suspends if the argument is a future. */ - -#define Arg_Type_Error(Arg_No, Err_No) \ -{ \ - fast Pointer *Arg, Orig_Arg; \ - \ - Arg = &(Stack_Ref(Arg_No-1)); \ - Orig_Arg = *Arg; \ - \ - if (Type_Code(*Arg) != TC_FUTURE) \ - Pop_Return_Error(Err_No); \ - \ - while ((Type_Code(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \ - { \ - if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \ - *Arg = Future_Value(*Arg); \ - } \ - if (Type_Code(*Arg) != TC_FUTURE) \ - goto Prim_No_Trap_Apply; \ - \ - Save_Cont(); \ - Will_Push(STACK_ENV_EXTRA_SLOTS+2); \ - Push(*Arg); /* Arg 1: The future itself */ \ - Push(Get_Fixed_Obj_Slot(System_Scheduler)); \ - Push(STACK_FRAME_HEADER+1); \ - Pushed(); \ - *Arg = Orig_Arg; \ - goto Apply_Non_Trapping; \ -} - -/* Apply_Future_Check is called at apply time to guarantee that certain - objects (the procedure itself, and its LAMBDA components for user defined - procedures) are not futures -*/ - -#define Apply_Future_Check(Name, Object) \ -{ \ - fast Pointer *Arg, Orig_Answer; \ - \ - Arg = &(Object); \ - Orig_Answer = *Arg; \ - \ - while (Type_Code(*Arg) == TC_FUTURE) \ - { \ - if (Future_Has_Value(*Arg)) \ - { \ - if (Future_Is_Keep_Slot(*Arg)) \ - Log_Touch_Of_Future(*Arg); \ - *Arg = Future_Value(*Arg); \ - } \ - else \ - { \ - Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \ - Store_Return(RC_INTERNAL_APPLY); \ - Val = NIL; \ - Save_Cont(); \ - Push(*Arg); \ - Push(Get_Fixed_Obj_Slot(System_Scheduler)); \ - Push(STACK_FRAME_HEADER+1); \ - Pushed(); \ - *Arg = Orig_Answer; \ - goto Internal_Apply; \ - } \ - } \ - Name = *Arg; \ -} - -/* Future handling macros continue on the next page */ - -/* Future handling macros, continued */ - -/* Pop_Return_Val_Check suspends the process if the value calculated by - a recursive call to EVAL is an undetermined future */ - -#define Pop_Return_Val_Check() \ -{ \ - fast Pointer Orig_Val = Val; \ - \ - while (Type_Code(Val) == TC_FUTURE) \ - { \ - if (Future_Has_Value(Val)) \ - { \ - if (Future_Is_Keep_Slot(Val)) \ - Log_Touch_Of_Future(Val); \ - Val = Future_Value(Val); \ - } \ - else \ - { \ - Save_Cont(); \ - Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \ - Store_Return(RC_RESTORE_VALUE); \ - Store_Expression(Orig_Val); \ - Save_Cont(); \ - Push(Val); \ - Push(Get_Fixed_Obj_Slot(System_Scheduler)); \ - Push(STACK_FRAME_HEADER+1); \ - Pushed(); \ - goto Internal_Apply; \ - } \ - } \ -} - -#else /* Not compiling FUTURES code */ - -#define Pop_Return_Val_Check() -#define Apply_Future_Check(Name, Object) Name = (Object) -#define Arg_Type_Error(Arg_No, Err_No) Pop_Return_Error(Err_No) - -#endif - -/* The EVAL/APPLY ying/yang */ - -void -Interpret(dumped_p) - Boolean dumped_p; -{ - long Which_Way; - fast Pointer *Reg_Block, *Reg_Stack_Pointer, *Reg_History; - - extern long enter_compiled_expression(); - extern long apply_compiled_procedure(); - extern long return_to_compiled_code(); - - Reg_Block = &Registers[0]; - - /* Primitives jump back here for errors, requests to - * evaluate an expression, apply a function, or handle an - * interrupt request. On errors or interrupts they leave - * their arguments on the stack, the primitive itself in - * Expression, and a RESTART_PRIMITIVE continuation in the - * return register. In the other cases, they have removed - * their stack frames entirely. - */ - - Which_Way = setjmp(*Back_To_Eval); - Set_Time_Zone(Zone_Working); - Import_Registers(); - if (Must_Report_References()) - { Save_Cont(); - Will_Push(CONTINUATION_SIZE + 2); - Push(Val); - Save_Env(); - Store_Return(RC_REPEAT_DISPATCH); - Store_Expression(Make_Non_Pointer(TC_FIXNUM, Which_Way)); - Save_Cont(); - Pushed(); - Call_Future_Logging(); - } - -Repeat_Dispatch: - switch (Which_Way) - { case PRIM_APPLY: goto Internal_Apply; - case PRIM_NO_TRAP_APPLY: goto Apply_Non_Trapping; - case PRIM_DO_EXPRESSION: Reduces_To(Fetch_Expression()); - case PRIM_NO_TRAP_EVAL: New_Reduction(Fetch_Expression(),Fetch_Env()); - goto Eval_Non_Trapping; - case 0: if (!dumped_p) break; /* Else fall through */ - case PRIM_POP_RETURN: goto Pop_Return; - default: Pop_Return_Error(Which_Way); - case PRIM_INTERRUPT: - { Save_Cont(); - Interrupt(IntCode & IntEnb); - } - case ERR_ARG_1_WRONG_TYPE: Arg_Type_Error(1, ERR_ARG_1_WRONG_TYPE); - case ERR_ARG_2_WRONG_TYPE: Arg_Type_Error(2, ERR_ARG_2_WRONG_TYPE); - case ERR_ARG_3_WRONG_TYPE: Arg_Type_Error(3, ERR_ARG_3_WRONG_TYPE); - } - -Do_Expression: - - if (Eval_Debug) - { Print_Expression(Fetch_Expression(), "Eval, expression"); - CRLF(); - } - -/* The expression register has an Scode item in it which - * should be evaluated and the result left in Val. - * - * A "break" after the code for any operation indicates that - * all processing for this operation has been completed, and - * the next step will be to pop a return code off the stack - * and proceed at Pop_Return. This is sometimes called - * "executing the continuation" since the return code can be - * considered the continuation to be performed after the - * operation. - * - * An operation can terminate with a Reduces_To or - * Reduces_To_Nth macro. This indicates that the value of - * the current Scode item is the value returned when the - * new expression is evaluated. Therefore no new - * continuation is created and processing continues at - * Do_Expression with the new expression in the expression - * register. - * - * Finally, an operation can terminate with a Do_Nth_Then - * macro. This indicates that another expression must be - * evaluated and them some additional processing will be - * performed before the value of this S-Code item available. - * Thus a new continuation is created and placed on the - * stack (using Save_Cont), the new expression is placed in - * the Expression register, and processing continues at - * Do_Expression. - */ - -/* Handling of Eval Trapping. - - If we are handling traps and there is an Eval Trap set, - turn off all trapping and then go to Internal_Apply to call the - user supplied eval hook with the expression to be evaluated and the - environment. - -*/ - - if (Microcode_Does_Stepping && Trapping && (Fetch_Eval_Trapper() != NIL)) - { Stop_Trapping(); - Will_Push(4); - Push(Fetch_Env()); - Push(Fetch_Expression()); - Push(Fetch_Eval_Trapper()); - Push(STACK_FRAME_HEADER+2); - Pushed(); - goto Apply_Non_Trapping; - } - -Eval_Non_Trapping: - Eval_Ucode_Hook(); - switch (Type_Code(Fetch_Expression())) - { case TC_BIG_FIXNUM: /* The self evaluating items */ - case TC_BIG_FLONUM: - case TC_CHARACTER_STRING: - case TC_CHARACTER: - case TC_COMPILED_PROCEDURE: - case TC_COMPLEX: - case TC_CONTROL_POINT: - case TC_DELAYED: - case TC_ENVIRONMENT: - case TC_EXTENDED_PROCEDURE: - case TC_FIXNUM: - case TC_HUNK3: - case TC_INTERNED_SYMBOL: - case TC_LIST: - case TC_NON_MARKED_VECTOR: - case TC_NULL: - case TC_PRIMITIVE: - case TC_PRIMITIVE_EXTERNAL: - case TC_PROCEDURE: - case TC_QUAD: - case TC_UNINTERNED_SYMBOL: - case TC_TRUE: - case TC_VECTOR: - case TC_VECTOR_16B: - case TC_VECTOR_1B: - case TC_REFERENCE_TRAP: - Val = Fetch_Expression(); break; - - case TC_ACCESS: - Will_Push(CONTINUATION_SIZE); - Do_Nth_Then(RC_EXECUTE_ACCESS_FINISH, ACCESS_ENVIRONMENT, Pushed()); - - case TC_ASSIGNMENT: - Will_Push(CONTINUATION_SIZE + 1); - Save_Env(); - Do_Nth_Then(RC_EXECUTE_ASSIGNMENT_FINISH, ASSIGN_VALUE, Pushed()); - - case TC_BROKEN_HEART: - Export_Registers(); - Microcode_Termination(TERM_BROKEN_HEART); - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_COMBINATION: - { long Array_Length = Vector_Length(Fetch_Expression())-1; - Eval_GC_Check(New_Stacklet_Size(Array_Length+1+1+CONTINUATION_SIZE)); - Will_Push(Array_Length + 1+1+CONTINUATION_SIZE); /* Save_Env, Finger */ - Stack_Pointer = Simulate_Pushing(Array_Length); - Push(Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Array_Length)); - /* The finger: last argument number */ - Pushed(); - if (Array_Length == 0) - { Push(STACK_FRAME_HEADER); /* Frame size */ - Do_Nth_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT, {}); - } - Save_Env(); - Do_Nth_Then(RC_COMB_SAVE_VALUE, Array_Length+1, {}); - } - - case TC_COMBINATION_1: - Reserve_Stack_Space(); /* STACK_ENV_EXTRA_SLOTS+2+CONTINUATION_SIZE */ - Save_Env(); - Do_Nth_Then(RC_COMB_1_PROCEDURE, COMB_1_ARG_1, {}); - - case TC_COMBINATION_2: - Reserve_Stack_Space(); /* STACK_ENV_EXTRA_SLOTS+3+CONTINUATION_SIZE */ - Save_Env(); - Do_Nth_Then(RC_COMB_2_FIRST_OPERAND, COMB_2_ARG_2, {}); - - case TC_COMMENT: - Reduces_To_Nth(COMMENT_EXPRESSION); - - case TC_CONDITIONAL: - Will_Push(CONTINUATION_SIZE + 1); - Save_Env(); - Do_Nth_Then(RC_CONDITIONAL_DECIDE, COND_PREDICATE, Pushed()); - - case TC_COMPILED_EXPRESSION: - execute_compiled_setup(); - Store_Expression( (Pointer) Get_Pointer( Fetch_Expression())); - Export_Registers(); - Which_Way = enter_compiled_expression(); - goto return_from_compiled_code; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_DEFINITION: - Will_Push(CONTINUATION_SIZE + 1); - Save_Env(); - Do_Nth_Then(RC_EXECUTE_DEFINITION_FINISH, DEFINE_VALUE, Pushed()); - - case TC_DELAY: - /* Deliberately omitted: Eval_GC_Check(2); */ - Val = Make_Pointer(TC_DELAYED, Free); - Free[THUNK_ENVIRONMENT] = Fetch_Env(); - Free[THUNK_PROCEDURE] = - Fast_Vector_Ref(Fetch_Expression(), DELAY_OBJECT); - Free += 2; - break; - - case TC_DISJUNCTION: - Will_Push(CONTINUATION_SIZE + 1); - Save_Env(); - Do_Nth_Then(RC_DISJUNCTION_DECIDE, OR_PREDICATE, Pushed()); - - case TC_EXTENDED_LAMBDA: /* Close the procedure */ - /* Deliberately omitted: Eval_GC_Check(2); */ - Val = Make_Pointer(TC_EXTENDED_PROCEDURE, Free); - Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression(); - Free[PROCEDURE_ENVIRONMENT] = Fetch_Env(); - Free += 2; - break; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - -#ifdef COMPILE_FUTURES - case TC_FUTURE: - if (Future_Has_Value(Fetch_Expression())) - { Pointer Future = Fetch_Expression(); - if (Future_Is_Keep_Slot(Future)) Log_Touch_Of_Future(Future); - Reduces_To_Nth(FUTURE_VALUE); - } - Prepare_Eval_Repeat(); - Will_Push(STACK_ENV_EXTRA_SLOTS+2); - Push(Fetch_Expression()); /* Arg: FUTURE object */ - Push(Get_Fixed_Obj_Slot(System_Scheduler)); - Push(STACK_FRAME_HEADER+1); - Pushed(); - goto Internal_Apply; -#endif - - case TC_IN_PACKAGE: - Will_Push(CONTINUATION_SIZE); - Do_Nth_Then(RC_EXECUTE_IN_PACKAGE_CONTINUE, - IN_PACKAGE_ENVIRONMENT, Pushed()); - - case TC_LAMBDA: /* Close the procedure */ - case TC_LEXPR: - /* Deliberately omitted: Eval_GC_Check(2); */ - Val = Make_Pointer(TC_PROCEDURE, Free); - Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression(); - Free[PROCEDURE_ENVIRONMENT] = Fetch_Env(); - Free += 2; - break; - - case TC_MANIFEST_NM_VECTOR: - case TC_MANIFEST_SPECIAL_NM_VECTOR: - Eval_Error(ERR_EXECUTE_MANIFEST_VECTOR); - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_PCOMB0: - /* In case we back out */ - Reserve_Stack_Space(); /* CONTINUATION_SIZE */ - Finished_Eventual_Pushing(); /* of this primitive */ - -Primitive_Internal_Apply: - if (Microcode_Does_Stepping && Trapping && - (Fetch_Apply_Trapper() != NIL)) - {Will_Push(3); - Push(Fetch_Expression()); - Push(Fetch_Apply_Trapper()); - Push(STACK_FRAME_HEADER + 1 + - N_Args_Primitive(Get_Integer(Fetch_Expression()))); - Pushed(); - Stop_Trapping(); - goto Apply_Non_Trapping; - } -Prim_No_Trap_Apply: - { - fast long primitive_code; - - primitive_code = Get_Integer(Fetch_Expression()); - - Export_Regs_Before_Primitive(); - Metering_Apply_Primitive(Val, primitive_code); - Import_Regs_After_Primitive(); - Pop_Primitive_Frame(N_Args_Primitive(primitive_code)); - if (Must_Report_References()) - { Store_Expression(Val); - Store_Return(RC_RESTORE_VALUE); - Save_Cont(); - Call_Future_Logging(); - } - break; - } - - case TC_PCOMB1: - Reserve_Stack_Space(); /* 1+CONTINUATION_SIZE */ - Do_Nth_Then(RC_PCOMB1_APPLY, PCOMB1_ARG_SLOT, {}); - - case TC_PCOMB2: - Reserve_Stack_Space(); /* 2+CONTINUATION_SIZE */ - Save_Env(); - Do_Nth_Then(RC_PCOMB2_DO_1, PCOMB2_ARG_2_SLOT, {}); - - case TC_PCOMB3: - Reserve_Stack_Space(); /* 3+CONTINUATION_SIZE */ - Save_Env(); - Do_Nth_Then(RC_PCOMB3_DO_2, PCOMB3_ARG_3_SLOT, {}); - - case TC_SCODE_QUOTE: - Val = Fast_Vector_Ref(Fetch_Expression(), SCODE_QUOTE_OBJECT); - break; - - case TC_SEQUENCE_2: - Will_Push(CONTINUATION_SIZE + 1); - Save_Env(); - Do_Nth_Then(RC_SEQ_2_DO_2, SEQUENCE_1, Pushed()); - - case TC_SEQUENCE_3: - Will_Push(CONTINUATION_SIZE + 1); - Save_Env(); - Do_Nth_Then(RC_SEQ_3_DO_2, SEQUENCE_1, Pushed()); - - case TC_THE_ENVIRONMENT: - Val = Fetch_Env(); break; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_VARIABLE: - { - long temp; - -#ifndef No_In_Line_Lookup - - fast Pointer *cell; - - Set_Time_Zone(Zone_Lookup); - cell = Get_Pointer(Fetch_Expression()); - lookup(cell, Fetch_Env(), cell, repeat_variable_lookup); - Val = *cell; - if (Type_Code(Val) != TC_REFERENCE_TRAP) - { - Set_Time_Zone(Zone_Working); - goto Pop_Return; - } - - get_trap_kind(temp, Val); - switch(temp) - { - case TRAP_DANGEROUS: - case TRAP_UNBOUND_DANGEROUS: - case TRAP_UNASSIGNED_DANGEROUS: - case TRAP_FLUID_DANGEROUS: - cell = Get_Pointer(Fetch_Expression()); - temp = - deep_lookup_end(deep_lookup(Fetch_Env(), cell[VARIABLE_SYMBOL], cell), - cell); - goto external_lookup_return; - - /* No need to recompile, pass the fake variable. */ - case TRAP_FLUID: - temp = deep_lookup_end(lookup_fluid(Val), fake_variable_object); - - external_lookup_return: - Import_Val(); - if (temp != PRIM_DONE) - break; - Set_Time_Zone(Zone_Working); - goto Pop_Return; - - case TRAP_UNBOUND: - temp = ERR_UNBOUND_VARIABLE; - break; - - case TRAP_UNASSIGNED: - temp = ERR_UNASSIGNED_VARIABLE; - break; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - default: - temp = ERR_BROKEN_COMPILED_VARIABLE; - break; - } - -#else No_In_Line_Lookup - - Set_Time_Zone(Zone_Lookup); - temp = Lex_Ref(Fetch_Env(), Fetch_Expression()); - Import_Val(); - if (temp == PRIM_DONE) - break; - -#endif No_In_Line_Lookup - - /* Back out of the evaluation. */ - - Set_Time_Zone(Zone_Working); - - if (temp == PRIM_INTERRUPT) - { - Prepare_Eval_Repeat(); - Interrupt(IntCode & IntEnb); - } - - Eval_Error(temp); - } - - case TC_RETURN_CODE: - default: Eval_Error(ERR_UNDEFINED_USER_TYPE); - }; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - -/* Now restore the continuation saved during an earlier part - * of the EVAL cycle and continue as directed. - */ - -Pop_Return: - Pop_Return_Ucode_Hook(); - Restore_Cont(); - if (Consistency_Check && - (Type_Code(Fetch_Return()) != TC_RETURN_CODE)) - { Push(Val); /* For possible stack trace */ - Save_Cont(); - Export_Registers(); - Microcode_Termination(TERM_BAD_STACK); - } - if (Eval_Debug) - { Print_Return("Pop_Return, return code"); - Print_Expression(Val, "Pop_Return, value"); - CRLF(); - }; - - /* Dispatch on the return code. A BREAK here will cause - * a "goto Pop_Return" to occur, since this is the most - * common occurrence. - */ - - switch (Get_Integer(Fetch_Return())) - { case RC_COMB_1_PROCEDURE: - Restore_Env(); - Push(Val); /* Arg. 1 */ - Push(NIL); /* Operator */ - Push(STACK_FRAME_HEADER+1); - Finished_Eventual_Pushing(); - Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_1_FN); - - case RC_COMB_2_FIRST_OPERAND: - Restore_Env(); - Push(Val); - Save_Env(); - Do_Another_Then(RC_COMB_2_PROCEDURE, COMB_2_ARG_1); - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_COMB_2_PROCEDURE: - Restore_Env(); - Push(Val); /* Arg 1, just calculated */ - Push(NIL); /* Function */ - Push(STACK_FRAME_HEADER+2); - Finished_Eventual_Pushing(); - Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_2_FN); - - case RC_COMB_APPLY_FUNCTION: - End_Subproblem(); - Stack_Ref(STACK_ENV_FUNCTION) = Val; - goto Internal_Apply; - - case RC_COMB_SAVE_VALUE: - { long Arg_Number; - - Restore_Env(); - Arg_Number = Get_Integer(Stack_Ref(STACK_COMB_FINGER))-1; - Stack_Ref(STACK_COMB_FIRST_ARG+Arg_Number) = Val; - Stack_Ref(STACK_COMB_FINGER) = - Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Arg_Number); - /* DO NOT count on the type code being NMVector here, since - the stack parser may create them with NIL here! */ - if (Arg_Number > 0) - { Save_Env(); - Do_Another_Then(RC_COMB_SAVE_VALUE, - (COMB_ARG_1_SLOT - 1) + Arg_Number); - } - Push(Fast_Vector_Ref(Fetch_Expression(), 0)); /* Frame Size */ - Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT); - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - -#define define_compiler_restart( return_code, entry) \ - case return_code: \ - { extern long entry(); \ - compiled_code_restart(); \ - Export_Registers(); \ - Which_Way = entry(); \ - goto return_from_compiled_code; \ - } - - define_compiler_restart( RC_COMP_INTERRUPT_RESTART, - comp_interrupt_restart) - - define_compiler_restart( RC_COMP_LEXPR_INTERRUPT_RESTART, - comp_lexpr_interrupt_restart) - - define_compiler_restart( RC_COMP_LOOKUP_APPLY_RESTART, - comp_lookup_apply_restart) - - define_compiler_restart( RC_COMP_REFERENCE_RESTART, - comp_reference_restart) - - define_compiler_restart( RC_COMP_ACCESS_RESTART, - comp_access_restart) - - define_compiler_restart( RC_COMP_UNASSIGNED_P_RESTART, - comp_unassigned_p_restart) - - define_compiler_restart( RC_COMP_UNBOUND_P_RESTART, - comp_unbound_p_restart) - - define_compiler_restart( RC_COMP_ASSIGNMENT_RESTART, - comp_assignment_restart) - - define_compiler_restart( RC_COMP_DEFINITION_RESTART, - comp_definition_restart) - - case RC_REENTER_COMPILED_CODE: - compiled_code_restart(); - Export_Registers(); - Which_Way = return_to_compiled_code(); - goto return_from_compiled_code; - - case RC_CONDITIONAL_DECIDE: - Pop_Return_Val_Check(); - End_Subproblem(); - Restore_Env(); - Reduces_To_Nth((Val==NIL)? COND_ALTERNATIVE : COND_CONSEQUENT); - - case RC_DISJUNCTION_DECIDE: - /* Return predicate if it isn't NIL; else do ALTERNATIVE */ - Pop_Return_Val_Check(); - End_Subproblem(); - Restore_Env(); - if (Val != NIL) goto Pop_Return; - Reduces_To_Nth(OR_ALTERNATIVE); - - case RC_END_OF_COMPUTATION: - /* Signals bottom of stack */ - Export_Registers(); - Microcode_Termination(TERM_END_OF_COMPUTATION); - - case RC_EVAL_ERROR: - /* Should be called RC_REDO_EVALUATION. */ - Store_Env(Pop()); - Reduces_To(Fetch_Expression()); - - case RC_EXECUTE_ACCESS_FINISH: - { - long Result; - Pointer value; - - Pop_Return_Val_Check(); - value = Val; - - if (Environment_P(Val)) - { Result = Symbol_Lex_Ref(value, - Fast_Vector_Ref(Fetch_Expression(), - ACCESS_NAME)); - Import_Val(); - if (Result == PRIM_DONE) - { - End_Subproblem(); - break; - } - if (Result != PRIM_INTERRUPT) - { - Val = value; - Pop_Return_Error(Result); - } - Prepare_Pop_Return_Interrupt(RC_EXECUTE_ACCESS_FINISH, value); - Interrupt(IntCode & IntEnb); - } - Val = value; - Pop_Return_Error(ERR_BAD_FRAME); - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_EXECUTE_ASSIGNMENT_FINISH: - { - long temp; - Pointer value; - Lock_Handle set_serializer; - -#ifndef No_In_Line_Lookup - - Pointer bogus_unassigned; - fast Pointer *cell; - - Set_Time_Zone(Zone_Lookup); - Restore_Env(); - cell = Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME)); - lookup(cell, Fetch_Env(), cell, repeat_assignment_lookup); - setup_lock(set_serializer, cell); - - value = Val; - bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object); - if (value == bogus_unassigned) - value = UNASSIGNED_OBJECT; - - if (Type_Code(*cell) != TC_REFERENCE_TRAP) - { - Val = *cell; - - normal_assignment_done: - *cell = value; - remove_lock(set_serializer); - Set_Time_Zone(Zone_Working); - End_Subproblem(); - goto Pop_Return; - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - get_trap_kind(temp, *cell); - switch(temp) - { - case TRAP_DANGEROUS: - case TRAP_UNBOUND_DANGEROUS: - case TRAP_UNASSIGNED_DANGEROUS: - case TRAP_FLUID_DANGEROUS: - remove_lock(set_serializer); - cell = Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME)); - temp = - deep_assignment_end(deep_lookup(Fetch_Env(), - cell[VARIABLE_SYMBOL], - cell), - cell, - value, - false); - goto external_assignment_return; - - case TRAP_UNASSIGNED: - Val = bogus_unassigned; - goto normal_assignment_done; - - case TRAP_FLUID: - /* No need to recompile, pass the fake variable. */ - remove_lock(set_serializer); - temp = deep_assignment_end(lookup_fluid(*cell), - fake_variable_object, - value, - false); - - external_assignment_return: - Import_Val(); - if (temp != PRIM_DONE) - break; - Set_Time_Zone(Zone_Working); - End_Subproblem(); - goto Pop_Return; - - case TRAP_UNBOUND: - remove_lock(set_serializer); - temp = ERR_UNBOUND_VARIABLE; - break; - - default: - remove_lock(set_serializer); - temp = ERR_BROKEN_COMPILED_VARIABLE; - break; - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - -#else - - Set_Time_Zone(Zone_Lookup); - Restore_Env(); - temp = Lex_Set(Fetch_Env(), - Vector_Ref(Fetch_Expression(), ASSIGN_NAME), - value); - Import_Val(); - if (temp == PRIM_DONE) - { End_Subproblem(); - Set_Time_Zone(Zone_Working); - break; - } - -#endif - - Set_Time_Zone(Zone_Working); - Save_Env(); - if (temp != PRIM_INTERRUPT) - { - Val = value; - Pop_Return_Error(temp); - } - - Prepare_Pop_Return_Interrupt(RC_EXECUTE_ASSIGNMENT_FINISH, - value); - Interrupt(IntCode & IntEnb); - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_EXECUTE_DEFINITION_FINISH: - { - Pointer value; - long result; - - value = Val; - Restore_Env(); - Export_Registers(); - result = Local_Set(Fetch_Env(), - Fast_Vector_Ref(Fetch_Expression(), DEFINE_NAME), - Val); - Import_Registers(); - if (result == PRIM_DONE) - { - End_Subproblem(); - break; - } - Save_Env(); - if (result == PRIM_INTERRUPT) - { - Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH, - value); - Interrupt(IntCode & IntEnb); - } - Val = value; - Pop_Return_Error(result); - } - - case RC_EXECUTE_IN_PACKAGE_CONTINUE: - Pop_Return_Val_Check(); - if (Environment_P(Val)) - { - End_Subproblem(); - Store_Env(Val); - Reduces_To_Nth(IN_PACKAGE_EXPRESSION); - } - Pop_Return_Error(ERR_BAD_FRAME); - -#ifdef COMPILE_FUTURES - case RC_FINISH_GLOBAL_INT: - Export_Registers(); - Val = Global_Int_Part_2(Fetch_Expression(), Val); - Import_Registers_Except_Val(); - break; -#endif - - case RC_GC_CHECK: - if (Get_Integer(Fetch_Expression()) > Space_Before_GC()) - { - Export_Registers(); - Microcode_Termination(TERM_GC_OUT_OF_SPACE); - } - break; - - case RC_HALT: - Export_Registers(); - Microcode_Termination(TERM_TERM_HANDLER); - - case RC_INTERNAL_APPLY: - -Internal_Apply: - -/* Branch here to perform a function application. - - At this point the top of the stack contains an application frame - which consists of the following elements (see sdata.h): - - A header specifying the frame length. - - A procedure. - - The actual (evaluated) arguments. - - No registers (except the stack pointer) are meaning full at this point. - Before interrupts or errors are processed, some registers are cleared - to avoid holding onto garbage if a garbage collection occurs. -*/ - -#define Prepare_Apply_Interrupt() \ -{ \ - Store_Return(RC_INTERNAL_APPLY); \ - Store_Expression(NIL); \ - Save_Cont(); \ -} - -#define Apply_Error(N) \ -{ \ - Store_Return(RC_INTERNAL_APPLY); \ - Store_Expression(NIL); \ - Val = NIL; \ - Pop_Return_Error(N); \ -} - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - if (Microcode_Does_Stepping && Trapping && - (Fetch_Apply_Trapper() != NIL)) - { - long Count; - - Count = Get_Integer(Stack_Ref(STACK_ENV_HEADER)); - Top_Of_Stack() = Fetch_Apply_Trapper(); - Push(STACK_FRAME_HEADER+Count); - Stop_Trapping(); - } - -Apply_Non_Trapping: - - if ((IntCode & IntEnb) != 0) - { - long Interrupts; - - Interrupts = (IntCode & IntEnb); - Store_Expression(NIL); - Val = NIL; - Prepare_Apply_Interrupt(); - Interrupt(Interrupts); - } - -Perform_Application: - - Apply_Ucode_Hook(); - - { - fast Pointer Function; - - Apply_Future_Check(Function, Stack_Ref(STACK_ENV_FUNCTION)); - - switch(Type_Code(Function)) - { - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_PROCEDURE: - { - fast long nargs; - - nargs = Get_Integer(Pop()); - Function = Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR); - - { - fast Pointer formals; - - Apply_Future_Check(formals, - Fast_Vector_Ref(Function, LAMBDA_FORMALS)); - - if ((nargs != Vector_Length(formals)) && - ((Type_Code(Function) != TC_LEXPR) || - (nargs < Vector_Length(formals)))) - { - Push(STACK_FRAME_HEADER + nargs - 1); - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } - } - - if (Eval_Debug) - { - Print_Expression(Make_Unsigned_Fixnum(nargs), - "APPLY: Number of arguments"); - } - - if (GC_Check(nargs + 1)) - { - Push(STACK_FRAME_HEADER + nargs - 1); - Prepare_Apply_Interrupt(); - Immediate_GC(nargs + 1); - } - - { - fast Pointer *scan; - - scan = Free; - Store_Env(Make_Pointer(TC_ENVIRONMENT, scan)); - *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, nargs); - while(--nargs >= 0) - *scan++ = Pop(); - Free = scan; - Reduces_To(Fast_Vector_Ref(Function, LAMBDA_SCODE)); - } - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_CONTROL_POINT: - { - if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) != - STACK_ENV_FIRST_ARG) - { - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } - Val = Stack_Ref(STACK_ENV_FIRST_ARG); - Our_Throw(false, Function); - Apply_Stacklet_Backout(); - Our_Throw_Part_2(); - goto Pop_Return; - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - /* - After checking the number of arguments, remove the - frame header since primitives do not expect it. - */ - - case TC_PRIMITIVE: - { - if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) != - STACK_ENV_FIRST_ARG + N_Args_Primitive(Get_Integer(Function)) - 1) - { - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } - Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG); - Store_Expression(Function); - goto Prim_No_Trap_Apply; - } - - case TC_PRIMITIVE_EXTERNAL: - { - fast long NArgs, Proc; - - Proc = Datum(Function); - if (Proc > MAX_EXTERNAL_PRIMITIVE) - { - Apply_Error(ERR_UNDEFINED_PRIMITIVE); - } - NArgs = N_Args_External(Proc); - if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) != - (NArgs + (STACK_ENV_FIRST_ARG - 1))) - { - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } - Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG); - Store_Expression(Function); - -Repeat_External_Primitive: - /* Reinitialize Proc in case we "goto Repeat_External..." */ - Proc = Get_Integer(Fetch_Expression()); - - Export_Regs_Before_Primitive(); - Val = Apply_External(Proc); - Set_Time_Zone(Zone_Working); - Import_Regs_After_Primitive(); - Pop_Primitive_Frame(N_Args_External(Proc)); - - goto Pop_Return; - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_EXTENDED_PROCEDURE: - { - Pointer lambda; - long nargs, nparams, formals, params, auxes, - rest_flag, size; - - fast long i; - fast Pointer *scan; - - nargs = Get_Integer(Pop()) - STACK_FRAME_HEADER; - - if (Eval_Debug) - { - Print_Expression(Make_Unsigned_Fixnum(nargs+STACK_FRAME_HEADER), - "APPLY: Number of arguments"); - } - - lambda = Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR); - Apply_Future_Check(Function, - Fast_Vector_Ref(lambda, ELAMBDA_NAMES)); - nparams = Vector_Length(Function) - 1; - - Apply_Future_Check(Function, Get_Count_Elambda(lambda)); - formals = Elambda_Formals_Count(Function); - params = Elambda_Opts_Count(Function) + formals; - rest_flag = Elambda_Rest_Flag(Function); - auxes = nparams - (params + rest_flag); - - if ((nargs < formals) || (!rest_flag && (nargs > params))) - { - Push(STACK_FRAME_HEADER + nargs); - Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS); - } - - /* size includes the procedure slot, but not the header. */ - size = params + rest_flag + auxes + 1; - if (GC_Check(size + 1 + ((nargs > params) ? - (2 * (nargs - params)) : - 0))) - { - Push(STACK_FRAME_HEADER + nargs); - Prepare_Apply_Interrupt(); - Immediate_GC(size + 1 + ((nargs > params) ? - (2 * (nargs - params)) : - 0)); - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - scan = Free; - Store_Env(Make_Pointer(TC_ENVIRONMENT, scan)); - *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, size); - - if (nargs <= params) - { - for (i = (nargs + 1); --i >= 0; ) - *scan++ = Pop(); - for (i = (params - nargs); --i >= 0; ) - *scan++ = UNASSIGNED_OBJECT; - if (rest_flag) - *scan++ = NIL; - for (i = auxes; --i >= 0; ) - *scan++ = UNASSIGNED_OBJECT; - } - else - { - /* rest_flag must be true. */ - Pointer list; - - list = Make_Pointer(TC_LIST, (scan + size)); - for (i = (params + 1); --i >= 0; ) - *scan++ = Pop(); - *scan++ = list; - for (i = auxes; --i >= 0; ) - *scan++ = UNASSIGNED_OBJECT; - /* Now scan == Get_Pointer(list) */ - for (i = (nargs - params); --i >= 0; ) - { - *scan++ = Pop(); - *scan = Make_Pointer(TC_LIST, (scan + 1)); - scan += 1; - } - scan[-1] = NIL; - } - - Free = scan; - Reduces_To(Get_Body_Elambda(lambda)); - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case TC_COMPILED_PROCEDURE: - { - apply_compiled_setup(STACK_ENV_EXTRA_SLOTS + - Get_Integer( Stack_Ref( STACK_ENV_HEADER))); - Export_Registers(); - Which_Way = apply_compiled_procedure(); - -return_from_compiled_code: - Import_Registers(); - switch (Which_Way) - { - case PRIM_DONE: - { compiled_code_done(); - goto Pop_Return; - } - - case PRIM_APPLY: - { compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS + - Get_Integer( Stack_Ref( STACK_ENV_HEADER))); - goto Internal_Apply; - } - - case ERR_COMPILED_CODE_ERROR: - { /* The compiled code is signalling a microcode error. */ - compiled_error_backout(); - /* The Save_Cont is done by Pop_Return_Error. */ - Pop_Return_Error( compiled_code_error_code); - } - - case PRIM_INTERRUPT: - { compiled_error_backout(); - Save_Cont(); - Interrupt( (IntCode & IntEnb)); - } - - case ERR_WRONG_NUMBER_OF_ARGUMENTS: - { apply_compiled_backout(); - Apply_Error( Which_Way); - } - - case ERR_EXECUTE_MANIFEST_VECTOR: - { /* This error code means that enter_compiled_expression - was called in a system without compiler support. - */ - execute_compiled_backout(); - Val = Make_Non_Pointer( TC_COMPILED_EXPRESSION, - Fetch_Expression()); - Pop_Return_Error( Which_Way); - } - - case ERR_INAPPLICABLE_OBJECT: - { /* This error code means that apply_compiled_procedure - was called in a system without compiler support. - */ - apply_compiled_backout(); - Apply_Error( Which_Way); - } - - case ERR_INAPPLICABLE_CONTINUATION: - { /* This error code means that return_to_compiled_code - or some other compiler continuation was called in a - system without compiler support. - */ - Store_Expression(NIL); - Store_Return(RC_REENTER_COMPILED_CODE); - Pop_Return_Error(Which_Way); - } - - default: Microcode_Termination( TERM_COMPILER_DEATH); - } - } - - default: - Apply_Error(ERR_INAPPLICABLE_OBJECT); - } /* End of switch in RC_INTERNAL_APPLY */ - } /* End of RC_INTERNAL_APPLY case */ - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_MOVE_TO_ADJACENT_POINT: - /* Expression contains the space in which we are moving */ - { long From_Count = Get_Integer(Stack_Ref(TRANSLATE_FROM_DISTANCE)); - Pointer Thunk, New_Location; - if (From_Count != 0) - { Pointer Current = Stack_Ref(TRANSLATE_FROM_POINT); - Stack_Ref(TRANSLATE_FROM_DISTANCE) = Make_Unsigned_Fixnum((From_Count - 1)); - Thunk = Fast_Vector_Ref(Current, STATE_POINT_AFTER_THUNK); - New_Location = Fast_Vector_Ref(Current, STATE_POINT_NEARER_POINT); - Stack_Ref(TRANSLATE_FROM_POINT) = New_Location; - if ((From_Count == 1) && - (Stack_Ref(TRANSLATE_TO_DISTANCE) == Make_Unsigned_Fixnum(0))) - Stack_Pointer = Simulate_Popping(4); - else Save_Cont(); - } - else - { long To_Count = Get_Integer(Stack_Ref(TRANSLATE_TO_DISTANCE))-1; - fast Pointer To_Location = Stack_Ref(TRANSLATE_TO_POINT); - fast long i; - for (i=0; i < To_Count; i++) - To_Location = Fast_Vector_Ref(To_Location, STATE_POINT_NEARER_POINT); - Thunk = Fast_Vector_Ref(To_Location, STATE_POINT_BEFORE_THUNK); - New_Location = To_Location; - Stack_Ref(TRANSLATE_TO_DISTANCE) = Make_Unsigned_Fixnum(To_Count); - if (To_Count==0) - Stack_Pointer = Simulate_Popping(4); - else Save_Cont(); - } - if (Fetch_Expression() != NIL) - Vector_Set(Fetch_Expression(), STATE_SPACE_NEAREST_POINT, New_Location); - else Current_State_Point = New_Location; - Will_Push(2); - Push(Thunk); - Push(STACK_FRAME_HEADER); - Pushed(); - goto Internal_Apply; - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_INVOKE_STACK_THREAD: - /* Used for WITH_THREADED_STACK primitive */ - Will_Push(3); - Push(Val); /* Value calculated by thunk */ - Push(Fetch_Expression()); - Push(STACK_FRAME_HEADER+1); - Pushed(); - goto Internal_Apply; - - case RC_JOIN_STACKLETS: - Our_Throw(true, Fetch_Expression()); - Join_Stacklet_Backout(); - Our_Throw_Part_2(); - break; - - case RC_NORMAL_GC_DONE: - End_GC_Hook(); - if (GC_Check(GC_Space_Needed)) - { printf("\nGC just ended. The free pointer is at 0x%x, the top of this heap\n", - Free); - printf("is at 0x%x, and we are trying to cons 0x%x objects. Dead!\n", - MemTop, GC_Space_Needed); - Microcode_Termination(TERM_EXIT); - } - GC_Space_Needed = 0; - Val = Fetch_Expression(); - break; - - case RC_PCOMB1_APPLY: - End_Subproblem(); - Push(Val); /* Argument value */ - Finished_Eventual_Pushing(); - Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB1_FN_SLOT)); - goto Primitive_Internal_Apply; - - case RC_PCOMB2_APPLY: - End_Subproblem(); - Push(Val); /* Value of arg. 1 */ - Finished_Eventual_Pushing(); - Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB2_FN_SLOT)); - goto Primitive_Internal_Apply; - - case RC_PCOMB2_DO_1: - Restore_Env(); - Push(Val); /* Save value of arg. 2 */ - Do_Another_Then(RC_PCOMB2_APPLY, PCOMB2_ARG_1_SLOT); - - case RC_PCOMB3_APPLY: - End_Subproblem(); - Push(Val); /* Save value of arg. 1 */ - Finished_Eventual_Pushing(); - Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB3_FN_SLOT)); - goto Primitive_Internal_Apply; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_PCOMB3_DO_1: - { Pointer Temp; - Temp = Pop(); /* Value of arg. 3 */ - Restore_Env(); - Push(Temp); /* Save arg. 3 again */ - Push(Val); /* Save arg. 2 */ - Do_Another_Then(RC_PCOMB3_APPLY, PCOMB3_ARG_1_SLOT); - } - - case RC_PCOMB3_DO_2: - Restore_Then_Save_Env(); - Push(Val); /* Save value of arg. 3 */ - Do_Another_Then(RC_PCOMB3_DO_1, PCOMB3_ARG_2_SLOT); - - case RC_POP_RETURN_ERROR: - case RC_RESTORE_VALUE: - Val = Fetch_Expression(); - break; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_PURIFY_GC_1: - { Pointer GC_Daemon_Proc, Result; - Export_Registers(); - Result = Purify_Pass_2(Fetch_Expression()); - Import_Registers(); - if (Result == NIL) - { /* The object does not fit in Constant space. - There is no need to run the daemons, and we should let the runtime - system know what happened. - */ - Val = NIL; - break; - } - GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon); - if (GC_Daemon_Proc==NIL) - { Val = TRUTH; - break; - } - Store_Expression(NIL); - Store_Return(RC_PURIFY_GC_2); - Save_Cont(); - Will_Push(2); - Push(GC_Daemon_Proc); - Push(STACK_FRAME_HEADER); - Pushed(); - goto Internal_Apply; - } - - case RC_PURIFY_GC_2: - Val = TRUTH; - break; - - case RC_REPEAT_DISPATCH: - Sign_Extend(Fetch_Expression(), Which_Way); - Restore_Env(); - Val = Pop(); - Restore_Cont(); - goto Repeat_Dispatch; - - case RC_REPEAT_PRIMITIVE: - if (Type_Code(Fetch_Expression()) == TC_PRIMITIVE_EXTERNAL) - goto Repeat_External_Primitive; - else goto Primitive_Internal_Apply; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - -/* The following two return codes are both used to restore - a saved history object. The difference is that the first - does not copy the history object while the second does. - In both cases, the Expression register contains the history - object and the next item to be popped off the stack contains - the offset back to the previous restore history return code. - - ASSUMPTION: History objects are never created using futures. -*/ - - case RC_RESTORE_DONT_COPY_HISTORY: - { Pointer Stacklet; - Prev_Restore_History_Offset = Get_Integer(Pop()); - Stacklet = Pop(); - History = Get_Pointer(Fetch_Expression()); - if (Prev_Restore_History_Offset == 0) - Prev_Restore_History_Stacklet = NULL; - else if (Stacklet == NIL) - Prev_Restore_History_Stacklet = NULL; - else - Prev_Restore_History_Stacklet = Get_Pointer(Stacklet); - break; - } - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_RESTORE_HISTORY: - { Pointer Stacklet; - Export_Registers(); - if (! Restore_History(Fetch_Expression())) - { Import_Registers(); - Save_Cont(); - Will_Push(CONTINUATION_SIZE); - Store_Expression(Val); - Store_Return(RC_RESTORE_VALUE); - Save_Cont(); - Pushed(); - Immediate_GC((Free > MemTop) ? 0 : ((MemTop-Free)+1)); - } - Import_Registers(); - Prev_Restore_History_Offset = Get_Integer(Pop()); - Stacklet = Pop(); - if (Prev_Restore_History_Offset == 0) - Prev_Restore_History_Stacklet = NULL; - else - { if (Stacklet == NIL) - { Prev_Restore_History_Stacklet = NULL; - Get_End_Of_Stacklet()[-Prev_Restore_History_Offset] = - Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY); - } - else - { Prev_Restore_History_Stacklet = Get_Pointer(Stacklet); - Prev_Restore_History_Stacklet[-Prev_Restore_History_Offset] = - Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY); - } - } - break; - } - - case RC_RESTORE_FLUIDS: - Fluid_Bindings = Fetch_Expression(); - New_Compiler_MemTop(); - break; - - case RC_RESTORE_INT_MASK: - IntEnb = Get_Integer(Fetch_Expression()); - New_Compiler_MemTop(); - break; - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_RESTORE_TO_STATE_POINT: - { Pointer Where_To_Go = Fetch_Expression(); - Will_Push(CONTINUATION_SIZE); - /* Restore the contents of Val after moving to point */ - Store_Expression(Val); - Store_Return(RC_RESTORE_VALUE); - Save_Cont(); - Pushed(); - Export_Registers(); - Translate_To_Point(Where_To_Go); - break; /* We never get here.... */ - } - - case RC_RETURN_TRAP_POINT: - Store_Return(Old_Return_Code); - Will_Push(CONTINUATION_SIZE+3); - Save_Cont(); - Return_Hook_Address = NULL; - Stop_Trapping(); - Push(Val); - Push(Fetch_Return_Trapper()); - Push(STACK_FRAME_HEADER+1); - Pushed(); - goto Apply_Non_Trapping; - - case RC_SEQ_2_DO_2: - End_Subproblem(); - Restore_Env(); - Reduces_To_Nth(SEQUENCE_2); - - case RC_SEQ_3_DO_2: - Restore_Then_Save_Env(); - Do_Another_Then(RC_SEQ_3_DO_3, SEQUENCE_2); - - case RC_SEQ_3_DO_3: - End_Subproblem(); - Restore_Env(); - Reduces_To_Nth(SEQUENCE_3); - -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_SNAP_NEED_THUNK: - Vector_Set(Fetch_Expression(), THUNK_SNAPPED, TRUTH); - Vector_Set(Fetch_Expression(), THUNK_VALUE, Val); - break; - - case RC_AFTER_MEMORY_UPDATE: - case RC_BAD_INTERRUPT_CONTINUE: - case RC_COMPLETE_GC_DONE: - case RC_RESTARTABLE_EXIT: - case RC_RESTART_EXECUTION: - case RC_RESTORE_CONTINUATION: - case RC_RESTORE_STEPPER: - case RC_POP_FROM_COMPILED_CODE: - Export_Registers(); - Microcode_Termination(TERM_UNIMPLEMENTED_CONTINUATION); - - default: - Export_Registers(); - Microcode_Termination(TERM_NON_EXISTENT_CONTINUATION); - }; - goto Pop_Return; -} diff --git a/v8/src/microcode/lookup.h b/v8/src/microcode/lookup.h deleted file mode 100644 index a1898b0d6..000000000 --- a/v8/src/microcode/lookup.h +++ /dev/null @@ -1,252 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/lookup.h,v 9.36 1987/04/16 02:26:04 jinx Exp $ */ - -/* Macros and declarations for the variable lookup code. */ - -extern Pointer - *deep_lookup(), - *lookup_fluid(); - -extern long - deep_lookup_end(), - deep_assignment_end(); - -extern Pointer - unbound_trap_object[], - uncompiled_trap_object[], - illegal_trap_object[], - fake_variable_object[]; - -#define GC_allocate_test(N) GC_Check(N) - -#define AUX_LIST_TYPE TC_VECTOR - -#define AUX_CHUNK_SIZE 20 -#define AUX_LIST_COUNT ENV_EXTENSION_COUNT -#define AUX_LIST_FIRST ENV_EXTENSION_MIN_SIZE -#define AUX_LIST_INITIAL_SIZE (AUX_LIST_FIRST + AUX_CHUNK_SIZE) - -/* Variable compilation types. */ - -#define LOCAL_REF TC_NULL -#define GLOBAL_REF TC_UNINTERNED_SYMBOL -#define FORMAL_REF TC_CHARACTER -#define AUX_REF TC_FIXNUM -#define UNCOMPILED_REF TC_TRUE - -/* Common constants. */ - -#ifndef b32 -#define UNCOMPILED_VARIABLE Make_Non_Pointer(UNCOMPILED_REF, 0) -#else -#define UNCOMPILED_VARIABLE 0x08000000 -#endif - -/* Macros for speedy variable reference. */ - -#if (LOCAL_REF == 0) - -#define Lexical_Offset(Ind) ((long) (Ind)) -#define Make_Local_Offset(Ind) ((Pointer) (Ind)) - -#else - -#define Lexical_Offset(Ind) Get_Integer(Ind) -#define Make_Local_Offset(Ind) Make_Non_Pointer(LOCAL_REF, Ind) - -#endif - -/* The code below depends on the following. */ - -/* Done as follows because of VMS. */ - -#define lookup_inconsistency_p \ - ((VARIABLE_OFFSET == VARIABLE_COMPILED_TYPE) || \ - (VARIABLE_FRAME_NO != VARIABLE_COMPILED_TYPE)) - -#if (lookup_inconsistency_p) -#include "error: lookup.h inconsistency detected." -#endif - -#define get_offset(hunk) Lexical_Offset(Fetch(hunk[VARIABLE_OFFSET])) - -#ifdef PARALLEL_PROCESSOR - -#define verify(type_code, variable, code, label) \ -{ \ - variable = code; \ - if (Type_Code(Fetch(hunk[VARIABLE_COMPILED_TYPE])) != \ - type_code) \ - goto label; \ -} - -#define verified_offset(variable, code) variable - -/* Unlike Lock_Cell, cell must be (Pointer *). This currently does - not matter, but might on a machine with address mapping. - */ - -#define setup_lock(handle, cell) handle = Lock_Cell(cell) -#define remove_lock(handle) Unlock_Cell(handle) - -#else - -#define verify(type_code, variable, code, label) -#define verified_offset(variable, code) code -#define setup_lock(handle, cell) -#define remove_lock(ignore) - -#endif - -/* Pointer *cell, env, *hunk; */ - -#define lookup(cell, env, hunk, label) \ -{ \ - fast Pointer frame; \ - long offset; \ - \ -label: \ - \ - frame = Fetch(hunk[VARIABLE_COMPILED_TYPE]); \ - \ - switch (Type_Code(frame)) \ - { \ - case GLOBAL_REF: \ - /* frame is a pointer to the same symbol. */ \ - cell = Nth_Vector_Loc(frame, SYMBOL_GLOBAL_VALUE); \ - break; \ - \ - case LOCAL_REF: \ - cell = Nth_Vector_Loc(env, Lexical_Offset(frame)); \ - break; \ - \ - case FORMAL_REF: \ - lookup_formal(cell, env, hunk, label); \ - \ - case AUX_REF: \ - lookup_aux(cell, env, hunk, label); \ - \ - default: \ - /* Done here rather than in a separate case because of \ - peculiarities of the bobcat compiler. \ - */ \ - cell = ((Type_Code(frame) == UNCOMPILED_REF) ? \ - uncompiled_trap_object : \ - illegal_trap_object); \ - break; \ - } \ -} - -#define lookup_formal(cell, env, hunk, label) \ -{ \ - fast long depth; \ - \ - verify(FORMAL_REF, offset, get_offset(hunk), label); \ - depth = Get_Integer(frame); \ - frame = env; \ - while(--depth >= 0) \ - { \ - frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \ - PROCEDURE_ENVIRONMENT); \ - } \ - \ - cell = Nth_Vector_Loc(frame, \ - verified_offset(offset, get_offset(hunk))); \ - \ - break; \ -} - -#define lookup_aux(cell, env, hunk, label) \ -{ \ - fast long depth; \ - \ - verify(AUX_REF, offset, get_offset(hunk), label); \ - depth = Get_Integer(frame); \ - frame = env; \ - while(--depth >= 0) \ - { \ - frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \ - PROCEDURE_ENVIRONMENT); \ - } \ - \ - frame = Vector_Ref(frame, ENVIRONMENT_FUNCTION); \ - if (Type_Code(frame) != AUX_LIST_TYPE) \ - { \ - cell = uncompiled_trap_object; \ - break; \ - } \ - depth = verified_offset(offset, get_offset(hunk)); \ - if (depth > Vector_Length(frame)) \ - { \ - cell = uncompiled_trap_object; \ - break; \ - } \ - frame = Vector_Ref(frame, depth); \ - if ((frame == NIL) || \ - (Fast_Vector_Ref(frame, CONS_CAR) != hunk[VARIABLE_SYMBOL])) \ - { \ - cell = uncompiled_trap_object; \ - break; \ - } \ - cell = Nth_Vector_Loc(frame, CONS_CDR); \ - break; \ -} - -#define lookup_primitive_type_test() \ -{ \ - if (Type_Code(Arg1) != GLOBAL_ENV) Arg_1_Type(TC_ENVIRONMENT); \ - if (Type_Code(Arg2) != TC_INTERNED_SYMBOL) \ - Arg_2_Type(TC_UNINTERNED_SYMBOL); \ -} - -#define lookup_primitive_end(Result) \ -{ \ - if (Result == PRIM_DONE) \ - return Val; \ - if (Result == PRIM_INTERRUPT) \ - Primitive_Interrupt(); \ - Primitive_Error(Result); \ -} - -#define standard_lookup_primitive(action) \ -{ \ - long Result; \ - \ - lookup_primitive_type_test(); \ - Result = action; \ - lookup_primitive_end(Result); \ - /*NOTREACHED*/ \ -} - - diff --git a/v8/src/microcode/mul.c b/v8/src/microcode/mul.c deleted file mode 100644 index 339c23864..000000000 --- a/v8/src/microcode/mul.c +++ /dev/null @@ -1,81 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/mul.c,v 9.22 1987/04/16 02:26:41 jinx Rel $ - * - * This file contains the portable fixnum multiplication procedure. - * Returns NIL if the result does not fit in a fixnum. - * Note: This has only been tried on machines with long = 32 bits. - * This file is included in the appropriate os file if needed. - */ - -#define HALF_WORD_SIZE ((sizeof(long)*CHAR_SIZE)/2) -#define HALF_WORD_MASK (1<> HALF_WORD_SIZE) & HALF_WORD_MASK); - Hi_B = ((B >> HALF_WORD_SIZE) & HALF_WORD_MASK); - Lo_A = (A & HALF_WORD_MASK); - Lo_B = (B & HALF_WORD_MASK); - Lo_C = (Lo_A * Lo_B); - if (Lo_C > FIXNUM_SIGN_BIT) - return NIL; - Middle_C = (Lo_A * Hi_B) + (Hi_A * Lo_B); - if (Middle_C >= MAX_MIDDLE) - return NIL; - if ((Hi_A > 0) && (Hi_B > 0)) - return NIL; - C = Lo_C + (Middle_C << HALF_WORD_SIZE); - if (Fixnum_Fits(C)) - { - if (Sign || (C == 0)) - return Make_Unsigned_Fixnum(C); - else - return Make_Unsigned_Fixnum(MAX_FIXNUM - C); - } - return NIL; -} diff --git a/v8/src/microcode/object.h b/v8/src/microcode/object.h deleted file mode 100644 index 1e07bfe97..000000000 --- a/v8/src/microcode/object.h +++ /dev/null @@ -1,244 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/object.h,v 9.22 1987/04/16 02:27:09 jinx Exp $ */ - -/* This file contains definitions pertaining to the C view of - Scheme pointers: widths of fields, extraction macros, pre-computed - extraction masks, etc. */ - -/* The C type Pointer is defined at the end of CONFIG.H - The definition of POINTER_LENGTH here assumes that Pointer is the same - as unsigned long. If that ever changes, this definition must also. - POINTER_LENGTH is defined this way to make it available to - the preprocessor. */ - -#define POINTER_LENGTH ULONG_SIZE -#define TYPE_CODE_LENGTH 8 /* Not CHAR_SIZE!! */ -#define MAX_TYPE_CODE 0xFF /* ((1<> ADDRESS_LENGTH) & MAX_TYPE_CODE) -#define safe_pointer_type(P) (((P) >> ADDRESS_LENGTH) & SAFE_TYPE_MASK) -#else /* Faster for logical shifts */ -#define pointer_type(P) ((P) >> ADDRESS_LENGTH) -#define safe_pointer_type(P) ((pointer_type (P)) & SAFE_TYPE_MASK) -#endif - -#define pointer_datum(P) ((P) & ADDRESS_MASK) - -/* compatibility definitions */ -#define Type_Code(P) (pointer_type (P)) -#define Safe_Type_Code(P) (safe_pointer_type (P)) -#define Datum(P) (pointer_datum (P)) - -#define Make_Object(TC, D) \ -((((unsigned) (TC)) << ADDRESS_LENGTH) | (pointer_datum (D))) - -#ifndef Heap_In_Low_Memory /* Safe version */ - -typedef Pointer *relocation_type; /* Used to relocate pointers on fasload */ - -extern Pointer *Memory_Base; - -/* The "-1" in the value returned is a guarantee that there is one - word reserved exclusively for use by the garbage collector. */ - -#define Allocate_Heap_Space(space) \ - (Memory_Base = ((Pointer *) (malloc ((sizeof (Pointer)) * (space)))), \ - Heap = Memory_Base, \ - ((Memory_Base + (space)) - 1)) - -#define Get_Pointer(P) ((Pointer *) (Memory_Base + (pointer_datum (P)))) -#define C_To_Scheme(P) ((Pointer) ((P) - Memory_Base)) - -#else /* Storing absolute addresses */ - -typedef long relocation_type; /* Used to relocate pointers on fasload */ - -#define Allocate_Heap_Space(space) \ - (Heap = ((Pointer *) (malloc ((sizeof (Pointer)) * (space)))), \ - ((Heap + (space)) - 1)) - -#ifdef spectrum - -#define Quad1_Tag 0x40000000 -#define Get_Pointer(P) ((Pointer *) (((P) & ADDRESS_MASK) | Quad1_Tag)) -#define C_To_Scheme(P) ((Pointer) (((long) (P)) & ADDRESS_MASK)) - -#else /* Not Spectrum, fast case */ - -#define Get_Pointer(P) ((Pointer *) (pointer_datum (P))) -#define C_To_Scheme(P) ((Pointer) (P)) - -#endif /* spectrum */ -#endif /* Heap_In_Low_Memory */ - -#define Make_Pointer(TC, A) Make_Object((TC), C_To_Scheme(A)) -#define Make_Non_Pointer(TC, D) Make_Object(TC, ((Pointer) (D))) - -/* (Make_New_Pointer (TC, A)) may be more efficient than - (Make_Pointer (TC, (Get_Pointer (A)))) */ - -#define Make_New_Pointer(TC, A) (Make_Object (TC, ((Pointer) A))) - -#define Store_Type_Code(P, TC) P = (Make_Object ((TC), (P))) - -#define Store_Address(P, A) \ - P = (((P) & TYPE_CODE_MASK) | (pointer_datum ((Pointer) (A)))) - -#define Address(P) (pointer_datum (P)) - -/* These are used only where the object is known to be immutable. - On a parallel processor they don't require atomic references */ - -#define Fast_Vector_Ref(P, N) ((Get_Pointer(P))[N]) -#define Fast_Vector_Set(P, N, S) Fast_Vector_Ref(P, N) = (S) -#define Fast_User_Vector_Ref(P, N) Fast_Vector_Ref(P, (N)+1) -#define Fast_User_Vector_Set(P, N, S) Fast_Vector_Set(P, (N)+1, S) -#define Nth_Vector_Loc(P, N) (&(Fast_Vector_Ref(P, N))) -#define Vector_Length(P) (Get_Integer(Fast_Vector_Ref((P), 0))) - -/* General case vector handling requires atomicity for parallel processors */ - -#define Vector_Ref(P, N) Fetch(Fast_Vector_Ref(P, N)) -#define Vector_Set(P, N, S) Store(Fast_Vector_Ref(P, N), S) -#define User_Vector_Ref(P, N) Vector_Ref(P, (N)+1) -#define User_Vector_Set(P, N, S) Vector_Set(P, (N)+1, S) - -#define Make_Broken_Heart(N) (BROKEN_HEART_ZERO + (N)) -#define Make_Unsigned_Fixnum(N) (FIXNUM_ZERO + (N)) -#define Make_Signed_Fixnum(N) Make_Non_Pointer( TC_FIXNUM, (N)) -#define fixnum_p(P) ((pointer_type (P)) == TC_FIXNUM) -#define Get_Float(P) (* ((double *) (Nth_Vector_Loc ((P), 1)))) -#define Get_Integer(P) (pointer_datum (P)) - -#define fixnum_negative_p(P) (((P) & FIXNUM_SIGN_BIT) != 0) - -#define Sign_Extend(P, S) \ -{ \ - (S) = (Get_Integer (P)); \ - if (((S) & FIXNUM_SIGN_BIT) != 0) \ - (S) |= (-1 << ADDRESS_LENGTH); \ -} - -#define Fixnum_Fits(x) \ - ((((x) & SIGN_MASK) == 0) || \ - (((x) & SIGN_MASK) == SIGN_MASK)) - -/* Playing with the danger bit */ - -#define Without_Danger_Bit(P) ((P) & (~DANGER_BIT)) -#define Dangerous(P) ((P & DANGER_BIT) != 0) -#define Clear_Danger_Bit(P) P &= ~DANGER_BIT -#define Set_Danger_Bit(P) P |= DANGER_BIT -/* Side effect testing */ - -#define Is_Constant(address) \ - (((address) >= Constant_Space) && ((address) < Free_Constant)) - -#define Is_Pure(address) \ - ((Is_Constant (address)) && (Pure_Test (address))) - -#define Side_Effect_Impurify(Old_Pointer, Will_Contain) \ -if ((Is_Constant (Get_Pointer (Old_Pointer))) && \ - (GC_Type (Will_Contain) != GC_Non_Pointer) && \ - (! (Is_Constant (Get_Pointer (Will_Contain)))) && \ - (Pure_Test (Get_Pointer (Old_Pointer)))) \ - Primitive_Error (ERR_WRITE_INTO_PURE_SPACE); - -#ifdef FLOATING_ALIGNMENT - -#define FLOATING_BUFFER_SPACE \ - ((FLOATING_ALIGNMENT + 1)/sizeof(Pointer)) - -#define HEAP_BUFFER_SPACE \ - (TRAP_MAX_IMMEDIATE + 1 + FLOATING_BUFFER_SPACE) - -/* The space is there, find the correct position. */ - -#define Initial_Align_Float(Where) \ -{ \ - while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \ - Where -= 1; \ -} - -#define Align_Float(Where) \ -{ \ - while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \ - *Where++ = (Make_Non_Pointer (TC_MANIFEST_NM_VECTOR, 0)); \ -} - -#else not FLOATING_ALIGNMENT - -#define HEAP_BUFFER_SPACE (TRAP_MAX_IMMEDIATE + 1) - -#define Initial_Align_Float(Where) -#define Align_Float(Where) - -#endif FLOATING_ALIGNMENT diff --git a/v8/src/microcode/ppband.c b/v8/src/microcode/ppband.c deleted file mode 100644 index 590fdf6f0..000000000 --- a/v8/src/microcode/ppband.c +++ /dev/null @@ -1,268 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/ppband.c,v 9.24 1987/04/03 00:06:29 jinx Exp $ - * - * Dumps Scheme FASL in user-readable form . - */ - -#include "scheme.h" - -/* These are needed by load.c */ - -static Pointer *Memory_Base; - -#define Load_Data(Count,To_Where) \ - fread(To_Where, sizeof(Pointer), Count, stdin) - -#define Reloc_or_Load_Debug true - -#include "load.c" -#include "gctype.c" - -#ifdef Heap_In_Low_Memory -#ifdef spectrum -#define File_To_Pointer(P) ((((long) (P))&ADDRESS_MASK) / sizeof(Pointer)) -#else -#define File_To_Pointer(P) ((P) / sizeof(Pointer)) -#endif /* spectrum */ -#else -#define File_To_Pointer(P) (P) -#endif - -#ifndef Conditional_Bug -#define Relocate(P) \ - (((long) (P) < Const_Base) ? \ - File_To_Pointer(((long) (P)) - Heap_Base) : \ - (Heap_Count+File_To_Pointer(((long) (P)) - Const_Base))) -#else -#define Relocate_Into(What, P) -if (((long) (P)) < Const_Base) - (What) = File_To_Pointer(((long) (P)) - Heap_Base); -else - (What) = Heap_Count + File_To_Pointer(((long) P) - Const_Base); - -static long Relocate_Temp; -#define Relocate(P) (Relocate_Into(Relocate_Temp, P), Relocate_Temp) -#endif - -static Pointer *Data, *end_of_memory; - -Boolean -scheme_string(From, Quoted) -long From; -Boolean Quoted; -{ fast long i, Count; - fast char *Chars; - Chars = (char *) &Data[From+STRING_CHARS]; - if (Chars < ((char *) end_of_memory)) - { Count = Get_Integer(Data[From+STRING_LENGTH]); - if (&Chars[Count] < ((char *) end_of_memory)) - { putchar(Quoted ? '\"' : '\''); - for (i=0; i < Count; i++) printf("%c", *Chars++); - if (Quoted) putchar('\"'); - putchar('\n'); - return true; - } - } - if (Quoted) - printf("String not in memory; datum = %x\n", From); - return false; -} - -#define via(File_Address) Relocate(Address(Data[File_Address])) - -void -scheme_symbol(From) -long From; -{ Pointer *symbol; - symbol = &Data[From+SYMBOL_NAME]; - if ((symbol >= end_of_memory) || - !scheme_string(via(From+SYMBOL_NAME), false)) - printf("symbol not in memory; datum = %x\n", From); - return; -} - -Display(Location, Type, The_Datum) -long Location, Type, The_Datum; -{ long Points_To; - printf("%5x: %2x|%6x ", Location, Type, The_Datum); - if (GC_Type_Map[Type & MAX_SAFE_TYPE] != GC_Non_Pointer) - Points_To = Relocate((Pointer *) The_Datum); - else - Points_To = The_Datum; - if (Type > MAX_SAFE_TYPE) printf("*"); - switch (Type & SAFE_TYPE_MASK) - { /* "Strange" cases */ - case TC_NULL: if (The_Datum == 0) - { printf("NIL\n"); - return; - } - else printf("[NULL "); - break; - case TC_TRUE: if (The_Datum == 0) - { printf("TRUE\n"); - return; - } - else printf("[TRUE "); - break; - case TC_BROKEN_HEART: printf("[BROKEN-HEART "); - if (The_Datum == 0) - Points_To = 0; - break; - case TC_MANIFEST_SPECIAL_NM_VECTOR: printf("[MANIFEST-SPECIAL-NM "); - Points_To = The_Datum; - break; - case TC_MANIFEST_NM_VECTOR: printf("[MANIFEST-NM-VECTOR "); - Points_To = The_Datum; - break; - case TC_INTERNED_SYMBOL: scheme_symbol(Points_To); - return; - case TC_UNINTERNED_SYMBOL: - printf("uninterned "); - scheme_symbol(Points_To); - return; - case TC_CHARACTER_STRING: scheme_string(Points_To, true); - return; - case TC_FIXNUM: printf("%d\n", Points_To); - return; - - /* Default cases */ - case TC_LIST: printf("[LIST "); break; - case TC_CHARACTER: printf("[CHARACTER "); break; - case TC_SCODE_QUOTE: printf("[SCODE-QUOTE "); break; - case TC_PCOMB2: printf("[PCOMB2 "); break; - case TC_BIG_FLONUM: printf("[BIG-FLONUM "); break; - case TC_COMBINATION_1: printf("[COMBINATION-1 "); break; - case TC_EXTENDED_PROCEDURE: printf("[EXTENDED-PROCEDURE "); break; - case TC_VECTOR: printf("[VECTOR "); break; - case TC_RETURN_CODE: printf("[RETURN-CODE "); break; - case TC_COMBINATION_2: printf("[COMBINATION-2 "); break; - case TC_COMPILED_PROCEDURE: printf("[COMPILED-PROCEDURE "); break; - case TC_BIG_FIXNUM: printf("[BIG-FIXNUM "); break; - case TC_PROCEDURE: printf("[PROCEDURE "); break; - case TC_PRIMITIVE_EXTERNAL: printf("[PRIMITIVE-EXTERNAL "); break; - case TC_DELAY: printf("[DELAY "); break; - case TC_ENVIRONMENT: printf("[ENVIRONMENT "); break; - case TC_DELAYED: printf("[DELAYED "); break; - case TC_EXTENDED_LAMBDA: printf("[EXTENDED-LAMBDA "); break; - case TC_COMMENT: printf("[COMMENT "); break; - case TC_NON_MARKED_VECTOR: printf("[NON-MARKED-VECTOR "); break; - case TC_LAMBDA: printf("[LAMBDA "); break; - case TC_PRIMITIVE: printf("[PRIMITIVE "); break; - case TC_SEQUENCE_2: printf("[SEQUENCE-2 "); break; - case TC_PCOMB1: printf("[PCOMB1 "); break; - case TC_CONTROL_POINT: printf("[CONTROL-POINT "); break; - case TC_ACCESS: printf("[ACCESS "); break; - case TC_DEFINITION: printf("[DEFINITION "); break; - case TC_ASSIGNMENT: printf("[ASSIGNMENT "); break; - case TC_HUNK3: printf("[HUNK3 "); break; - case TC_IN_PACKAGE: printf("[IN-PACKAGE "); break; - case TC_COMBINATION: printf("[COMBINATION "); break; - case TC_COMPILED_EXPRESSION: printf("[COMPILED-EXPRESSION "); break; - case TC_LEXPR: printf("[LEXPR "); break; - case TC_PCOMB3: printf("[PCOMB3 "); break; - - case TC_VARIABLE: printf("[VARIABLE "); break; - case TC_THE_ENVIRONMENT: printf("[THE-ENVIRONMENT "); break; - case TC_FUTURE: printf("[FUTURE "); break; - case TC_VECTOR_1B: printf("[VECTOR-1B "); break; - case TC_PCOMB0: printf("[PCOMB0 "); break; - case TC_VECTOR_16B: printf("[VECTOR-16B "); break; - case TC_SEQUENCE_3: printf("[SEQUENCE-3 "); break; - case TC_CONDITIONAL: printf("[CONDITIONAL "); break; - case TC_DISJUNCTION: printf("[DISJUNCTION "); break; - case TC_CELL: printf("[CELL "); break; - case TC_WEAK_CONS: printf("[WEAK-CONS "); break; - case TC_REFERENCE_TRAP: printf("[REFERENCE-TRAP "); break; - case TC_RETURN_ADDRESS: printf("[RETURN-ADDRESS "); break; - case TC_COMPILER_LINK: printf("[COMPILER-LINK "); break; - case TC_STACK_ENVIRONMENT: printf("[STACK-ENVIRONMENT "); break; - case TC_COMPLEX: printf("[COMPLEX "); break; - case TC_QUAD: printf("[QUAD "); break; - default: printf("[02x%x ", Type); break; - } - printf("%x]\n", Points_To); -} - -main(argc, argv) -int argc; -char **argv; -{ Pointer *Next; - long i; - if (argc == 1) - { if (!Read_Header()) - { fprintf(stderr, "Input does not appear to be in FASL format.\n"); - exit(1); - } - printf("Dumped object at 0x%x\n", Relocate(Dumped_Object)); - if (Sub_Version >= FASL_LONG_HEADER) - printf("External primitives at 0x%x\n\n", Relocate(Ext_Prim_Vector)); - } - else - { Const_Count = 0; - sscanf(argv[1], "%x", &Heap_Base); - sscanf(argv[2], "%x", &Const_Base); - sscanf(argv[3], "%d", &Heap_Count); - printf("Heap Base = 0x%08x; Constant Base = 0x%08x; Heap Count = %d\n", - Heap_Base, Const_Base, Heap_Count); - } - Data = (Pointer *) malloc(sizeof(Pointer) * (Heap_Count + Const_Count)); - end_of_memory = &Data[Heap_Count + Const_Count]; - Load_Data(Heap_Count + Const_Count, Data); - printf("Heap contents\n\n"); - for (Next=Data, i=0; i < Heap_Count; Next++, i++) - if (Safe_Type_Code(*Next)==TC_MANIFEST_NM_VECTOR) - { long j, count = Get_Integer(*Next); - Display(i, Type_Code(*Next), Address(*Next)); - Next += 1; - for (j=0; j < count ; j++, Next++) - printf(" %02x%06x\n", - Type_Code(*Next), Address(*Next)); - i += count; - Next -= 1; - } - else Display(i, Type_Code(*Next), Address(*Next)); - printf("\n\nConstant space\n\n"); - for (; i < Heap_Count+Const_Count; Next++, i++) - if (Safe_Type_Code(*Next)==TC_MANIFEST_NM_VECTOR) - { long j, count = Get_Integer(*Next); - Display(i, Type_Code(*Next), Address(*Next)); - Next += 1; - for (j=0; j < count ; j++, Next++) - printf(" %02x%06x\n", - Type_Code(*Next), Address(*Next)); - i += count; - Next -= 1; - } - else Display(i, Type_Code(*Next), Address(*Next)); -} diff --git a/v8/src/microcode/psbmap.h b/v8/src/microcode/psbmap.h deleted file mode 100644 index cd440c2ff..000000000 --- a/v8/src/microcode/psbmap.h +++ /dev/null @@ -1,268 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbmap.h,v 9.21 1987/01/22 14:33:52 jinx Rel $ - * - * This file contains macros and declarations for Bintopsb.c - * and Psbtobin.c - * - */ - -/* These definitions insure that the appropriate code is extracted - from the included files. -*/ - -#include -#define fast register - -#include "config.h" -#include "object.h" -#include "bignum.h" -#include "gc.h" -#include "types.h" -#include "sdata.h" -#include "const.h" -#include "gccode.h" -#include "character.h" - -#ifdef HAS_FREXP -extern double frexp(), ldexp(); -#else -#include "missing.c" -#endif - -#define PORTABLE_VERSION 1 - -/* Number of objects which, when traced recursively, point at all other - objects dumped. Currently the dumped object and the external - primitives vector. - */ - -#define NROOTS 2 - -/* Types to recognize external object references. Any occurrence of these - (which are external types and thus handled separately) means a reference - to an external object. - */ - -#define CONSTANT_CODE TC_BIG_FIXNUM -#define HEAP_CODE TC_FIXNUM - -#define fixnum_to_bits FIXNUM_LENGTH -#define bignum_to_bits(len) ((len) * SHIFT) -#define bits_to_bigdigit(nbits) (((nbits) + (SHIFT-1)) / SHIFT) - -#define hex_digits(nbits) (((nbits) + 3) / 4) - -#define to_pointer(size) \ - (((size) + (sizeof(Pointer) - 1)) / sizeof(Pointer)) - -#define bigdigit_to_pointer(ndig) \ - to_pointer((ndig) * sizeof(bigdigit)) - -/* This assumes that a bignum header is 2 Pointers. - The bignum code is not very portable, unfortunately */ - -#define bignum_header_to_pointer Align(0) - -#define float_to_pointer \ - to_pointer(sizeof(double)) -#define flonum_to_pointer(nchars) \ - ((nchars) * (1 + float_to_pointer)) - -#define char_to_pointer(nchars) \ - to_pointer(nchars) -#define pointer_to_char(npoints) \ - ((npoints) * sizeof(Pointer)) - -/* Global data */ - -/* If true, make all integers fixnums if possible, and all strings as - short as possible (trim extra stuff). */ - -static Boolean Compact_P = true; - -/* If true, null out all elements of random non-marked vectors. */ - -static Boolean Null_NMV = false; - -#ifndef Heap_In_Low_Memory -static Pointer *Memory_Base; -#endif - -static FILE *Input_File, *Output_File; - -static char *Program_Name; - -/* Status flags */ - -#define COMPACT_P 1 -#define NULL_NMV 2 - -#define Make_Flags() \ -((Compact_P ? COMPACT_P : 0) | \ - (Null_NMV ? NULL_NMV : 0)) - -#define Read_Flags(f) \ -Compact_P = ((f) & COMPACT_P); \ -Null_NMV = ((f) & NULL_NMV) - -/* Argument List Parsing */ - -struct Option_Struct { char *name; - Boolean value; - Boolean *ptr; - }; - -Boolean strequal(s1, s2) -fast char *s1, *s2; -{ while (*s1 != '\0') - if (*s1++ != *s2++) return false; - return (*s2 == '\0'); -} - -char *Find_Options(argc, argv, Noptions, Options) -int argc; -char **argv; -int Noptions; -struct Option_Struct Options[]; -{ for ( ; --argc >= 0; argv++) - { char *this = *argv; - int n; - for (n = 0; - ((n < Noptions) && (!strequal(this, Options[n].name))); - n++) ; - if (n >= Noptions) return this; - *(Options[n].ptr) = Options[n].value; - } - return NULL; -} - -/* Usage information */ - -Print_Options(n, options, where) -int n; -struct Option_Struct *options; -FILE *where; -{ if (--n < 0) return; - fprintf(where, "[%s]", options->name); - options += 1; - for (; --n >= 0; options += 1) - fprintf(where, " [%s]", options->name); - return; -} - -Print_Usage_and_Exit(noptions, options, io_options) -int noptions; -struct Option_Struct *options; -char *io_options; -{ fprintf(stderr, "usage: %s%s%s", - Program_Name, - (((io_options == NULL) || - (io_options[0] == '\0')) ? "" : " "), - io_options); - if (noptions != 0) - { putc(' ', stderr); - Print_Options(noptions, options, stderr); - } - putc('\n', stderr); - exit(1); -} - -/* Top level of program */ - -/* When debugging force arguments on command line */ - -#ifdef DEBUG -#undef unix -#endif - -#ifdef unix - -/* On unix use io redirection */ - -Setup_Program(argc, argv, Noptions, Options) -int argc; -char *argv[]; -int Noptions; -struct Option_Struct *Options; -{ extern do_it(); - Program_Name = argv[0]; - Input_File = stdin; - Output_File = stdout; - if (((argc - 1) > Noptions) || - (Find_Options((argc - 1), &argv[1], Noptions, Options) != NULL)) - Print_Usage_and_Exit(Noptions, Options, ""); - do_it(); - return; -} - -#else - -/* Otherwise use command line arguments */ - -Setup_Program(argc, argv, Noptions, Options) -int argc; -char *argv[]; -int Noptions; -struct Option_Struct *Options; -{ extern do_it(); - Program_Name = argv[0]; - if ((argc < 3) || - ((argc - 3) > Noptions) || - (Find_Options((argc - 3), &argv[3], Noptions, Options) != NULL)) - Print_Usage_and_Exit(Noptions, Options, "input_file output_file"); - Input_File = ((strequal(argv[1], "-")) ? - stdin : - fopen(argv[1], "r")); - if (Input_File == NULL) - { perror("Open failed."); - exit(1); - } - Output_File = ((strequal(argv[2], "-")) ? - stdout : - fopen(argv[2], "w")); - if (Output_File == NULL) - { perror("Open failed."); - fclose(Input_File); - exit(1); - } - fprintf(stderr, "%s: Reading from %s, writing to %s.\n", - Program_Name, argv[1], argv[2]); - do_it(); - fclose(Input_File); - fclose(Output_File); - return; -} - -#endif - diff --git a/v8/src/microcode/psbtobin.c b/v8/src/microcode/psbtobin.c deleted file mode 100644 index ec0a158bd..000000000 --- a/v8/src/microcode/psbtobin.c +++ /dev/null @@ -1,622 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbtobin.c,v 9.23 1987/04/16 02:06:10 jinx Exp $ - * - * This File contains the code to translate portable format binary - * files to internal format. - * - */ - -/* Cheap renames */ - -#define Portable_File Input_File -#define Internal_File Output_File - -#include "translate.h" - -static long Dumped_Object_Addr, Dumped_Ext_Prim_Addr; -static long Dumped_Heap_Base, Heap_Objects, Heap_Count; -static long Dumped_Constant_Base, Constant_Objects, Constant_Count; -static long Dumped_Pure_Base, Pure_Objects, Pure_Count; -static Pointer *Heap; -static Pointer *Heap_Base, *Heap_Table, *Heap_Object_Base, *Free; -static Pointer *Constant_Base, *Constant_Table, - *Constant_Object_Base, *Free_Constant; -static Pointer *Pure_Base, *Pure_Table, *Pure_Object_Base, *Free_Pure; -static Pointer *Stack_Top; - -Write_Data(Count, From_Where) -long Count; -Pointer *From_Where; -{ fwrite(((char *) From_Where), sizeof(Pointer), Count, Internal_File); -} - -#include "dump.c" - -#define OUT(c) return ((long) ((c) & MAX_CHAR)) - -long read_a_char() -{ fast char C = getc(Portable_File); - if (C != '\\') OUT(C); - C = getc(Portable_File); - switch(C) - { case 'n': OUT('\n'); - case 't': OUT('\n'); - case 'r': OUT('\r'); - case 'f': OUT('\f'); - case '0': OUT('\0'); - case 'X': - { long Code; - fprintf(stderr, - "%s: File is not Portable. Character Code Found.\n", - Program_Name); - fscanf(Portable_File, "%d", &Code); - getc(Portable_File); /* Space */ - OUT(Code); - } - case '\\': OUT('\\'); - default : OUT(C); - } -} - -Pointer *read_a_string(To, Slot) -Pointer *To, *Slot; -{ long maxlen, len, Pointer_Count; - fast char *string = ((char *) (&To[STRING_CHARS])); - *Slot = Make_Pointer(TC_CHARACTER_STRING, To); - fscanf(Portable_File, "%ld %ld", &maxlen, &len); - maxlen += 1; /* Null terminated */ - Pointer_Count = STRING_CHARS + char_to_pointer(maxlen); - To[STRING_HEADER] = - Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1)); - To[STRING_LENGTH] = Make_Non_Pointer(TC_FIXNUM, len); - getc(Portable_File); /* Space */ - while (--len >= 0) *string++ = ((char) read_a_char()); - *string = '\0'; - return (To + Pointer_Count); -} - -Pointer *read_an_integer(The_Type, To, Slot) -int The_Type; -Pointer *To; -Pointer *Slot; -{ Boolean negative; - long size_in_bits; - - getc(Portable_File); /* Space */ - negative = ((getc(Portable_File)) == '-'); - fscanf(Portable_File, "%ld", &size_in_bits); - if ((size_in_bits <= fixnum_to_bits) && - (The_Type == TC_FIXNUM)) - { fast long Value = 0; - fast int Normalization; - fast long ndigits; - long digit; - if (size_in_bits != 0) - for(Normalization = 0, - ndigits = hex_digits(size_in_bits); - --ndigits >= 0; - Normalization += 4) - { fscanf(Portable_File, "%1lx", &digit); - Value += (digit << Normalization); - } - if (negative) Value = -Value; - *Slot = Make_Non_Pointer(TC_FIXNUM, Value); - return To; - } - else if (size_in_bits == 0) - { bigdigit *REG = BIGNUM(To); - Prepare_Header(REG, 0, POSITIVE); - *Slot = Make_Pointer(TC_BIG_FIXNUM, To); - return (To + Align(0)); - } - else - { fast bigdigit *The_Bignum; - fast long size, nbits, ndigits; - fast unsigned long Temp; - long Length; - if ((The_Type == TC_FIXNUM) && (!Compact_P)) - fprintf(stderr, - "%s: Fixnum too large, coercing to bignum.\n", - Program_Name); - size = bits_to_bigdigit(size_in_bits); - ndigits = hex_digits(size_in_bits); - Length = Align(size); - The_Bignum = BIGNUM(To); - Prepare_Header(The_Bignum, size, (negative ? NEGATIVE : POSITIVE)); - for (The_Bignum = Bignum_Bottom(The_Bignum), nbits = 0, Temp = 0; - --size >= 0; - ) - { for ( ; - (nbits < SHIFT) && (ndigits > 0); - ndigits -= 1, nbits += 4) - { long digit; - fscanf(Portable_File, "%1lx", &digit); - Temp |= (((unsigned long) digit) << nbits); - } - *The_Bignum++ = Rem_Radix(Temp); - Temp = Div_Radix(Temp); - nbits -= SHIFT; - } - *Slot = Make_Pointer(TC_BIG_FIXNUM, To); - return (To + Length); - } -} - -/* Underflow and Overflow */ - -/* dflmax and dflmin exist in the Berserkely FORTRAN library */ - -static double the_max = 0.0; - -#define dflmin() 0.0 /* Cop out */ -#define dflmax() ((the_max == 0.0) ? compute_max() : the_max) - -double compute_max() -{ fast double Result = 0.0; - fast int expt; - for (expt = MAX_FLONUM_EXPONENT; - expt != 0; - expt >>= 1) - Result += ldexp(1.0, expt); - the_max = Result; - return Result; -} - -double read_a_flonum() -{ Boolean negative; - long size_in_bits, exponent; - fast double Result; - - getc(Portable_File); /* Space */ - negative = ((getc(Portable_File)) == '-'); - fscanf(Portable_File, "%ld %ld", &exponent, &size_in_bits); - if (size_in_bits == 0) Result = 0.0; - else if ((exponent > MAX_FLONUM_EXPONENT) || - (exponent < -MAX_FLONUM_EXPONENT)) - { /* Skip over mantissa */ - while (getc(Portable_File) != '\n') ; - fprintf(stderr, - "%s: Floating point exponent too %s!\n", - Program_Name, - ((exponent < 0) ? "small" : "large")); - Result = ((exponent < 0) ? dflmin() : dflmax()); - } - else - { fast long ndigits; - fast double Normalization; - long digit; - if (size_in_bits > FLONUM_MANTISSA_BITS) - fprintf(stderr, - "%s: Some precision may be lost.", - Program_Name); - getc(Portable_File); /* Space */ - for (ndigits = hex_digits(size_in_bits), - Result = 0.0, - Normalization = (1.0 / 16.0); - --ndigits >= 0; - Normalization /= 16.0) - { - fscanf(Portable_File, "%1lx", &digit); - Result += (((double ) digit) * Normalization); - } - Result = ldexp(Result, ((int) exponent)); - } - if (negative) Result = -Result; - return Result; -} - -Pointer * -Read_External(N, Table, To) - long N; - fast Pointer *Table, *To; -{ - fast Pointer *Until = &Table[N]; - int The_Type; - - while (Table < Until) - { - fscanf(Portable_File, "%2x", &The_Type); - switch(The_Type) - { - case TC_CHARACTER_STRING: - To = read_a_string(To, Table++); - continue; - case TC_FIXNUM: - case TC_BIG_FIXNUM: - To = read_an_integer(The_Type, To, Table++); - continue; - case TC_CHARACTER: - { - long the_char_code; - - getc(Portable_File); /* Space */ - fscanf( Portable_File, "%3x", &the_char_code); - *Table++ = Make_Non_Pointer( TC_CHARACTER, the_char_code); - continue; - } - case TC_BIG_FLONUM: - { - double The_Flonum = read_a_flonum(); - - Align_Float(To); - *Table++ = Make_Pointer(TC_BIG_FLONUM, To); - *To++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (float_to_pointer)); - *((double *) To) = The_Flonum; - To += float_to_pointer; - continue; - } - default: - fprintf(stderr, - "%s: Unknown external object found; Type = 0x%02x\n", - Program_Name, The_Type); - exit(1); - } - } - return To; -} - -#if false -Move_Memory(From, N, To) -fast Pointer *From, *To; -long N; -{ fast Pointer *Until = &From[N]; - while (From < Until) *To++ = *From++; - return; -} -#endif - -Relocate_Objects(From, N, disp) -fast Pointer *From; -long N; -fast long disp; -{ fast Pointer *Until = &From[N]; - while (From < Until) - { switch(Type_Code(*From)) - { case TC_FIXNUM: - case TC_CHARACTER: - From += 1; - break; - case TC_BIG_FIXNUM: - case TC_BIG_FLONUM: - case TC_CHARACTER_STRING: - *From++ == Make_Object(Type_Code(*From), (disp + Datum(*From))); - break; - default: - fprintf(stderr, - "%s: Unknown External Object Reference with Type 0x%02x", - Program_Name, - Type_Code(*From)); - } - } -} - -#define Relocate_Into(Where, Addr) \ -if ((Addr) < Dumped_Pure_Base) \ - (Where) = &Heap_Object_Base[(Addr) - Dumped_Heap_Base]; \ -else if ((Addr) < Dumped_Constant_Base) \ - (Where) = &Pure_Base[(Addr) - Dumped_Pure_Base]; \ -else (Where) = &Constant_Base[(Addr) - Dumped_Constant_Base]; - -#ifndef Conditional_Bug - -#define Relocate(Addr) \ -(((Addr) < Dumped_Pure_Base) ? \ - &Heap_Object_Base[(Addr) - Dumped_Heap_Base] : \ - (((Addr) < Dumped_Constant_Base) ? \ - &Pure_Base[(Addr) - Dumped_Pure_Base] : \ - &Constant_Base[(Addr) - Dumped_Constant_Base])) - -#else -static Pointer *Relocate_Temp; -#define Relocate(Addr) \ - (Relocate_Into(Relocate_Temp, Addr), Relocate_Temp) -#endif - -Pointer *Read_Pointers_and_Relocate(N, To) -fast long N; -fast Pointer *To; -{ int The_Type; - long The_Datum; -/* Align_Float(To); */ - while (--N >= 0) - { fscanf(Portable_File, "%2x %lx", &The_Type, &The_Datum); - switch(The_Type) - { case CONSTANT_CODE: - *To++ = Constant_Table[The_Datum]; - continue; - - case HEAP_CODE: - *To++ = Heap_Table[The_Datum]; - continue; - - case TC_MANIFEST_NM_VECTOR: - if (!(Null_NMV)) /* Unknown object! */ - fprintf(stderr, "%s: File is not portable: NMH found\n", - Program_Name); - *To++ = Make_Non_Pointer(The_Type, The_Datum); - { fast long count = The_Datum; - N -= count; - while (--count >= 0) - { fscanf(Portable_File, "%2x %lx", &The_Type, &The_Datum); - *To++ = Make_Non_Pointer(The_Type, The_Datum); - } - } - continue; - - case TC_BROKEN_HEART: - if (The_Datum != 0) - { fprintf(stderr, "%s: Broken Heart Found\n", Program_Name); - exit(1); - } - /* Fall Through */ - case TC_PRIMITIVE_EXTERNAL: - case TC_MANIFEST_SPECIAL_NM_VECTOR: - case_simple_Non_Pointer: - *To++ = Make_Non_Pointer(The_Type, The_Datum); - continue; - - case TC_REFERENCE_TRAP: - if (The_Datum <= TRAP_MAX_IMMEDIATE) - { - *To++ = Make_Non_Pointer(The_Type, The_Datum); - continue; - } - /* It is a pointer, fall through. */ - default: - /* Should be stricter */ - *To++ = Make_Pointer(The_Type, Relocate(The_Datum)); - continue; - } - } -/* Align_Float(To); */ - return To; -} - -#ifdef DEBUG -Print_External_Objects(area_name, Table, N) -char *area_name; -fast Pointer *Table; -fast long N; -{ fast Pointer *Table_End = &Table[N]; - - fprintf(stderr, "%s External Objects:\n", area_name); - fprintf(stderr, "Table = 0x%x; N = %d\n", Table, N); - - for( ; Table < Table_End; Table++) - switch (Type_Code(*Table)) - { case TC_FIXNUM: - { long The_Number; - Sign_Extend(*Table, The_Number); - fprintf(stderr, - "Table[%6d] = Fixnum %d\n", - (N-(Table_End-Table)), - The_Number); - break; - } - case TC_CHARACTER: - fprintf(stderr, - "Table[%6d] = Character %c = 0x%02x\n", - (N-(Table_End-Table)), - Get_Integer(*Table), - Get_Integer(*Table)); - break; - -/* Print_External_Objects continues on the next page */ - -/* Print_External_Objects, continued */ - - case TC_CHARACTER_STRING: - fprintf(stderr, - "Table[%6d] = string \"%s\"\n", - (N-(Table_End-Table)), - ((char *) Nth_Vector_Loc(*Table, STRING_CHARS))); - break; - case TC_BIG_FIXNUM: - fprintf(stderr, - "Table[%6d] = Bignum\n", - (N-(Table_End-Table))); - break; - case TC_BIG_FLONUM: - fprintf(stderr, - "Table[%6d] = Flonum %lf\n", - (N-(Table_End-Table)), - (* ((double *) Nth_Vector_Loc(*Table, 1)))); - break; - default: - fprintf(stderr, - "Table[%6d] = Unknown External Object 0x%8x\n", - (N-(Table_End-Table)), - *Table); - break; - } -} -#endif - -long Read_Header_and_Allocate() -{ long Portable_Version, Flags, Version, Sub_Version; - long NFlonums, NIntegers, NStrings, NBits, NChars; - long Size; - - /* Read Header */ - - fscanf(Input_File, "%ld %ld %ld %ld", - &Portable_Version, &Flags, &Version, &Sub_Version); - fscanf(Input_File, "%ld %ld %ld", - &Heap_Count, &Dumped_Heap_Base, &Heap_Objects); - fscanf(Input_File, "%ld %ld %ld", - &Constant_Count, &Dumped_Constant_Base, &Constant_Objects); - fscanf(Input_File, "%ld %ld %ld", - &Pure_Count, &Dumped_Pure_Base, &Pure_Objects); - fscanf(Input_File, "%ld %ld %ld %ld %ld", - &NFlonums, &NIntegers, &NStrings, &NBits, &NChars); - fscanf(Input_File, "%ld %ld", - &Dumped_Object_Addr, &Dumped_Ext_Prim_Addr); - - if ((Portable_Version != PORTABLE_VERSION) || - (Version != FASL_FORMAT_VERSION) || - (Sub_Version != FASL_SUBVERSION)) - { fprintf(stderr, - "FASL File Version %4d Subversion %4d Portable Version %4d\n", - Version, Sub_Version , Portable_Version); - fprintf(stderr, - "Expected: Version %4d Subversion %4d Portable Version %4d\n", - FASL_FORMAT_VERSION, FASL_SUBVERSION, PORTABLE_VERSION); - exit(1); - } - - Read_Flags(Flags); - - Size = (6 + /* SNMV */ - HEAP_BUFFER_SPACE + - Heap_Count + Heap_Objects + - Constant_Count + Constant_Objects + - Pure_Count + Pure_Objects + - flonum_to_pointer(NFlonums) + - ((NIntegers * bignum_header_to_pointer) + - (bigdigit_to_pointer(bits_to_bigdigit(NBits)))) + - ((NStrings * STRING_CHARS) + (char_to_pointer(NChars)))); - - Allocate_Heap_Space(Size); - if (Heap == NULL) - { fprintf(stderr, - "%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n", - Program_Name, Size); - exit(1); - } - Heap += HEAP_BUFFER_SPACE; - Initial_Align_Float(Heap); - return (Size - HEAP_BUFFER_SPACE); -} - -do_it() -{ long Size; - Size = Read_Header_and_Allocate(); - Stack_Top = &Heap[Size]; - - Heap_Table = &Heap[0]; - Heap_Base = &Heap_Table[Heap_Objects]; - Heap_Object_Base = - Read_External(Heap_Objects, Heap_Table, Heap_Base); - - Pure_Table = &Heap_Object_Base[Heap_Count]; - Pure_Base = &Pure_Table[Pure_Objects + 2]; /* SNMV */ - Pure_Object_Base = - Read_External(Pure_Objects, Pure_Table, Pure_Base); - - Constant_Table = &Heap[Size - Constant_Objects]; - Constant_Base = &Pure_Object_Base[Pure_Count + 2]; /* SNMV */ - Constant_Object_Base = - Read_External(Constant_Objects, Constant_Table, Constant_Base); - -#ifdef DEBUG - Print_External_Objects("Heap", Heap_Table, Heap_Objects); - Print_External_Objects("Pure", Pure_Table, Pure_Objects); - Print_External_Objects("Constant", Constant_Table, Constant_Objects); -#endif - - /* Read the normal objects */ - - Free = - Read_Pointers_and_Relocate(Heap_Count, Heap_Object_Base); - Free_Pure = - Read_Pointers_and_Relocate(Pure_Count, Pure_Object_Base); - Free_Constant = - Read_Pointers_and_Relocate(Constant_Count, Constant_Object_Base); - - /* Dump the objects */ - - { Pointer *Dumped_Object, *Dumped_Ext_Prim; - Relocate_Into(Dumped_Object, Dumped_Object_Addr); - Relocate_Into(Dumped_Ext_Prim, Dumped_Ext_Prim_Addr); - -#ifdef DEBUG - fprintf(stderr, "Dumping:\n"); - fprintf(stderr, - "Heap = 0x%x; Heap Count = %d\n", - Heap_Base, (Free - Heap_Base)); - fprintf(stderr, - "Pure Space = 0x%x; Pure Count = %d\n", - Pure_Base, (Free_Pure - Pure_Base)); - fprintf(stderr, - "Constant Space = 0x%x; Constant Count = %d\n", - Constant_Base, (Free_Constant - Constant_Base)); - fprintf(stderr, - "& Dumped Object = 0x%x; Dumped Object = 0x%x\n", - Dumped_Object, *Dumped_Object); - fprintf(stderr, - "& Dumped Ext Prim = 0x%x; Dumped Ext Prim = 0x%x\n", - Dumped_Ext_Prim, *Dumped_Ext_Prim); -#endif - - /* Is there a Pure/Constant block? */ - - if ((Constant_Objects == 0) && (Constant_Count == 0) && - (Pure_Objects == 0) && (Pure_Count == 0)) - Write_File((Free - Heap_Base), Heap_Base, Dumped_Object, - 0, &Heap[Size], Dumped_Ext_Prim); - else - { long Pure_Length = (Constant_Base - Pure_Base) + 1; - long Total_Length = (Free_Constant - Pure_Base) + 4; - Pure_Base[-2] = - Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, (Pure_Length - 1)); - Pure_Base[-1] = - Make_Non_Pointer(PURE_PART, Total_Length); - Constant_Base[-2] = - Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1); - Constant_Base[-1] = - Make_Non_Pointer(CONSTANT_PART, (Pure_Length - 1)); - Free_Constant[0] = - Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1); - Free_Constant[1] = - Make_Non_Pointer(END_OF_BLOCK, Total_Length); - - Write_File((Free - Heap_Base), Heap_Base, Dumped_Object, - Total_Length, (Pure_Base - 2), Dumped_Ext_Prim); - } - } - return; -} - -/* Top level */ - -static int Noptions = 0; -/* C does not usually like empty initialized arrays, so ... */ -static struct Option_Struct Options[] = {{"dummy", true, NULL}}; - -main(argc, argv) -int argc; -char *argv[]; -{ Setup_Program(argc, argv, Noptions, Options); - return; -} diff --git a/v8/src/microcode/returns.h b/v8/src/microcode/returns.h deleted file mode 100644 index a63ff9990..000000000 --- a/v8/src/microcode/returns.h +++ /dev/null @@ -1,118 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/returns.h,v 9.22 1987/04/16 02:28:30 jinx Exp $ - * - * Return codes. These are placed in Return when an - * interpreter operation needs to operate in several - * phases. This must correspond with UTABMD.SCM - * - */ - -/* These names are also in storage.c. - * Please maintain consistency. - */ - -#define RC_END_OF_COMPUTATION 0x00 -/* formerly RC_RESTORE_CONTROL_POINT 0x01 */ -#define RC_JOIN_STACKLETS 0x01 -#define RC_RESTORE_CONTINUATION 0x02 /* Used for 68000 */ -#define RC_INTERNAL_APPLY 0x03 -#define RC_BAD_INTERRUPT_CONTINUE 0x04 /* Used for 68000 */ -#define RC_RESTORE_HISTORY 0x05 -#define RC_INVOKE_STACK_THREAD 0x06 -#define RC_RESTART_EXECUTION 0x07 /* Used for 68000 */ -#define RC_EXECUTE_ASSIGNMENT_FINISH 0x08 -#define RC_EXECUTE_DEFINITION_FINISH 0x09 -#define RC_EXECUTE_ACCESS_FINISH 0x0A -#define RC_EXECUTE_IN_PACKAGE_CONTINUE 0x0B -#define RC_SEQ_2_DO_2 0x0C -#define RC_SEQ_3_DO_2 0x0D -#define RC_SEQ_3_DO_3 0x0E -#define RC_CONDITIONAL_DECIDE 0x0F -#define RC_DISJUNCTION_DECIDE 0x10 -#define RC_COMB_1_PROCEDURE 0x11 -#define RC_COMB_APPLY_FUNCTION 0x12 -#define RC_COMB_2_FIRST_OPERAND 0x13 -#define RC_COMB_2_PROCEDURE 0x14 -#define RC_COMB_SAVE_VALUE 0x15 -#define RC_PCOMB1_APPLY 0x16 -#define RC_PCOMB2_DO_1 0x17 -#define RC_PCOMB2_APPLY 0x18 -#define RC_PCOMB3_DO_2 0x19 -#define RC_PCOMB3_DO_1 0x1A -#define RC_PCOMB3_APPLY 0x1B - -#define RC_SNAP_NEED_THUNK 0x1C -#define RC_REENTER_COMPILED_CODE 0x1D -/* formerly RC_GET_CHAR_REPEAT 0x1E */ -#define RC_COMP_REFERENCE_RESTART 0x1F -#define RC_NORMAL_GC_DONE 0x20 -#define RC_COMPLETE_GC_DONE 0x21 /* Used for 68000 */ -#define RC_PURIFY_GC_1 0x22 -#define RC_PURIFY_GC_2 0x23 -#define RC_AFTER_MEMORY_UPDATE 0x24 /* Used for 68000 */ -#define RC_RESTARTABLE_EXIT 0x25 /* Used for 68000 */ -/* formerly RC_GET_CHAR 0x26 */ -/* formerly RC_GET_CHAR_IMMEDIATE 0x27 */ -#define RC_COMP_ASSIGNMENT_RESTART 0x28 -#define RC_POP_FROM_COMPILED_CODE 0x29 -#define RC_RETURN_TRAP_POINT 0x2A -#define RC_RESTORE_STEPPER 0x2B /* Used for 68000 */ -#define RC_RESTORE_TO_STATE_POINT 0x2C -#define RC_MOVE_TO_ADJACENT_POINT 0x2D -#define RC_RESTORE_VALUE 0x2E -#define RC_RESTORE_DONT_COPY_HISTORY 0x2F - -/* The following are not used in the 68000 implementation */ - -#define RC_POP_RETURN_ERROR 0x40 -#define RC_EVAL_ERROR 0x41 -#define RC_REPEAT_PRIMITIVE 0x42 -#define RC_COMP_INTERRUPT_RESTART 0x43 -/* formerly RC_COMP_RECURSION_GC 0x44 */ -#define RC_RESTORE_INT_MASK 0x45 -#define RC_HALT 0x46 -#define RC_FINISH_GLOBAL_INT 0x47 /* Multiprocessor */ -#define RC_REPEAT_DISPATCH 0x48 -#define RC_GC_CHECK 0x49 -#define RC_RESTORE_FLUIDS 0x4A -#define RC_COMP_LOOKUP_APPLY_RESTART 0x4B -#define RC_COMP_ACCESS_RESTART 0x4C -#define RC_COMP_UNASSIGNED_P_RESTART 0x4D -#define RC_COMP_UNBOUND_P_RESTART 0x4E -#define RC_COMP_DEFINITION_RESTART 0x4F -#define RC_COMP_LEXPR_INTERRUPT_RESTART 0x50 - -#define MAX_RETURN_CODE 0x50 - -/* When adding return codes, don't forget to update storage.c too. */ diff --git a/v8/src/microcode/trap.h b/v8/src/microcode/trap.h deleted file mode 100644 index c6634e1f4..000000000 --- a/v8/src/microcode/trap.h +++ /dev/null @@ -1,97 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/trap.h,v 9.37 1987/04/16 02:30:49 jinx Exp $ */ - -/* Kinds of traps: - - Note that for every trap there is a dangerous version. - The danger bit is the bottom bit of the trap number, - thus all dangerous traps are odd and viceversa. - - For efficiency, some traps are immediate, while some are - pointer objects. The type code is multiplexed, and the - garbage collector handles it specially. - - */ - -/* The following are immediate traps: */ - -#define TRAP_UNASSIGNED 0 -#define TRAP_UNASSIGNED_DANGEROUS 1 -#define TRAP_UNBOUND 2 -#define TRAP_UNBOUND_DANGEROUS 3 -#define TRAP_ILLEGAL 4 -#define TRAP_ILLEGAL_DANGEROUS 5 /* Unused. */ - -/* TRAP_MAX_IMMEDIATE is defined in const.h */ - -/* The following are not: */ - -#define TRAP_NOP 10 /* Unused. */ -#define TRAP_DANGEROUS 11 -#define TRAP_FLUID 12 -#define TRAP_FLUID_DANGEROUS 13 - -/* Trap utilities */ - -#define get_trap_kind(variable, what) \ -{ \ - variable = Datum(what); \ - if (variable > TRAP_MAX_IMMEDIATE) \ - variable = Datum(Vector_Ref(what, TRAP_TAG)); \ -} - -/* Common constants */ - -#ifndef b32 -#define UNASSIGNED_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNASSIGNED) -#define DANGEROUS_UNASSIGNED_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNASSIGNED_DANGEROUS) -#define UNBOUND_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNBOUND) -#define DANGEROUS_UNBOUND_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNBOUND_DANGEROUS) -#define ILLEGAL_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_ILLEGAL) -#define DANGEROUS_ILLEGAL_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_ILLEGAL_DANGEROUS) -#else -#define UNASSIGNED_OBJECT 0x32000000 -#define DANGEROUS_UNASSIGNED_OBJECT 0x32000001 -#define UNBOUND_OBJECT 0x32000002 -#define DANGEROUS_UNBOUND_OBJECT 0x32000003 -#define ILLEGAL_OBJECT 0x32000004 -#define DANGEROUS_ILLEGAL_OBJECT 0x32000005 -#endif - -#define DANGEROUS_OBJECT Make_Unsigned_Fixnum(TRAP_DANGEROUS) - -#if (TC_REFERENCE_TRAP != 0x32) -#include "error: trap.h and types.h are inconsistent" -#endif - diff --git a/v8/src/microcode/types.h b/v8/src/microcode/types.h deleted file mode 100644 index a6e1c9fcc..000000000 --- a/v8/src/microcode/types.h +++ /dev/null @@ -1,111 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/types.h,v 9.22 1987/04/03 00:21:38 jinx Exp $ - * - * Type code definitions, numerical order - * - */ - -#define TC_NULL 0x00 -#define TC_LIST 0x01 -#define TC_CHARACTER 0x02 -#define TC_SCODE_QUOTE 0x03 -#define TC_PCOMB2 0x04 -#define TC_UNINTERNED_SYMBOL 0x05 -#define TC_BIG_FLONUM 0x06 -#define TC_COMBINATION_1 0x07 -#define TC_TRUE 0x08 -#define TC_EXTENDED_PROCEDURE 0x09 -#define TC_VECTOR 0x0A -#define TC_RETURN_CODE 0x0B -#define TC_COMBINATION_2 0x0C -#define TC_COMPILED_PROCEDURE 0x0D -#define TC_BIG_FIXNUM 0x0E -#define TC_PROCEDURE 0x0F -#define TC_PRIMITIVE_EXTERNAL 0x10 -#define TC_DELAY 0x11 -#define TC_ENVIRONMENT 0x12 -#define TC_DELAYED 0x13 -#define TC_EXTENDED_LAMBDA 0x14 -#define TC_COMMENT 0x15 -#define TC_NON_MARKED_VECTOR 0x16 -#define TC_LAMBDA 0x17 -#define TC_PRIMITIVE 0x18 -#define TC_SEQUENCE_2 0x19 - -#define TC_FIXNUM 0x1A -#define TC_PCOMB1 0x1B -#define TC_CONTROL_POINT 0x1C -#define TC_INTERNED_SYMBOL 0x1D -#define TC_CHARACTER_STRING 0x1E -#define TC_ACCESS 0x1F -/* UNUSED 0x20 */ /* Used to be EXTENDED_FIXNUM. */ -#define TC_DEFINITION 0x21 -#define TC_BROKEN_HEART 0x22 -#define TC_ASSIGNMENT 0x23 -#define TC_HUNK3 0x24 -#define TC_IN_PACKAGE 0x25 -#define TC_COMBINATION 0x26 -#define TC_MANIFEST_NM_VECTOR 0x27 -#define TC_COMPILED_EXPRESSION 0x28 -#define TC_LEXPR 0x29 -#define TC_PCOMB3 0x2A -#define TC_MANIFEST_SPECIAL_NM_VECTOR 0x2B -#define TC_VARIABLE 0x2C -#define TC_THE_ENVIRONMENT 0x2D -#define TC_FUTURE 0x2E -#define TC_VECTOR_1B 0x2F -#define TC_PCOMB0 0x30 -#define TC_VECTOR_16B 0x31 -#define TC_REFERENCE_TRAP 0x32 /* Used to be UNASSIGNED. */ -#define TC_SEQUENCE_3 0x33 -#define TC_CONDITIONAL 0x34 -#define TC_DISJUNCTION 0x35 -#define TC_CELL 0x36 -#define TC_WEAK_CONS 0x37 -#define TC_QUAD 0x38 /* Used to be TC_TRAP. */ -#define TC_RETURN_ADDRESS 0x39 -#define TC_COMPILER_LINK 0x3A -#define TC_STACK_ENVIRONMENT 0x3B -#define TC_COMPLEX 0x3C - -/* If you add a new type, don't forget to update gccode.h and gctype.c */ - -/* Aliases */ - -#define TC_FALSE TC_NULL -#define TC_MANIFEST_VECTOR TC_NULL -#define GLOBAL_ENV TC_NULL -#define TC_BIT_STRING TC_VECTOR_1B -#define TC_VECTOR_8B TC_CHARACTER_STRING -#define TC_ADDRESS TC_FIXNUM diff --git a/v8/src/microcode/utabmd.scm b/v8/src/microcode/utabmd.scm deleted file mode 100644 index 100c49ad8..000000000 --- a/v8/src/microcode/utabmd.scm +++ /dev/null @@ -1,857 +0,0 @@ -;;; -*-Scheme-*- -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions 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 MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. 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. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Machine Dependent Type Tables - -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.25 1987/04/16 02:32:05 jinx Exp $ - -(declare (usual-integrations)) - -;;; For quick access to any given table, -;;; search for the following strings: -;;; -;;; [] Fixed -;;; [] Types -;;; [] Returns -;;; [] Primitives -;;; [] External -;;; [] Errors -;;; [] Identification - -;;; [] Fixed - -(vector-set! (get-fixed-objects-vector) - #x0F ;(fixed-objects-vector-slot 'MICROCODE-FIXED-OBJECTS-SLOTS) - #(NON-OBJECT ;00 - SYSTEM-INTERRUPT-VECTOR ;01 - SYSTEM-ERROR-VECTOR ;02 - OBARRAY ;03 - MICROCODE-TYPES-VECTOR ;04 - MICROCODE-RETURNS-VECTOR ;05 - MICROCODE-PRIMITIVES-VECTOR ;06 - MICROCODE-ERRORS-VECTOR ;07 - MICROCODE-IDENTIFICATION-VECTOR ;08 - #F ;09 - #F ;0A - GC-DAEMON ;0B - TRAP-HANDLER ;0C - #F ;0D - STEPPER-STATE ;0E - MICROCODE-FIXED-OBJECTS-SLOTS ;0F - MICROCODE-EXTERNAL-PRIMITIVES ;10 - STATE-SPACE-TAG ;11 - STATE-POINT-TAG ;12 - DUMMY-HISTORY ;13 - BIGNUM-ONE ;14 - SCHEDULER ;15 - MICROCODE-TERMINATIONS-VECTOR ;16 - MICROCODE-TERMINATIONS-PROCEDURES ;17 - FIXED-OBJECTS-VECTOR ;18 - THE-WORK-QUEUE ;19 - FUTURE-READS-LOGGER ;1A - TOUCHED-FUTURES-VECTOR ;1B - PRECIOUS-OBJECTS ;1C - ERROR-PROCEDURE ;1D - UNSNAPPED-LINK ;1E - MICROCODE-UTILITIES-VECTOR ;1F - COMPILER-ERROR-PROCEDURE ;20 - LOST-OBJECT-BASE ;21 - STATE-SPACE-ROOT ;22 - MICROCODE-TABLE-IDENTIFICATION ;23 - )) - -;;; [] Types - -(vector-set! (get-fixed-objects-vector) - 4 ;(fixed-objects-vector-slot 'MICROCODE-TYPES-VECTOR) - #((NULL FALSE MANIFEST-VECTOR GLOBAL-ENVIRONMENT) ;00 - (PAIR LIST) ;01 - CHARACTER ;02 - QUOTATION ;03 - PRIMITIVE-COMBINATION-2 ;04 - UNINTERNED-SYMBOL ;05 - (FLONUM BIG-FLONUM) ;06 - COMBINATION-1 ;07 - TRUE ;08 - EXTENDED-PROCEDURE ;09 - VECTOR ;0A - RETURN-ADDRESS ;0B - COMBINATION-2 ;0C - COMPILED-PROCEDURE ;0D - (BIGNUM BIG-FIXNUM) ;0E - PROCEDURE ;0F - PRIMITIVE-EXTERNAL ;10 - DELAY ;11 - ENVIRONMENT ;12 - DELAYED ;13 - EXTENDED-LAMBDA ;14 - COMMENT ;15 - NON-MARKED-VECTOR ;16 - LAMBDA ;17 - PRIMITIVE ;18 - SEQUENCE-2 ;19 - (FIXNUM ADDRESS) ;1A - PRIMITIVE-COMBINATION-1 ;1B - CONTROL-POINT ;1C - INTERNED-SYMBOL ;1D - (STRING CHARACTER-STRING VECTOR-8B) ;1E - ACCESS ;1F - #F ;20 - DEFINITION ;21 - BROKEN-HEART ;22 - ASSIGNMENT ;23 - (TRIPLE HUNK3) ;24 - IN-PACKAGE ;25 - COMBINATION ;26 - MANIFEST-NM-VECTOR ;27 - COMPILED-EXPRESSION ;28 - LEXPR ;29 - PRIMITIVE-COMBINATION-3 ;2A - MANIFEST-SPECIAL-NM-VECTOR ;2B - VARIABLE ;2C - THE-ENVIRONMENT ;2D - FUTURE ;2E - VECTOR-1B ;2F - PRIMITIVE-COMBINATION-0 ;30 - VECTOR-16B ;31 - (REFERENCE-TRAP UNASSIGNED) ;32 - SEQUENCE-3 ;33 - CONDITIONAL ;34 - DISJUNCTION ;35 - CELL ;36 - WEAK-CONS ;37 - QUAD ;38 - COMPILER-RETURN-ADDRESS ;39 - COMPILER-LINK ;3A - STACK-ENVIRONMENT ;3B - COMPLEX ;3C - #F ;3D - #F ;3E - #F ;3F - #F ;40 - #F ;41 - #F ;42 - #F ;43 - #F ;44 - #F ;45 - #F ;46 - #F ;47 - #F ;48 - #F ;49 - #F ;4A - #F ;4B - #F ;4C - #F ;4D - #F ;4E - #F ;4F - #F ;50 - #F ;51 - #F ;52 - #F ;53 - #F ;54 - #F ;55 - #F ;56 - #F ;57 - #F ;58 - #F ;59 - #F ;5A - #F ;5B - #F ;5C - #F ;5D - #F ;5E - #F ;5F - #F ;60 - #F ;61 - #F ;62 - #F ;63 - #F ;64 - #F ;65 - #F ;66 - #F ;67 - #F ;68 - #F ;69 - #F ;6A - #F ;6B - #F ;6C - #F ;6D - #F ;6E - #F ;6F - #F ;70 - #F ;71 - #F ;72 - #F ;73 - #F ;74 - #F ;75 - #F ;76 - #F ;77 - #F ;78 - #F ;79 - #F ;7A - #F ;7B - #F ;7C - #F ;7D - #F ;7E - #F ;7F - )) - -;;; [] Returns - -(vector-set! (get-fixed-objects-vector) - 5 ;(fixed-objects-vector-slot 'MICROCODE-RETURNS-VECTOR) - #(NON-EXISTENT-CONTINUATION ;00 - JOIN-STACKLETS ;01 - RESTORE-CONTINUATION ;02 - INTERNAL-APPLY ;03 - BAD-INTERRUPT-CONTINUE ;04 - RESTORE-HISTORY ;05 - INVOKE-STACK-THREAD ;06 - RESTART-EXECUTION ;07 - ASSIGNMENT-CONTINUE ;08 - DEFINITION-CONTINUE ;09 - ACCESS-CONTINUE ;0A - IN-PACKAGE-CONTINUE ;0B - SEQUENCE-2-SECOND ;0C - SEQUENCE-3-SECOND ;0D - SEQUENCE-3-THIRD ;0E - CONDITIONAL-DECIDE ;0F - DISJUNCTION-DECIDE ;10 - COMBINATION-1-PROCEDURE ;11 - COMBINATION-APPLY ;12 - COMBINATION-2-FIRST-OPERAND ;13 - COMBINATION-2-PROCEDURE ;14 - COMBINATION-SAVE-VALUE ;15 - PRIMITIVE-COMBINATION-1-APPLY ;16 - PRIMITIVE-COMBINATION-2-FIRST-OPERAND ;17 - PRIMITIVE-COMBINATION-2-APPLY ;18 - PRIMITIVE-COMBINATION-3-SECOND-OPERAND ;19 - PRIMITIVE-COMBINATION-3-FIRST-OPERAND ;1A - PRIMITIVE-COMBINATION-3-APPLY ;1B - FORCE-SNAP-THUNK ;1C - REENTER-COMPILED-CODE ;1D - #F ;1E - COMPILER-REFERENCE-RESTART ;1F - NORMAL-GARBAGE-COLLECT-DONE ;20 - COMPLETE-GARBAGE-COLLECT-DONE ;21 - PURIFY-AFTER-FIRST-GC ;22 - PURIFY-AFTER-SECOND-GC ;23 - AFTER-MEMORY-UPDATE ;24 - RETRY-MICROCODE-TERMINATION-RESTARTABLE ;25 - #F ;26 - #F ;27 - COMPILER-ASSIGNMENT-RESTART ;28 - POP-FROM-COMPILED-CODE ;29 - RETURN-TRAP-POINT ;2A - RESTORE-STEPPER ;2B - RESTORE-TO-STATE-POINT ;2C - MOVE-TO-ADJACENT-POINT ;2D - RESTORE-VALUE ;2E - RESTORE-DONT-COPY-HISTORY ;2F - #F ;30 - #F ;31 - #F ;32 - #F ;33 - #F ;34 - #F ;35 - #F ;36 - #F ;37 - #F ;38 - #F ;39 - #F ;3A - #F ;3B - #F ;3C - #F ;3D - #F ;3E - #F ;3F - POP-RETURN-ERROR ;40 - EVAL-ERROR ;41 - REPEAT-PRIMITIVE ;42 - COMPILER-INTERRUPT-RESTART ;43 - #F ;44 - RESTORE-INTERRUPT-MASK ;45 - HALT ;46 - FINISH-GLOBAL-INTERRUPT ;47 - REPEAT-DISPATCH ;48 - GC-CHECK ;49 - RESTORE-FLUIDS ;4A - COMPILER-LOOKUP-APPLY-RESTART ;4B - COMPILER-ACCESS-RESTART ;4C - COMPILER-UNASSIGNED?-RESTART ;4D - COMPILER-UNBOUND?-RESTART ;4E - COMPILER-DEFINITION-RESTART ;4F - COMPILER-LEXPR-INTERRUPT-RESTART ;50 - )) - -;;; [] Primitives - -(vector-set! (get-fixed-objects-vector) - 6 ;(fixed-objects-vector-slot 'MICROCODE-PRIMITIVES-VECTOR) - #(LEXICAL-ASSIGNMENT ;$00 - LOCAL-REFERENCE ;$01 - LOCAL-ASSIGNMENT ;$02 - CALL-WITH-CURRENT-CONTINUATION ;$03 - SCODE-EVAL ;$04 - APPLY ;$05 - SET-INTERRUPT-ENABLES! ;$06 - STRING->SYMBOL ;$07 - GET-WORK ;$08 - NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION ;$09 - CURRENT-DYNAMIC-STATE ;$0A - SET-CURRENT-DYNAMIC-STATE! ;$0B - (NULL? NOT FALSE?) ;$0C - EQ? ;$0D - STRING-EQUAL? ;$0E - PRIMITIVE-TYPE? ;$0F - PRIMITIVE-TYPE ;$10 - PRIMITIVE-SET-TYPE ;$11 - LEXICAL-REFERENCE ;$12 - LEXICAL-UNREFERENCEABLE? ;$13 - MAKE-CHAR ;$14 - CHAR-BITS ;$15 - EXIT ;$16 - CHAR-CODE ;$17 - LEXICAL-UNASSIGNED? ;$18 - INSERT-NON-MARKED-VECTOR! ;$19 - HALT ;$1A - CHAR->INTEGER ;$1B - MEMQ ;$1C - INSERT-STRING ;$1D - ENABLE-INTERRUPTS! ;$1E - MAKE-EMPTY-STRING ;$1F - CONS ;$20 - (CAR FIRST) ;$21 - (CDR FIRST-TAIL) ;$22 - (SET-CAR! SET-FIRST!) ;$23 - (SET-CDR! SET-FIRST-TAIL!) ;$24 - #F ;$25 - TTY-GET-CURSOR ;$26 - GENERAL-CAR-CDR ;$27 - HUNK3-CONS ;$28 - HUNK3-CXR ;$29 - HUNK3-SET-CXR! ;$2A - INSERT-STRING! ;$2B - VECTOR-CONS ;$2C - (VECTOR-LENGTH VECTOR-SIZE) ;$2D - VECTOR-REF ;$2E - SET-CURRENT-HISTORY! ;$2F - VECTOR-SET! ;$30 - NON-MARKED-VECTOR-CONS ;$31 - #F ;$32 - LEXICAL-UNBOUND? ;$33 - INTEGER->CHAR ;$34 - CHAR-DOWNCASE ;$35 - CHAR-UPCASE ;$36 - ASCII->CHAR ;$37 - CHAR-ASCII? ;$38 - CHAR->ASCII ;$39 - GARBAGE-COLLECT ;$3A - PLUS-FIXNUM ;$3B - MINUS-FIXNUM ;$3C - MULTIPLY-FIXNUM ;$3D - DIVIDE-FIXNUM ;$3E - EQUAL-FIXNUM? ;$3F - LESS-THAN-FIXNUM? ;$40 - POSITIVE-FIXNUM? ;$41 - ONE-PLUS-FIXNUM ;$42 - MINUS-ONE-PLUS-FIXNUM ;$43 - TRUNCATE-STRING! ;$44 - SUBSTRING ;$45 - ZERO-FIXNUM? ;$46 - MAKE-OBJECT-SAFE ;$47 - MAKE-OBJECT-DANGEROUS ;$48 - OBJECT-DANGEROUS? ;$49 - SUBSTRING->LIST ;$4A - MAKE-FILLED-STRING ;$4B - PLUS-BIGNUM ;$4C - MINUS-BIGNUM ;$4D - MULTIPLY-BIGNUM ;$4E - DIVIDE-BIGNUM ;$4F - LISTIFY-BIGNUM ;$50 - EQUAL-BIGNUM? ;$51 - LESS-THAN-BIGNUM? ;$52 - POSITIVE-BIGNUM? ;$53 - FILE-OPEN-CHANNEL ;$54 - FILE-CLOSE-CHANNEL ;$55 - PRIMITIVE-FASDUMP ;$56 - BINARY-FASLOAD ;$57 - STRING-POSITION ;$58 - STRING-LESS? ;$59 - #F ;$5A - #F ;$5B - REHASH ;$5C - LENGTH ;$5D - ASSQ ;$5E - LIST->STRING ;$5F - EQUAL-STRING-TO-LIST? ;$60 - MAKE-CELL ;$61 - CELL-CONTENTS ;$62 - CELL? ;$63 - CHARACTER-UPCASE ;$64 - CHARACTER-LIST-HASH ;$65 - GCD-FIXNUM ;$66 - COERCE-FIXNUM-TO-BIGNUM ;$67 - COERCE-BIGNUM-TO-FIXNUM ;$68 - PLUS-FLONUM ;$69 - MINUS-FLONUM ;$6A - MULTIPLY-FLONUM ;$6B - DIVIDE-FLONUM ;$6C - EQUAL-FLONUM? ;$6D - LESS-THAN-FLONUM? ;$6E - ZERO-BIGNUM? ;$6F - TRUNCATE-FLONUM ;$70 - ROUND-FLONUM ;$71 - COERCE-INTEGER-TO-FLONUM ;$72 - SINE-FLONUM ;$73 - COSINE-FLONUM ;$74 - ARCTAN-FLONUM ;$75 - EXP-FLONUM ;$76 - LN-FLONUM ;$77 - SQRT-FLONUM ;$78 - PRIMITIVE-FASLOAD ;$79 - GET-FIXED-OBJECTS-VECTOR ;$7A - SET-FIXED-OBJECTS-VECTOR! ;$7B - LIST->VECTOR ;$7C - SUBVECTOR->LIST ;$7D - PAIR? ;$7E - NEGATIVE-FIXNUM? ;$7F - NEGATIVE-BIGNUM? ;$80 - GREATER-THAN-FIXNUM? ;$81 - GREATER-THAN-BIGNUM? ;$82 - STRING-HASH ;$83 - SYSTEM-PAIR-CONS ;$84 - SYSTEM-PAIR? ;$85 - SYSTEM-PAIR-CAR ;$86 - SYSTEM-PAIR-CDR ;$87 - SYSTEM-PAIR-SET-CAR! ;$88 - SYSTEM-PAIR-SET-CDR! ;$89 - #F ;$8A - #F ;$8B - SET-CELL-CONTENTS! ;$8C - &MAKE-OBJECT ;$8D - SYSTEM-HUNK3-CXR0 ;$8E - SYSTEM-HUNK3-SET-CXR0! ;$8F - MAP-MACHINE-ADDRESS-TO-CODE ;$90 - SYSTEM-HUNK3-CXR1 ;$91 - SYSTEM-HUNK3-SET-CXR1! ;$92 - MAP-CODE-TO-MACHINE-ADDRESS ;$93 - SYSTEM-HUNK3-CXR2 ;$94 - SYSTEM-HUNK3-SET-CXR2! ;$95 - PRIMITIVE-PROCEDURE-ARITY ;$96 - SYSTEM-LIST-TO-VECTOR ;$97 - SYSTEM-SUBVECTOR-TO-LIST ;$98 - SYSTEM-VECTOR? ;$99 - SYSTEM-VECTOR-REF ;$9A - SYSTEM-VECTOR-SET! ;$9B - WITH-HISTORY-DISABLED ;$9C - #F ;$9D - #F ;$9E - #F ;$9F - #F ;$A0 - #F ;$A1 - #F ;$A2 - VECTOR-8B-CONS ;$A3 - VECTOR-8B? ;$A4 - VECTOR-8B-REF ;$A5 - VECTOR-8B-SET! ;$A6 - ZERO-FLONUM? ;$A7 - POSITIVE-FLONUM? ;$A8 - NEGATIVE-FLONUM? ;$A9 - GREATER-THAN-FLONUM? ;$AA - INTERN-CHARACTER-LIST ;$AB - #F ;$AC - (STRING-SIZE VECTOR-8B-SIZE) ;$AD - SYSTEM-VECTOR-SIZE ;$AE - FORCE ;$AF - PRIMITIVE-DATUM ;$B0 - MAKE-NON-POINTER-OBJECT ;$B1 - DEBUGGING-PRINTER ;$B2 - STRING-UPCASE ;$B3 - PRIMITIVE-PURIFY ;$B4 - #F ;$B5 - COMPLETE-GARBAGE-COLLECT ;$B6 - DUMP-BAND ;$B7 - SUBSTRING-SEARCH ;$B8 - LOAD-BAND ;$B9 - CONSTANT? ;$BA - PURE? ;$BB - PRIMITIVE-GC-TYPE ;$BC - PRIMITIVE-IMPURIFY ;$BD - WITH-THREADED-CONTINUATION ;$BE - WITHIN-CONTROL-POINT ;$BF - SET-RUN-LIGHT! ;$C0 - FILE-EOF? ;$C1 - FILE-READ-CHAR ;$C2 - FILE-FILL-INPUT-BUFFER ;$C3 - FILE-LENGTH ;$C4 - FILE-WRITE-CHAR ;$C5 - FILE-WRITE-STRING ;$C6 - CLOSE-LOST-OPEN-FILES ;$C7 - #F ;$C8 - WITH-INTERRUPTS-REDUCED ;$C9 - PRIMITIVE-EVAL-STEP ;$CA - PRIMITIVE-APPLY-STEP ;$CB - PRIMITIVE-RETURN-STEP ;$CC - TTY-READ-CHAR-READY? ;$CD - TTY-READ-CHAR ;$CE - TTY-READ-CHAR-IMMEDIATE ;$CF - TTY-READ-FINISH ;$D0 - BIT-STRING-ALLOCATE ;$D1 - MAKE-BIT-STRING ;$D2 - BIT-STRING? ;$D3 - BIT-STRING-LENGTH ;$D4 - BIT-STRING-REF ;$D5 - BIT-SUBSTRING-MOVE-RIGHT! ;$D6 - BIT-STRING-SET! ;$D7 - BIT-STRING-CLEAR! ;$D8 - BIT-STRING-ZERO? ;$D9 - #F ;$DA - #F ;$DB - UNSIGNED-INTEGER->BIT-STRING ;$DC - BIT-STRING->UNSIGNED-INTEGER ;$DD - #F ;$DE - READ-BITS! ;$DF - WRITE-BITS! ;$E0 - MAKE-STATE-SPACE ;$E1 - EXECUTE-AT-NEW-STATE-POINT ;$E2 - TRANSLATE-TO-STATE-POINT ;$E3 - GET-NEXT-CONSTANT ;$E4 - MICROCODE-IDENTIFY ;$E5 - ZERO? ;$E6 - POSITIVE? ;$E7 - NEGATIVE? ;$E8 - &= ;$E9 - &< ;$EA - &> ;$EB - &+ ;$EC - &- ;$ED - &* ;$EE - &/ ;$EF - INTEGER-DIVIDE ;$F0 - 1+ ;$F1 - -1+ ;$F2 - TRUNCATE ;$F3 - ROUND ;$F4 - FLOOR ;$F5 - CEILING ;$F6 - SQRT ;$F7 - EXP ;$F8 - LOG ;$F9 - SIN ;$FA - COS ;$FB - &ATAN ;$FC - TTY-WRITE-CHAR ;$FD - TTY-WRITE-STRING ;$FE - TTY-BEEP ;$FF - TTY-CLEAR ;$100 - GET-EXTERNAL-COUNTS ;$101 - GET-EXTERNAL-NAME ;$102 - GET-EXTERNAL-NUMBER ;$103 - #F ;$104 - #F ;$105 - GET-NEXT-INTERRUPT-CHARACTER ;$106 - CHECK-AND-CLEAN-UP-INPUT-CHANNEL ;$107 - #F ;$108 - SYSTEM-CLOCK ;$109 - FILE-EXISTS? ;$10A - #F ;$10B - TTY-MOVE-CURSOR ;$10C - #F ;$10D - CURRENT-DATE ;$10E - CURRENT-TIME ;$10F - TRANSLATE-FILE ;$110 - COPY-FILE ;$111 - RENAME-FILE ;$112 - REMOVE-FILE ;$113 - LINK-FILE ;$114 - MAKE-DIRECTORY ;$115 - VOLUME-NAME ;$116 - SET-WORKING-DIRECTORY-PATHNAME! ;$117 - OPEN-CATALOG ;$118 - CLOSE-CATALOG ;$119 - NEXT-FILE ;$11A - CAT-NAME ;$11B - CAT-KIND ;$11C - CAT-PSIZE ;$11D - CAT-LSIZE ;$11E - CAT-INFO ;$11F - CAT-BLOCK ;$120 - CAT-CREATE-DATE ;$121 - CAT-CREATE-TIME ;$122 - CAT-LAST-DATE ;$123 - CAT-LAST-TIME ;$124 - ERROR-MESSAGE ;$125 - CURRENT-YEAR ;$126 - CURRENT-MONTH ;$127 - CURRENT-DAY ;$128 - CURRENT-HOUR ;$129 - CURRENT-MINUTE ;$12A - CURRENT-SECOND ;$12B - INIT-FLOPPY ;$12C - ZERO-FLOPPY ;$12D - PACK-VOLUME ;$12E - LOAD-PICTURE ;$12F - STORE-PICTURE ;$130 - LOOKUP-SYSTEM-SYMBOL ;$131 - #F ;$132 - #F ;$133 - CLEAR-TO-END-OF-LINE ;$134 - #F ;$135 - #F ;$136 - WITH-INTERRUPT-MASK ;$137 - STRING? ;$138 - STRING-LENGTH ;$139 - STRING-REF ;$13A - STRING-SET! ;$13B - SUBSTRING-MOVE-RIGHT! ;$13C - SUBSTRING-MOVE-LEFT! ;$13D - STRING-ALLOCATE ;$13E - STRING-MAXIMUM-LENGTH ;$13F - SET-STRING-LENGTH! ;$140 - VECTOR-8B-FILL! ;$141 - VECTOR-8B-FIND-NEXT-CHAR ;$142 - VECTOR-8B-FIND-PREVIOUS-CHAR ;$143 - VECTOR-8B-FIND-NEXT-CHAR-CI ;$144 - VECTOR-8B-FIND-PREVIOUS-CHAR-CI ;$145 - SUBSTRING-FIND-NEXT-CHAR-IN-SET ;$146 - SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET ;$147 - SUBSTRING=? ;$148 - SUBSTRING-CI=? ;$149 - SUBSTRINGSYNTAX-ENTRY ;$176 - SCAN-WORD-FORWARD ;$177 - SCAN-WORD-BACKWARD ;$178 - SCAN-LIST-FORWARD ;$179 - SCAN-LIST-BACKWARD ;$17A - SCAN-SEXPS-FORWARD ;$17B - SCAN-FORWARD-TO-WORD ;$17C - SCAN-BACKWARD-PREFIX-CHARS ;$17D - CHAR->SYNTAX-CODE ;$17E - QUOTED-CHAR? ;$17F - MICROCODE-TABLES-FILENAME ;$180 - #F ;$181 - #F #| FIND-PASCAL-PROGRAM |# ;$182 - #F #| EXECUTE-PASCAL-PROGRAM |# ;$183 - #F #| GRAPHICS-MOVE |# ;$184 - #F #| GRAPHICS-LINE |# ;$185 - #F #| GRAPHICS-PIXEL |# ;$186 - #F #| GRAPHICS-SET-DRAWING-MODE |# ;$187 - #F #| ALPHA-RASTER? |# ;$188 - #F #| TOGGLE-ALPHA-RASTER |# ;$189 - #F #| GRAPHICS-RASTER? |# ;$18A - #F #| TOGGLE-GRAPHICS-RASTER |# ;$18B - #F #| GRAPHICS-CLEAR |# ;$18C - #F #| GRAPHICS-SET-LINE-STYLE |# ;$18D - ERROR-PROCEDURE ;$18E - VOLUME-EXISTS? ;$18F - RE-CHAR-SET-ADJOIN! ;$190 - RE-COMPILE-FASTMAP ;$191 - RE-MATCH ;$192 - RE-SEARCH-FORWARD ;$193 - RE-SEARCH-BACKWARD ;$194 - (SYSTEM-MEMORY-REF &OBJECT-REF) ;$195 - (SYSTEM-MEMORY-SET! &OBJECT-SET!) ;$196 - BIT-STRING-FILL! ;$197 - BIT-STRING-MOVE! ;$198 - BIT-STRING-MOVEC! ;$199 - BIT-STRING-OR! ;$19A - BIT-STRING-AND! ;$19B - BIT-STRING-ANDC! ;$19C - BIT-STRING=? ;$19D - WORKING-DIRECTORY-PATHNAME ;$19E - OPEN-DIRECTORY ;$19F - DIRECTORY-READ ;$1A0 - UNDER-EMACS? ;$1A1 - TTY-FLUSH-OUTPUT ;$1A2 - RELOAD-BAND-NAME ;$1A3 - )) - -;;; [] External - -(vector-set! (get-fixed-objects-vector) - 16 ;(fixed-objects-vector-slot 'MICROCODE-EXTERNAL-PRIMITIVES) - #()) - -;;; [] Errors - -(vector-set! (get-fixed-objects-vector) - 7 ;(fixed-objects-vector-slot 'MICROCODE-ERRORS-VECTOR) - #(BAD-ERROR-CODE ;00 - UNBOUND-VARIABLE ;01 - UNASSIGNED-VARIABLE ;02 - UNDEFINED-PROCEDURE ;03 - #F ;04 - #F ;05 - BAD-FRAME ;06 - BROKEN-CVARIABLE ;07 - UNDEFINED-USER-TYPE ;08 - UNDEFINED-PRIMITIVE-OPERATION ;09 - EXTERNAL-RETURN ;0A - EXECUTE-MANIFEST-VECTOR ;0B - WRONG-NUMBER-OF-ARGUMENTS ;0C - WRONG-TYPE-ARGUMENT-0 ;0D - WRONG-TYPE-ARGUMENT-1 ;0E - WRONG-TYPE-ARGUMENT-2 ;0F - BAD-RANGE-ARGUMENT-0 ;10 - BAD-RANGE-ARGUMENT-1 ;11 - BAD-RANGE-ARGUMENT-2 ;12 - #F ;13 - #F ;14 - BAD-INTERRUPT-CODE ;15 - #F ;16 - FASL-FILE-TOO-BIG ;17 - FASL-FILE-BAD-DATA ;18 - IMPURIFY-OBJECT-TOO-LARGE ;19 - WRITE-INTO-PURE-SPACE ;1A - #F ;1B - #F ;1C - #F ;1D - FAILED-ARG-1-COERCION ;1E - FAILED-ARG-2-COERCION ;1F - OUT-OF-FILE-HANDLES ;20 - #F ;21 - BAD-RANGE-ARGUMENT-3 ;22 - BAD-RANGE-ARGUMENT-4 ;23 - BAD-RANGE-ARGUMENT-5 ;24 - BAD-RANGE-ARGUMENT-6 ;25 - BAD-RANGE-ARGUMENT-7 ;26 - BAD-RANGE-ARGUMENT-8 ;27 - BAD-RANGE-ARGUMENT-9 ;28 - WRONG-TYPE-ARGUMENT-3 ;29 - WRONG-TYPE-ARGUMENT-4 ;2A - WRONG-TYPE-ARGUMENT-5 ;2B - WRONG-TYPE-ARGUMENT-6 ;2C - WRONG-TYPE-ARGUMENT-7 ;2D - WRONG-TYPE-ARGUMENT-8 ;2E - WRONG-TYPE-ARGUMENT-9 ;2F - INAPPLICABLE-CONTINUATION ;30 - COMPILED-CODE-ERROR ;31 - FLOATING-OVERFLOW ;32 - UNIMPLEMENTED-PRIMITIVE ;33 - )) - -;;; [] Terminations - -(vector-set! (get-fixed-objects-vector) - 22 ;(fixed-objects-vector-slot 'MICROCODE-TERMINATIONS-VECTOR) - #(HALT ;00 - DISK-RESTORE ;01 - BROKEN-HEART ;02 - NON-POINTER-RELOCATION ;03 - BAD-ROOT ;04 - NON-EXISTENT-CONTINUATION ;05 - BAD-STACK ;06 - STACK-OVERFLOW ;07 - STACK-ALLOCATION-FAILED ;08 - NO-ERROR-HANDLER ;09 - NO-INTERRUPT-HANDLER ;0A - UNIMPLEMENTED-CONTINUATION ;0B - EXIT ;0C - BAD-PRIMITIVE-DURING-ERROR ;0D - EOF ;0E - BAD-PRIMITIVE ;0F - TERMINATION-HANDLER ;10 - END-OF-CONTINUATION ;11 - INVALID-TYPE-CODE ;12 - COMPILER-DEATH ;13 - GC-OUT-OF-SPACE ;14 - )) - -(vector-set! (get-fixed-objects-vector) - 23 ;(fixed-objects-vector-slot 'MICROCODE-TERMINATION-PROCEDURES) - #()) - -;;; [] Identification - -(vector-set! (get-fixed-objects-vector) - 8 ;(fixed-objects-vector-slot 'MICROCODE-IDENTIFICATION-VECTOR) - #(SYSTEM-RELEASE-STRING ;00 - MICROCODE-VERSION ;01 - MICROCODE-MODIFICATION ;02 - CONSOLE-WIDTH ;03 - CONSOLE-HEIGHT ;04 - NEWLINE-CHAR ;05 - FLONUM-MANTISSA-LENGTH ;06 - FLONUM-EXPONENT-LENGTH ;07 - OS-NAME-STRING ;08 - OS-VARIANT-STRING ;09 - )) - -;;; This identification string is saved by the system. - -"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.25 1987/04/16 02:32:05 jinx Exp $" diff --git a/v8/src/microcode/version.h b/v8/src/microcode/version.h deleted file mode 100644 index 7320e9d89..000000000 --- a/v8/src/microcode/version.h +++ /dev/null @@ -1,54 +0,0 @@ -/* -*-C-*- - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. */ - -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 9.41 1987/04/17 04:03:23 cph Exp $ - -This file contains version information for the microcode. */ - -/* Scheme system release version */ - -#ifndef RELEASE -#define RELEASE "5.0.20" -#endif - -/* Microcode release version */ - -#ifndef VERSION -#define VERSION 9 -#endif -#ifndef SUBVERSION -#define SUBVERSION 41 -#endif - -#ifndef UCODE_TABLES_FILENAME -#define UCODE_TABLES_FILENAME "utabmd.bin" -#endif diff --git a/v8/src/sf/make.scm b/v8/src/sf/make.scm deleted file mode 100644 index fc654f119..000000000 --- a/v8/src/sf/make.scm +++ /dev/null @@ -1,118 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 3.4 1987/03/20 23:50:32 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; SCode Optimizer: System Construction - -(in-package system-global-environment -(declare (usual-integrations)) - -(define sf) -(define sf/set-file-syntax-table!) -(define sf/add-file-declarations!) -(load "$zcomp/base/load" system-global-environment) - -(load-system system-global-environment - 'PACKAGE/SCODE-OPTIMIZER - '(SYSTEM-GLOBAL-ENVIRONMENT) - '( - (PACKAGE/SCODE-OPTIMIZER - "mvalue" ;Multiple Value Support - "eqsets" ;Set Data Abstraction - - "object" ;Data Structures - "emodel" ;Environment Model - "gconst" ;Global Primitives List - "usicon" ;Usual Integrations: Constants - "tables" ;Table Abstractions - "packag" ;Global packaging - ) - - (PACKAGE/TOP-LEVEL - "toplev" ;Top Level - ) - - (PACKAGE/TRANSFORM - "xform" ;SCode -> Internal - ) - - (PACKAGE/INTEGRATE - "subst" ;Beta Substitution Optimizer - ) - - (PACKAGE/CGEN - "cgen" ;Internal -> SCode - ) - - (PACKAGE/EXPANSION - "usiexp" ;Usual Integrations: Expanders - ) - - (PACKAGE/DECLARATIONS - "pardec" ;Declaration Parser - ) - - (PACKAGE/COPY - "copy" ;Copy Expressions - ) - - (PACKAGE/FREE - "free" ;Free Variable Analysis - ) - - (PACKAGE/SAFE? - "safep" ;Safety Analysis - ) - - (PACKAGE/CHANGE-TYPE - "chtype" ;Type interning - ) - - )) - -(in-package package/scode-optimizer - (define integrations - "$zcomp/source/object") - - (define scode-optimizer/system - (make-environment - (define :name "SF") - (define :version 3) - (define :modification 3))) - - (add-system! scode-optimizer/system) - - (scode-optimizer/initialize!)) - -;;; end IN-PACKAGE SYSTEM-GLOBAL-ENVIRONMENT -) \ No newline at end of file diff --git a/v8/src/sf/toplev.scm b/v8/src/sf/toplev.scm deleted file mode 100644 index 145e10271..000000000 --- a/v8/src/sf/toplev.scm +++ /dev/null @@ -1,355 +0,0 @@ -#| -*-Scheme-*- - -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 3.2 1987/03/19 17:23:08 cph Exp $ - -Copyright (c) 1987 Massachusetts Institute of Technology - -This material was developed by the Scheme project at the Massachusetts -Institute of Technology, Department of Electrical Engineering and -Computer Science. Permission to copy this software, to redistribute -it, and to use it for any purpose is granted, subject to the following -restrictions 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 MIT Scheme project any improvements or extensions that -they make, so that these may be included in future releases; and (b) -to inform MIT of noteworthy uses of this software. - -3. 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. MIT has made no warrantee or representation that the operation of -this software will be error-free, and MIT is under no obligation to -provide any services, by way of maintenance, update, or otherwise. - -5. In conjunction with products arising from the use of this material, -there shall be no use of the name of the Massachusetts Institute of -Technology nor of any adaptation thereof in any advertising, -promotional, or sales literature without prior written consent from -MIT in each case. |# - -;;;; SCode Optimizer: Top Level - -(declare (usual-integrations)) - -;;;; User Interface - -(define generate-unfasl-files? false - "Set this non-false to cause unfasl files to be generated by default.") - -(define optimize-open-blocks? false - "Set this non-false to eliminate unreferenced auxiliary definitions. -Currently this optimization is not implemented.") - -(define (integrate/procedure procedure declarations) - (if (compound-procedure? procedure) - (procedure-components procedure - (lambda (*lambda environment) - (scode-eval (integrate/scode *lambda declarations false) - environment))) - (error "INTEGRATE/PROCEDURE: Not a compound procedure" procedure))) - -(define (integrate/sexp s-expression syntax-table declarations receiver) - (integrate/simple (lambda (s-expressions) - (phase:syntax s-expressions syntax-table)) - (list s-expression) declarations receiver)) - -(define (integrate/scode scode declarations receiver) - (integrate/simple identity-procedure scode declarations receiver)) - -(define (sf input-string #!optional bin-string spec-string) - (if (unassigned? bin-string) (set! bin-string false)) - (if (unassigned? spec-string) (set! spec-string false)) - (syntax-file input-string bin-string spec-string)) - -(define (scold input-string #!optional bin-string spec-string) - "Use this only for syntaxing the cold-load root file. -Currently only the 68000 implementation needs this." - (if (unassigned? bin-string) (set! bin-string false)) - (if (unassigned? spec-string) (set! spec-string false)) - (fluid-let ((wrapping-hook wrap-with-control-point)) - (syntax-file input-string bin-string spec-string))) - -(define (sf/set-file-syntax-table! pathname syntax-table) - (let ((pathname (pathname->absolute-pathname (->pathname pathname)))) - (let ((association (find-file-info/assoc pathname))) - (if association - (set-cdr! association - (transmit-values (cdr association) - (lambda (ignore declarations) - (return-2 syntax-table declarations)))) - (set! file-info - (cons (cons pathname (return-2 syntax-table '())) - file-info)))))) - -(define (sf/add-file-declarations! pathname declarations) - (let ((pathname (pathname->absolute-pathname (->pathname pathname)))) - (let ((association (find-file-info/assoc pathname))) - (if association - (set-cdr! association - (transmit-values (cdr association) - (lambda (syntax-table declarations*) - (return-2 syntax-table - (append! declarations* - (list-copy declarations)))))) - (set! file-info - (cons (cons pathname (return-2 false declarations)) - file-info)))))) - -(define file-info - '()) - -(define (find-file-info pathname) - (let ((association - (find-file-info/assoc (pathname->absolute-pathname pathname)))) - (if association - (cdr association) - (return-2 false '())))) - -(define (find-file-info/assoc pathname) - (list-search-positive file-info - (lambda (entry) - (pathname=? (car entry) pathname)))) - -(define (pathname=? x y) - (and (equal? (pathname-device x) (pathname-device y)) - (equal? (pathname-directory x) (pathname-directory y)) - (equal? (pathname-name x) (pathname-name y)))) - -;;;; File Syntaxer - -(define sf/default-input-pathname - (make-pathname false false false "scm" 'NEWEST)) - -(define sf/default-externs-pathname - (make-pathname false false false "ext" 'NEWEST)) - -(define sf/output-pathname-type "bin") -(define sf/unfasl-pathname-type "unf") - -(define (syntax-file input-string bin-string spec-string) - (let ((eval-sf-expression - (lambda (input-string) - (let ((input-path - (pathname->input-truename - (merge-pathnames (->pathname input-string) - sf/default-input-pathname)))) - (if (not input-path) - (error "SF: File does not exist" input-string)) - (let ((bin-path - (let ((bin-path - (pathname-new-type input-path - sf/output-pathname-type))) - (if bin-string - (merge-pathnames (->pathname bin-string) bin-path) - bin-path)))) - (let ((spec-path - (and (or spec-string generate-unfasl-files?) - (let ((spec-path - (pathname-new-type bin-path - sf/unfasl-pathname-type))) - (if spec-string - (merge-pathnames (->pathname spec-string) - spec-path) - spec-path))))) - (syntax-file* input-path bin-path spec-path))))))) - (if (list? input-string) - (for-each (lambda (input-string) - (eval-sf-expression input-string)) - input-string) - (eval-sf-expression input-string))) - *the-non-printing-object*) - -(define (syntax-file* input-pathname bin-pathname spec-pathname) - (let ((start-date (date)) - (start-time (time)) - (input-filename (pathname->string input-pathname)) - (bin-filename (pathname->string bin-pathname)) - (spec-filename (and spec-pathname (pathname->string spec-pathname)))) - (newline) - (write-string "Syntax file: ") - (write input-filename) - (write-string " ") - (write bin-filename) - (write-string " ") - (write spec-filename) - (transmit-values - (transmit-values (find-file-info input-pathname) - (lambda (syntax-table declarations) - (integrate/file input-pathname syntax-table declarations - spec-pathname))) - (lambda (expression externs events) - (fasdump (wrapping-hook - (make-comment `((SOURCE-FILE . ,input-filename) - (DATE . ,start-date) - (TIME . ,start-time) - (FLUID-LET . ,*fluid-let-type*)) - (set! expression false))) - bin-pathname) - (write-externs-file (pathname-new-type - bin-pathname - (pathname-type sf/default-externs-pathname)) - (set! externs false)) - (if spec-pathname - (begin (newline) - (write-string "Writing ") - (write spec-filename) - (with-output-to-file spec-pathname - (lambda () - (newline) - (write `(DATE ,start-date ,start-time)) - (newline) - (write `(FLUID-LET ,*fluid-let-type*)) - (newline) - (write `(SOURCE-FILE ,input-filename)) - (newline) - (write `(BINARY-FILE ,bin-filename)) - (for-each (lambda (event) - (newline) - (write `(,(car event) - (RUNTIME ,(cdr event))))) - events))) - (write-string " -- done"))))))) - -(define (read-externs-file pathname) - (let ((pathname - (merge-pathnames (->pathname pathname) sf/default-externs-pathname))) - (if (file-exists? pathname) - (fasload pathname) - (begin (warn "Nonexistent externs file" (pathname->string pathname)) - '())))) - -(define (write-externs-file pathname externs) - (cond ((not (null? externs)) - (fasdump externs pathname)) - ((file-exists? pathname) - (delete-file pathname)))) - -(define (print-spec identifier names) - (newline) - (newline) - (write-string "(") - (write identifier) - (let loop - ((names - (sort names - (lambda (x y) - (stringstring x) - (symbol->string y)))))) - (if (not (null? names)) - (begin (newline) - (write (car names)) - (loop (cdr names))))) - (write-string ")")) - -(define (wrapping-hook scode) - scode) - -(define control-point-tail - `(3 ,(primitive-set-type (microcode-type 'NULL) (* 4 4)) - () () () () () () () () () () () () () () ())) - -(define (wrap-with-control-point scode) - (system-list-to-vector type-code-control-point - `(,return-address-restart-execution - ,scode - ,system-global-environment - ,return-address-non-existent-continuation - ,@control-point-tail))) - -(define type-code-control-point - (microcode-type 'CONTROL-POINT)) - -(define return-address-restart-execution - (make-return-address (microcode-return 'RESTART-EXECUTION))) - -(define return-address-non-existent-continuation - (make-return-address (microcode-return 'NON-EXISTENT-CONTINUATION))) - -;;;; Optimizer Top Level - -(define (integrate/file file-name syntax-table declarations compute-free?) - (integrate/kernel (lambda () - (phase:syntax (phase:read file-name) syntax-table)) - declarations)) - -(define (integrate/simple preprocessor input declarations receiver) - (transmit-values - (integrate/kernel (lambda () (preprocessor input)) declarations) - (or receiver - (lambda (expression externs events) - expression)))) - -(define (integrate/kernel get-scode declarations) - (fluid-let ((previous-time false) - (previous-name false) - (events '())) - (transmit-values - (transmit-values - (transmit-values - (phase:transform (canonicalize-scode (get-scode) declarations)) - phase:optimize) - phase:generate-scode) - (lambda (externs expression) - (end-phase) - (return-3 expression externs (reverse! events)))))) - -(define (canonicalize-scode scode declarations) - (let ((declarations - ((access process-declarations syntaxer-package) declarations))) - (if (null? declarations) - scode - (scan-defines (make-sequence - (list (make-block-declaration declarations) - scode)) - make-open-block)))) - -(define (phase:read filename) - (mark-phase "Read") - (read-file filename)) - -(define (phase:syntax s-expression #!optional syntax-table) - (if (or (unassigned? syntax-table) (not syntax-table)) - (set! syntax-table (make-syntax-table system-global-syntax-table))) - (mark-phase "Syntax") - (syntax* s-expression syntax-table)) - -(define (phase:transform scode) - (mark-phase "Transform") - (transform/expression scode)) - -(define (phase:optimize block expression) - (mark-phase "Optimize") - (integrate/expression block expression)) - -(define (phase:generate-scode operations environment expression) - (mark-phase "Generate SCode") - (return-2 (operations->external operations environment) - (cgen/expression expression))) - -(define previous-time) -(define previous-name) -(define events) - -(define (mark-phase this-name) - (end-phase) - (newline) - (write-string " ") - (write-string this-name) - (write-string "...") - (set! previous-name this-name)) - -(define (end-phase) - (let ((this-time (runtime))) - (if previous-time - (let ((dt (- this-time previous-time))) - (set! events (cons (cons previous-name dt) events)) - (newline) - (write-string " Time: ") - (write dt) - (write-string " seconds."))) - (set! previous-time this-time))) \ No newline at end of file -- 2.25.1