aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/ChangeLog34
-rw-r--r--src/interp/Makefile.in162
-rw-r--r--src/interp/Makefile.pamphlet162
-rw-r--r--src/interp/bookvol5.pamphlet30
-rw-r--r--src/interp/bootlex.lisp34
-rw-r--r--src/interp/comp.lisp1
-rw-r--r--src/interp/def.lisp4
-rw-r--r--src/interp/fnewmeta.lisp.pamphlet4
-rw-r--r--src/interp/macros.lisp.pamphlet31
-rw-r--r--src/interp/metalex.lisp544
-rw-r--r--src/interp/newaux.lisp.pamphlet5
-rw-r--r--src/interp/nlib.lisp.pamphlet97
-rw-r--r--src/interp/parsing.lisp523
-rw-r--r--src/interp/patches.lisp.pamphlet24
-rw-r--r--src/interp/postpar.boot.pamphlet3
-rw-r--r--src/interp/postprop.lisp1
-rw-r--r--src/interp/preparse.lisp.pamphlet6
-rw-r--r--src/interp/setq.lisp.pamphlet11
-rw-r--r--src/interp/spad.lisp.pamphlet13
-rw-r--r--src/interp/sys-constants.boot24
-rw-r--r--src/interp/sys-globals.boot40
-rw-r--r--src/interp/sys-macros.lisp7
-rw-r--r--src/interp/util.lisp.pamphlet20
23 files changed, 916 insertions, 864 deletions
diff --git a/src/interp/ChangeLog b/src/interp/ChangeLog
index 16ab6fa7..10e71f06 100644
--- a/src/interp/ChangeLog
+++ b/src/interp/ChangeLog
@@ -1,3 +1,37 @@
+2007-09-19 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ * util.lisp.pamphlet ($directory-list): Move to sys-globals.boot.
+ ($library-directory-list): Likewise.
+ * spad.lisp.pamphlet: Import "bootlex".
+ * preparse.lisp.pamphlet: Import "fnewmeta".
+ * postprop.lisp: Import "macros".
+ * postpar.boot.pamphlet: Import "postprop".
+ * nlib.lisp.pamphlet (rdefiostream): Define unconditionally.
+ (get-io-index-stream): Likewise.
+ (makedir): Likewise.
+ (get-directory-list): Don't use $current-diretory.
+ ($filetype-table): Move to sys-constants.boot.
+ * patches.lisp.pamphlet ($current-directory): Remove.
+ (|cd|): Simplify implementation.
+ * newaux.lisp.pamphlet: Import "macros".
+ (|PARSE-NewKEY|): Define.
+ * metalex.lisp: Move various file, line, stack, character
+ utilities to here.
+ * macros.lisp.pamphlet (NREVERSE0): Move to sys-macros.lisp. Tidy.
+ * fnewmeta.lisp.pamphlet: Import "parsing".
+ * comp.lisp: Import "macros".
+ * def.lisp: Likewise.
+ (B-MDEF): Fix thinko.
+ * bootlex.lisp: Import "preparse", "def", and "nlib".
+ (BOOT-LINE-STACK): Move to metalex.lisp.
+ (NEXT-LINES-CLEAR): Likewise.
+ (NEXT-LINES-SHOW): Likewise.
+ (XCAPE): Likewise.
+ (KEYWORDS): Likewise.
+ * Makefile.pamphlet (${DEPSYS}): Now have all Lisp in compiled
+ form and load them.
+ * bookvol5.pamphlet ($current-directory): Remove.
+
2007-09-17 Gabriel Dos Reis <gdr@cs.tamu.edu>
Fix SF/1792002
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index 2e94d9af..14c14cbf 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -30,9 +30,7 @@ depsys_lisp_sources = $(depsys_lisp_noncompiled_sources) \
depsys_boot_sources = postpar.boot parse.boot clam.boot slam.boot \
g-boot.boot g-error.boot c-util.boot g-util.boot
-DEP= nlib.lisp \
- macros.lisp $(srcdir)/comp.lisp \
- spaderror.lisp debug.lisp \
+DEP= spaderror.lisp debug.lisp \
spad.lisp \
setq.lisp property.lisp \
unlisp.lisp foam_l.lisp \
@@ -343,16 +341,23 @@ ${DEPSYS}: vmlisp.$(FASLEXT) \
sys-globals.$(FASLEXT) \
diagnostics.$(FASLEXT) \
sys-macros.$(FASLEXT) \
+ macros.$(FASLEXT) \
+ nlib.$(FASLEXT) \
+ comp.$(FASLEXT) \
${DEP} \
nocompil.$(FASLEXT) \
bookvol5.$(FASLEXT)\
util.$(FASLEXT) \
- postpar.clisp parse.clisp \
- parsing.lisp metalex.lisp \
- bootlex.lisp newaux.lisp \
- preparse.lisp \
- postprop.lisp def.lisp \
- fnewmeta.lisp \
+ postpar.$(FASLEXT) \
+ parse.clisp \
+ parsing.$(FASLEXT) \
+ metalex.$(FASLEXT) \
+ bootlex.$(FASLEXT) \
+ newaux.$(FASLEXT) \
+ preparse.$(FASLEXT) \
+ postprop.$(FASLEXT)\
+ def.$(FASLEXT) \
+ fnewmeta.$(FASLEXT) \
g-error.clisp \
g-boot.clisp c-util.${LISP} \
g-util.clisp \
@@ -367,29 +372,25 @@ ${DEPSYS}: vmlisp.$(FASLEXT) \
@ echo '(|importModule| "ggreater")' >> makedep.lisp
@ echo '(|importModule| "union")' >> makedep.lisp
@ echo '(|importModule| "nocompil")' >> makedep.lisp
- @ echo '(|importModule| "parsing")' >> makedep.lisp
+ @ echo '(|importModule| "macros")' >> makedep.lisp
+ @ echo '(|importModule| "nlib")' >> makedep.lisp
@ echo '(|importModule| "bookvol5")' >> makedep.lisp
@ echo '(|importModule| "util")' >> makedep.lisp
@ echo '(in-package "BOOT")' >> makedep.lisp
@ echo '(build-depsys (quote ($(patsubst %, "%", ${DEP}))) "${AXIOM}")' >> makedep.lisp
- @ echo '(unless (probe-file "postpar.$(FASLEXT)") (|compileLispFile| "postpar.clisp" "postpar.$(FASLEXT)"))' >> makedep.lisp
- @ echo '(load "postpar")' >> makedep.lisp
@ echo '(unless (probe-file "parse.$(FASLEXT)") (|compileLispFile| "parse.clisp" "parse.$(FASLEXT)"))' >> makedep.lisp
+ @ echo '(in-package "AxiomCore")' >> makedep.lisp
+ @ echo '(|importModule| "newaux")' >> makedep.lisp
@ echo '(load "parse")' >> makedep.lisp
- @ echo '(unless (probe-file "metalex.$(FASLEXT)") (|compileLispFile| "$(srcdir)/metalex.lisp" "metalex.$(FASLEXT)"))' >> makedep.lisp
- @ echo '(load "metalex")' >> makedep.lisp
- @ echo '(unless (probe-file "bootlex.$(FASLEXT)") (|compileLispFile| "$(srcdir)/bootlex.lisp" "bootlex.$(FASLEXT)"))' >> makedep.lisp
- @ echo '(load "bootlex")' >> makedep.lisp
- @ echo '(unless (probe-file "newaux.$(FASLEXT)") (|compileLispFile| "newaux.lisp" "newaux.$(FASLEXT)"))' >> makedep.lisp
- @ echo '(load "newaux")' >> makedep.lisp
- @ echo '(unless (probe-file "preparse.$(FASLEXT)") (|compileLispFile| "preparse.lisp" "preparse.$(FASLEXT)"))' >> makedep.lisp
- @ echo '(load "preparse")' >> makedep.lisp
- @ echo '(unless (probe-file "postprop.$(FASLEXT)") (|compileLispFile| "$(srcdir)/postprop.lisp" "postprop.$(FASLEXT)"))' >> makedep.lisp
- @ echo '(load "postprop")' >> makedep.lisp
- @ echo '(unless (probe-file "def.$(FASLEXT)") (|compileLispFile| "$(srcdir)/def.lisp" "def.$(FASLEXT)"))' >> makedep.lisp
- @ echo '(load "def")' >> makedep.lisp
- @ echo '(unless (probe-file "fnewmeta.$(FASLEXT)") (|compileLispFile| "fnewmeta.lisp" "fnewmeta.$(FASLEXT)"))' >> makedep.lisp
- @ echo '(load "fnewmeta")' >> makedep.lisp
+ @ echo '(|importModule| "metalex")' >> makedep.lisp
+ @ echo '(|importModule| "parsing")' >> makedep.lisp
+ @ echo '(|importModule| "fnewmeta")' >> makedep.lisp
+ @ echo '(|importModule| "preparse")' >> makedep.lisp
+ @ echo '(|importModule| "comp")' >> makedep.lisp
+ @ echo '(|importModule| "def")' >> makedep.lisp
+ @ echo '(|importModule| "bootlex")' >> makedep.lisp
+ @ echo '(|importModule| "postprop")' >> makedep.lisp
+ @ echo '(|importModule| "postpar")' >> makedep.lisp
@ echo '(unless (probe-file "clam.$(FASLEXT)") (|compileLispFile| "clam.clisp" "clam.$(FASLEXT)"))' >> makedep.lisp
@ echo '(load "clam")' >> makedep.lisp
@ echo '(unless (probe-file "slam.$(FASLEXT)") (|compileLispFile| "slam.clisp" "slam.$(FASLEXT)"))' >> makedep.lisp
@@ -405,8 +406,7 @@ ${DEPSYS}: vmlisp.$(FASLEXT) \
../lisp/base-lisp$(EXEEXT) -- --make --output=$@ \
--load-directory=. makedep.lisp
@rm $(addsuffix .$(FASLEXT), \
- postpar parse metalex bootlex newaux preparse \
- postprop def fnewmeta clam slam g-error \
+ parse clam slam g-error \
g-boot c-util g-util)
@ echo 4 ${DEPSYS} created
@@ -414,45 +414,11 @@ ${DEPSYS}: vmlisp.$(FASLEXT) \
util.$(FASLEXT): util.lisp parsing.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-parsing.$(FASLEXT): parsing.lisp boot-pkg.$(FASLEXT)
- $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-
bookvol5.$(FASLEXT): bookvol5.lisp boot-pkg.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
nocompil.$(FASLEXT): nocompil.lisp boot-pkg.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-
-sys-macros.$(FASLEXT): sys-macros.lisp diagnostics.$(FASLEXT) \
- union.$(FASLEXT)
- $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-
-diagnostics.$(FASLEXT): diagnostics.boot sys-constants.$(FASLEXT) \
- sys-globals.$(FASLEXT)
- $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-
-sys-globals.$(FASLEXT): sys-globals.boot sys-constants.$(FASLEXT) \
- hash.$(FASLEXT)
- $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-
-sys-constants.$(FASLEXT): sys-constants.boot boot-pkg.$(FASLEXT)
- $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-
-hash.$(FASLEXT): hash.lisp vmlisp.$(FASLEXT)
- $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-
-union.$(FASLEXT): union.lisp vmlisp.$(FASLEXT)
- $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-
-ggreater.$(FASLEXT): ggreater.lisp vmlisp.$(FASLEXT)
- $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-
-vmlisp.$(FASLEXT): vmlisp.lisp boot-pkg.$(FASLEXT)
- $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-
-boot-pkg.$(FASLEXT): boot-pkg.lisp
- $(BOOTSYS) -- --compile --output=$@ $<
-
.PHONY: all-axiomsys
all-axiomsys: ${AXIOMSYS}
@@ -495,6 +461,47 @@ $(AUTO)/%.$(FASLEXT): %.$(FASLEXT)
## bahave very differently based on the history of the seesion. Ideal
## recipe for creating heisenbugs.
##
+
+## The old parser component roughtly is:
+##
+
+postpar.$(FASLEXT): postpar.clisp postprop.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+postprop.$(FASLEXT): postprop.lisp macros.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+bootlex.$(FASLEXT): bootlex.lisp preparse.$(FASLEXT) def.$(FASLEXT) \
+ nlib.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+newaux.$(FASLEXT): newaux.lisp macros.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+def.$(FASLEXT): def.lisp macros.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+comp.$(FASLEXT): comp.lisp macros.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+preparse.$(FASLEXT): preparse.lisp fnewmeta.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+fnewmeta.$(FASLEXT): fnewmeta.lisp parsing.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+parsing.$(FASLEXT): parsing.lisp metalex.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+metalex.$(FASLEXT): metalex.lisp macros.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+nlib.$(FASLEXT): nlib.lisp macros.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+macros.$(FASLEXT): macros.lisp sys-macros.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
## The new parser component roughtly is:
## astr.boot dq.boot incl.boot pile.boot ptrees.boot
## posit.boot cparse.boot format.boot cstream.boot
@@ -539,6 +546,37 @@ bits.$(FASLEXT): bits.lisp boot-pkg.$(FASLEXT)
dq.$(FASLEXT): dq.boot boot-pkg.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+## General support and utilities.
+sys-macros.$(FASLEXT): sys-macros.lisp diagnostics.$(FASLEXT) \
+ union.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+diagnostics.$(FASLEXT): diagnostics.boot sys-constants.$(FASLEXT) \
+ sys-globals.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+sys-globals.$(FASLEXT): sys-globals.boot sys-constants.$(FASLEXT) \
+ hash.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+sys-constants.$(FASLEXT): sys-constants.boot boot-pkg.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+hash.$(FASLEXT): hash.lisp vmlisp.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+union.$(FASLEXT): union.lisp vmlisp.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+ggreater.$(FASLEXT): ggreater.lisp vmlisp.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+vmlisp.$(FASLEXT): vmlisp.lisp boot-pkg.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+boot-pkg.$(FASLEXT): boot-pkg.lisp
+ $(BOOTSYS) -- --compile --output=$@ $<
+
as.clisp: as.boot
@ echo 417 making $@ from $<
@ echo '(progn (old-boot::boot "as.boot"))' | ${DEPSYS}
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet
index 248f0905..a3612286 100644
--- a/src/interp/Makefile.pamphlet
+++ b/src/interp/Makefile.pamphlet
@@ -268,9 +268,7 @@ We do, however, care about the macros as these will be
expanded in later compiles. All macros are assumed to be
in this list of files.
<<environment>>=
-DEP= nlib.lisp \
- macros.lisp $(srcdir)/comp.lisp \
- spaderror.lisp debug.lisp \
+DEP= spaderror.lisp debug.lisp \
spad.lisp \
setq.lisp property.lisp \
unlisp.lisp foam_l.lisp \
@@ -976,16 +974,23 @@ ${DEPSYS}: vmlisp.$(FASLEXT) \
sys-globals.$(FASLEXT) \
diagnostics.$(FASLEXT) \
sys-macros.$(FASLEXT) \
+ macros.$(FASLEXT) \
+ nlib.$(FASLEXT) \
+ comp.$(FASLEXT) \
${DEP} \
nocompil.$(FASLEXT) \
bookvol5.$(FASLEXT)\
util.$(FASLEXT) \
- postpar.clisp parse.clisp \
- parsing.lisp metalex.lisp \
- bootlex.lisp newaux.lisp \
- preparse.lisp \
- postprop.lisp def.lisp \
- fnewmeta.lisp \
+ postpar.$(FASLEXT) \
+ parse.clisp \
+ parsing.$(FASLEXT) \
+ metalex.$(FASLEXT) \
+ bootlex.$(FASLEXT) \
+ newaux.$(FASLEXT) \
+ preparse.$(FASLEXT) \
+ postprop.$(FASLEXT)\
+ def.$(FASLEXT) \
+ fnewmeta.$(FASLEXT) \
g-error.clisp \
g-boot.clisp c-util.${LISP} \
g-util.clisp \
@@ -1000,29 +1005,25 @@ ${DEPSYS}: vmlisp.$(FASLEXT) \
@ echo '(|importModule| "ggreater")' >> makedep.lisp
@ echo '(|importModule| "union")' >> makedep.lisp
@ echo '(|importModule| "nocompil")' >> makedep.lisp
- @ echo '(|importModule| "parsing")' >> makedep.lisp
+ @ echo '(|importModule| "macros")' >> makedep.lisp
+ @ echo '(|importModule| "nlib")' >> makedep.lisp
@ echo '(|importModule| "bookvol5")' >> makedep.lisp
@ echo '(|importModule| "util")' >> makedep.lisp
@ echo '(in-package "BOOT")' >> makedep.lisp
@ echo '(build-depsys (quote ($(patsubst %, "%", ${DEP}))) "${AXIOM}")' >> makedep.lisp
- @ echo '(unless (probe-file "postpar.$(FASLEXT)") (|compileLispFile| "postpar.clisp" "postpar.$(FASLEXT)"))' >> makedep.lisp
- @ echo '(load "postpar")' >> makedep.lisp
@ echo '(unless (probe-file "parse.$(FASLEXT)") (|compileLispFile| "parse.clisp" "parse.$(FASLEXT)"))' >> makedep.lisp
+ @ echo '(in-package "AxiomCore")' >> makedep.lisp
+ @ echo '(|importModule| "newaux")' >> makedep.lisp
@ echo '(load "parse")' >> makedep.lisp
- @ echo '(unless (probe-file "metalex.$(FASLEXT)") (|compileLispFile| "$(srcdir)/metalex.lisp" "metalex.$(FASLEXT)"))' >> makedep.lisp
- @ echo '(load "metalex")' >> makedep.lisp
- @ echo '(unless (probe-file "bootlex.$(FASLEXT)") (|compileLispFile| "$(srcdir)/bootlex.lisp" "bootlex.$(FASLEXT)"))' >> makedep.lisp
- @ echo '(load "bootlex")' >> makedep.lisp
- @ echo '(unless (probe-file "newaux.$(FASLEXT)") (|compileLispFile| "newaux.lisp" "newaux.$(FASLEXT)"))' >> makedep.lisp
- @ echo '(load "newaux")' >> makedep.lisp
- @ echo '(unless (probe-file "preparse.$(FASLEXT)") (|compileLispFile| "preparse.lisp" "preparse.$(FASLEXT)"))' >> makedep.lisp
- @ echo '(load "preparse")' >> makedep.lisp
- @ echo '(unless (probe-file "postprop.$(FASLEXT)") (|compileLispFile| "$(srcdir)/postprop.lisp" "postprop.$(FASLEXT)"))' >> makedep.lisp
- @ echo '(load "postprop")' >> makedep.lisp
- @ echo '(unless (probe-file "def.$(FASLEXT)") (|compileLispFile| "$(srcdir)/def.lisp" "def.$(FASLEXT)"))' >> makedep.lisp
- @ echo '(load "def")' >> makedep.lisp
- @ echo '(unless (probe-file "fnewmeta.$(FASLEXT)") (|compileLispFile| "fnewmeta.lisp" "fnewmeta.$(FASLEXT)"))' >> makedep.lisp
- @ echo '(load "fnewmeta")' >> makedep.lisp
+ @ echo '(|importModule| "metalex")' >> makedep.lisp
+ @ echo '(|importModule| "parsing")' >> makedep.lisp
+ @ echo '(|importModule| "fnewmeta")' >> makedep.lisp
+ @ echo '(|importModule| "preparse")' >> makedep.lisp
+ @ echo '(|importModule| "comp")' >> makedep.lisp
+ @ echo '(|importModule| "def")' >> makedep.lisp
+ @ echo '(|importModule| "bootlex")' >> makedep.lisp
+ @ echo '(|importModule| "postprop")' >> makedep.lisp
+ @ echo '(|importModule| "postpar")' >> makedep.lisp
@ echo '(unless (probe-file "clam.$(FASLEXT)") (|compileLispFile| "clam.clisp" "clam.$(FASLEXT)"))' >> makedep.lisp
@ echo '(load "clam")' >> makedep.lisp
@ echo '(unless (probe-file "slam.$(FASLEXT)") (|compileLispFile| "slam.clisp" "slam.$(FASLEXT)"))' >> makedep.lisp
@@ -1037,8 +1038,7 @@ ${DEPSYS}: vmlisp.$(FASLEXT) \
@ echo '(load "g-util")' >> makedep.lisp
<<save depsys image>>
@rm $(addsuffix .$(FASLEXT), \
- postpar parse metalex bootlex newaux preparse \
- postprop def fnewmeta clam slam g-error \
+ parse clam slam g-error \
g-boot c-util g-util)
@ echo 4 ${DEPSYS} created
@@ -1046,45 +1046,11 @@ ${DEPSYS}: vmlisp.$(FASLEXT) \
util.$(FASLEXT): util.lisp parsing.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-parsing.$(FASLEXT): parsing.lisp boot-pkg.$(FASLEXT)
- $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-
bookvol5.$(FASLEXT): bookvol5.lisp boot-pkg.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
nocompil.$(FASLEXT): nocompil.lisp boot-pkg.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-
-sys-macros.$(FASLEXT): sys-macros.lisp diagnostics.$(FASLEXT) \
- union.$(FASLEXT)
- $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-
-diagnostics.$(FASLEXT): diagnostics.boot sys-constants.$(FASLEXT) \
- sys-globals.$(FASLEXT)
- $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-
-sys-globals.$(FASLEXT): sys-globals.boot sys-constants.$(FASLEXT) \
- hash.$(FASLEXT)
- $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-
-sys-constants.$(FASLEXT): sys-constants.boot boot-pkg.$(FASLEXT)
- $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-
-hash.$(FASLEXT): hash.lisp vmlisp.$(FASLEXT)
- $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-
-union.$(FASLEXT): union.lisp vmlisp.$(FASLEXT)
- $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-
-ggreater.$(FASLEXT): ggreater.lisp vmlisp.$(FASLEXT)
- $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-
-vmlisp.$(FASLEXT): vmlisp.lisp boot-pkg.$(FASLEXT)
- $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-
-boot-pkg.$(FASLEXT): boot-pkg.lisp
- $(BOOTSYS) -- --compile --output=$@ $<
-
@
\section{Building SAVESYS and AXIOMSYS}
@@ -1990,6 +1956,47 @@ $(AUTO)/%.$(FASLEXT): %.$(FASLEXT)
## bahave very differently based on the history of the seesion. Ideal
## recipe for creating heisenbugs.
##
+
+## The old parser component roughtly is:
+##
+
+postpar.$(FASLEXT): postpar.clisp postprop.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+postprop.$(FASLEXT): postprop.lisp macros.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+bootlex.$(FASLEXT): bootlex.lisp preparse.$(FASLEXT) def.$(FASLEXT) \
+ nlib.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+newaux.$(FASLEXT): newaux.lisp macros.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+def.$(FASLEXT): def.lisp macros.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+comp.$(FASLEXT): comp.lisp macros.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+preparse.$(FASLEXT): preparse.lisp fnewmeta.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+fnewmeta.$(FASLEXT): fnewmeta.lisp parsing.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+parsing.$(FASLEXT): parsing.lisp metalex.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+metalex.$(FASLEXT): metalex.lisp macros.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+nlib.$(FASLEXT): nlib.lisp macros.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+macros.$(FASLEXT): macros.lisp sys-macros.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
## The new parser component roughtly is:
## astr.boot dq.boot incl.boot pile.boot ptrees.boot
## posit.boot cparse.boot format.boot cstream.boot
@@ -2034,6 +2041,37 @@ bits.$(FASLEXT): bits.lisp boot-pkg.$(FASLEXT)
dq.$(FASLEXT): dq.boot boot-pkg.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+## General support and utilities.
+sys-macros.$(FASLEXT): sys-macros.lisp diagnostics.$(FASLEXT) \
+ union.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+diagnostics.$(FASLEXT): diagnostics.boot sys-constants.$(FASLEXT) \
+ sys-globals.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+sys-globals.$(FASLEXT): sys-globals.boot sys-constants.$(FASLEXT) \
+ hash.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+sys-constants.$(FASLEXT): sys-constants.boot boot-pkg.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+hash.$(FASLEXT): hash.lisp vmlisp.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+union.$(FASLEXT): union.lisp vmlisp.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+ggreater.$(FASLEXT): ggreater.lisp vmlisp.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+vmlisp.$(FASLEXT): vmlisp.lisp boot-pkg.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
+boot-pkg.$(FASLEXT): boot-pkg.lisp
+ $(BOOTSYS) -- --compile --output=$@ $<
+
<<as.clisp>>
<<ax.clisp>>
diff --git a/src/interp/bookvol5.pamphlet b/src/interp/bookvol5.pamphlet
index 79fca804..74304b87 100644
--- a/src/interp/bookvol5.pamphlet
+++ b/src/interp/bookvol5.pamphlet
@@ -276,28 +276,6 @@ The [[curoutstream]] variable is set to the value of the
[[*standard-output*]] common lisp variable in [[ncIntLoop]].
While not using the ``dollar'' convention this variable is still ``global''.
-\subsection{\$current-directory}
-When running in Lucid Common Lisp ([[:lucid]]) on an IBM/370 mainframe
-([[:ibm/370]]) this variable is used in place of the
-[[*default-pathname-defaults*]] common lisp variable.
-Otherwise this variable is
-set to the empty string in [[restart]].
-
-Notice that the variable [[*default-pathname-defaults*]] is a Common
-Lisp standard variable with implementation defined meaning.
-Typically, its value is an object that represents the directory from
-where the Lisp image has been started.
-
-The [[reroot]] function sets this variable to the value of
-[[$spadroot]] which itself has the value of the argument to the
-[[reroot]] function. Since the argument to the [[reroot]] function is
-an string which represents an absolute pathname pointing to OpenAxiom the
-net result is that the [[$current-directory]] is set to point to the
-shell [[AXIOM]] variable.
-
-So during execute both [[$current-directory]] and [[$spadroot]] reflect
-the value of the [[AXIOM]] shell variable.
-
\subsection{\$currentLine}
The [[$currentLine]] line is set to [[NIL]] in [[restart]].
It is used in [[removeUndoLines]] in the undo mechanism.
@@ -705,11 +683,6 @@ We do not care that tail recursion occurs.
(setq |$SpadServer| t)))))
(setq |$IOindex| 1)
(setq |$InteractiveFrame| (|makeInitialModemapFrame|))
-#+(and :lucid :ibm/370)
- (setq $current-directory "")
-#-(and :lucid :ibm/370)
- (setq $current-directory
- (make-directory *default-pathname-defaults*))
(|loadExposureGroupData|)
(|statisticsInitialization|)
(|initHist|)
@@ -859,8 +832,7 @@ where the [[${SYS}]] variable is the same one set at build time.
(mapcar #'make-absolute-filename $relative-library-directory-list))
(setq |$defaultMsgDatabaseName|
(pathname (make-absolute-filename "/share/msgs/s2-us.msgs")))
- (setq |$msgDatabaseName| ())
- (setq $current-directory $spadroot))
+ (setq |$msgDatabaseName| ()))
@
\subsection{defun statisticsInitialization}
diff --git a/src/interp/bootlex.lisp b/src/interp/bootlex.lisp
index 6b1d67ad..35be2eaa 100644
--- a/src/interp/bootlex.lisp
+++ b/src/interp/bootlex.lisp
@@ -41,20 +41,13 @@
; 4. BOOT Token Parsing Actions
; 5. BOOT Error Handling
+(IMPORT-MODULE "preparse")
+(IMPORT-MODULE "def")
+(IMPORT-MODULE "nlib")
(in-package "BOOT")
; *** 0. Global parameters
-(defparameter Boot-Line-Stack nil "List of lines returned from PREPARSE.")
-
-(defun Next-Lines-Clear () (setq Boot-Line-Stack nil))
-
-(defun Next-Lines-Show ()
- (and Boot-Line-Stack (format t "Currently preparsed lines are:~%~%"))
- (mapcar #'(lambda (line)
- (format t "~&~5D> ~A~%" (car line) (cdr Line)))
- Boot-Line-Stack))
-
; *** 1. BOOT file handling
(defun init-boot/spad-reader ()
@@ -165,7 +158,6 @@
(OPTIONLIST nil)
(*EOF* NIL)
(File-Closed NIL)
- ;; ($current-directory "/spad/libraries/")
(/editfile *spad-input-file*)
(|$noSubsumption| |$noSubsumption|)
in-stream out-stream)
@@ -233,6 +225,7 @@
'|%l| '|%b| (ELT $SPAD_ERRORS 2) '|%d| '|semantic errors| '|%l|)))
(+ (ELT $SPAD_ERRORS 0) (ELT $SPAD_ERRORS 1) (ELT $SPAD_ERRORS 2))))
+
(defun READBOOT ()
(let (form expr ($BOOT 'T))
(declare (special $BOOT))
@@ -265,8 +258,6 @@ if it gets a non-blank line, and NIL at end of stream."
; *** 3. BOOT Token Handling ***
-(defparameter xcape #\_ "Escape character for Boot code.")
-
(defun get-BOOT-token (token)
"If you have an _, go to the next line.
@@ -318,18 +309,6 @@ Otherwise, get a .. identifier."
(token-install (intern (strconc "#" (format nil "~D" (token-symbol token))))
'argument-designator token nonblank))
-(defvar Keywords '(|or| |and| |isnt| |is| |otherwise| |when| |where|
- |has| |with| |add| |case| |in| |by| |pretend| |mod|
- |exquo| |div| |quo| |else| |rem| |then| |suchthat|
- |if| |yield| |iterate| |from| |exit| |leave| |return|
- |not| |unless| |repeat| |until| |while| |for| |import|)
-
-
-
-"Alphabetic literal strings occurring in the New Meta code constitute
-keywords. These are recognized specifically by the AnyId production,
-GET-BOOT-IDENTIFIER will recognize keywords but flag them
-as keywords.")
(defun get-boot-identifier-token (token &optional (escaped? nil))
"An identifier consists of an escape followed by any character, a %, ?,
@@ -405,11 +384,6 @@ or the chracters ?, !, ' or %"
; **** 4. BOOT token parsing actions
-; Parsing of operator tokens depends on tables initialized by BOTTOMUP.LISP
-
-(defun-parse-token SPADSTRING)
-(defun-parse-token KEYWORD)
-(defun-parse-token ARGUMENT-DESIGNATOR)
(defun TRANSLABEL (X AL) (TRANSLABEL1 X AL) X)
diff --git a/src/interp/comp.lisp b/src/interp/comp.lisp
index f46dc474..66d56e7a 100644
--- a/src/interp/comp.lisp
+++ b/src/interp/comp.lisp
@@ -49,6 +49,7 @@
; The package also causes traced things which are recompiled to
; become untraced.
+(IMPORT-MODULE "macros")
(in-package "BOOT")
(export '(Comp FluidVars LocVars OptionList SLAM SPADSLAM ILAM FLUID))
diff --git a/src/interp/def.lisp b/src/interp/def.lisp
index 4a70afcd..799034ee 100644
--- a/src/interp/def.lisp
+++ b/src/interp/def.lisp
@@ -33,7 +33,7 @@
; NAME: Def
; PURPOSE: Defines BOOT code
-(provide 'Boot)
+(IMPORT-MODULE "macros")
(in-package "BOOT")
@@ -113,7 +113,7 @@ foo defined inside of fum gets renamed as fum,foo.")
(declare (ignore SIGNATURE))
(let* ($OpAssoc
($op (first form)) (argl (cdr form))
- (GARGL (MAPCAR '(LAMBDA (X) (GENSYM)) ARGL))
+ (GARGL (MAPCAR #'(LAMBDA (X) (GENSYM)) ARGL))
($BODY (SUBLISLIS GARGL ARGL (|bootTransform| (DEFTRAN $BODY))))
($BODY (LIST 'SUBLISLIS (CONS 'LIST GARGL) (LIST 'QUOTE GARGL)
(LIST 'QUOTE $BODY))))
diff --git a/src/interp/fnewmeta.lisp.pamphlet b/src/interp/fnewmeta.lisp.pamphlet
index 29c55dd3..be041a6a 100644
--- a/src/interp/fnewmeta.lisp.pamphlet
+++ b/src/interp/fnewmeta.lisp.pamphlet
@@ -296,6 +296,7 @@ IteratorTail: ('repeat' <Iterator*>! / Iterator*) ;
<<*>>=
<<license>>
+(IMPORT-MODULE "parsing")
(IN-PACKAGE "BOOT" )
@@ -305,6 +306,9 @@ IteratorTail: ('repeat' <Iterator*>! / Iterator*) ;
(DEFPARAMETER DEFINITION_NAME NIL)
(DEFPARAMETER LABLASOC NIL)
+(defun |isTokenDelimiter| ()
+ (MEMBER (CURRENT-SYMBOL) '(\) END\_UNIT NIL)))
+
(DEFUN |PARSE-NewExpr| ()
(OR (AND (MATCH-STRING ")") (ACTION (|processSynonyms|))
diff --git a/src/interp/macros.lisp.pamphlet b/src/interp/macros.lisp.pamphlet
index c9234dcd..2799b0e9 100644
--- a/src/interp/macros.lisp.pamphlet
+++ b/src/interp/macros.lisp.pamphlet
@@ -214,13 +214,6 @@ ends up being [[CONTAINED |$EmptyMode| Y]].
"Needed by spadCompileOrSetq" 1)
-
-#-:CCL
-(defun NREVERSE0 (X) ; Already built-in to CCL
- "Returns LST, reversed. The argument is modified.
-This version is needed so that (COLLECT (IN X Y) ... (RETURN 'JUNK))=>JUNK."
- (if (ATOM X) X (NREVERSE X)))
-
; 7.8.4 Mapping
@@ -732,12 +725,6 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size
(defmacro |do| (&rest args) (CONS 'PROGN args))
(defun DROPTRAILINGBLANKS (LINE) (string-right-trim " " LINE))
-
-; # Gives the number of elements of a list, 0 for atoms.
-; If we quote it, then an interpreter trip is necessary every time
-; we call #, and this costs us - 4% in the RATINT DEMO."
-
-(define-function '\# #'SIZE)
(defun print-and-eval-defun (name body)
(eval body)
@@ -797,7 +784,7 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size
(defun compile-defun (name body) (eval body) (compile name))
-(defun |deleteWOC| (item list) (lisp::delete item list :test #'equal))
+(defun |deleteWOC| (item list) (delete item list :test #'equal))
;;---- Added by WFS.
@@ -892,14 +879,14 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size
(defun |applyWithOutputToString| (func args)
;; returns the cons of applying func to args and a string produced
;; from standard-output while executing.
- (let* ((*standard-output* (make-string-output-stream))
- (curoutstream *standard-output*)
- (*terminal-io* *standard-output*)
- (|$algebraOutputStream| *standard-output*)
- (erroroutstream *standard-output*)
+ (let* ((out-stream (make-string-output-stream))
+ (curoutstream out-stream)
+ (|$algebraOutputStream| out-stream)
+ (erroroutstream out-stream)
val)
- (declare (special *standard-output* curoutstream
- *terminal-io* |$algebraOutputStream|))
+ (declare (special curoutstream |$algebraOutputStream|))
+ (setq *standard-output* out-stream)
+ (setq *terminal-io* out-stream)
(setq val (catch 'spad_reader
(catch 'TOP_LEVEL
(apply (symbol-function func) args))))
@@ -980,6 +967,8 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size
)))
+(defvar HT nil)
+
(defun markhash (key n) (progn (cond
((equal n 3) (remhash key ht))
('t (hput ht key n)) ) nil))
diff --git a/src/interp/metalex.lisp b/src/interp/metalex.lisp
index f718ba1d..aa5be9ba 100644
--- a/src/interp/metalex.lisp
+++ b/src/interp/metalex.lisp
@@ -39,8 +39,409 @@
; 3. META Token Handling
; 4. META Token Parsing Actions
; 5. META Error Handling
-
+
+(IMPORT-MODULE "macros")
(in-package "BOOT")
+
+; 0. Current I/O Stream definition
+
+(defparameter in-stream t "Current input stream.")
+(defparameter out-stream t "Current output stream.")
+(defparameter File-Closed nil "Way to stop EOF tests for console input.")
+
+
+; 1. Data structure declarations (defstructs) for parsing objects
+;
+; A. Line Buffer
+; B. Stack
+; C. Token
+; D. Reduction
+
+; 1B. A Stack (of lines, tokens, or whatever)
+
+; FUNCTIONS DEFINED IN THIS SECTION:
+;
+; Make-Stack, Stack-Store, Stack-Size, Stack-Top, Stack-Load, Stack-Clear,
+; Stack-/-Empty, Stack-Push, Stack-Pop
+
+(defstruct Stack "A stack"
+ (Store nil) ; contents of the stack
+ (Size 0) ; number of elements in Store
+ (Top nil) ; first element of Store
+
+ (Updated nil) ; whether something has been pushed on the stack
+ ; since this flag was last set to NIL
+)
+
+(defun stack-load (list stack)
+ (setf (stack-store stack) list
+ (stack-size stack) (length list)
+ (stack-top stack) (car list)))
+
+(defun stack-clear (stack)
+ (setf (stack-store stack) nil (stack-size stack) 0 (stack-top stack) nil
+ (stack-updated stack) nil))
+
+(defmacro stack-/-empty (stack) `(> (stack-size ,stack) 0))
+
+(defun stack-push (x stack)
+ (push x (stack-store stack))
+ (setf (stack-top stack) x (stack-updated stack) t)
+ (incf (stack-size stack))
+ x)
+
+(defun stack-pop (stack)
+ (let ((y (pop (stack-store stack))))
+ (decf (stack-size stack))
+ (setf (stack-top stack) (if (stack-/-empty stack) (car (stack-store stack))))
+ y))
+
+
+; 1A. A Line Buffer
+;
+; The philosophy of lines is that
+;
+; a) NEXT LINE will always get you a non-blank line or fail.
+; b) Every line is terminated by a blank character.
+;
+; Hence there is always a current character, because there is never a non-blank line,
+; and there is always a separator character between tokens on separate lines.
+; Also, when a line is read, the character pointer is always positioned ON the first
+; character.
+
+; FUNCTIONS DEFINED IN THIS SECTION:
+;
+; Line-Buffer, Line-Current-Char, Line-Current-Index, Line-Last-Index, Line-Number
+; Line-New-Line, Line-Advance-Char, Line-Past-End-P, Line-At-End-P
+; Make-Line
+
+(defstruct Line "Line of input file to parse."
+ (Buffer (make-string 0) :type string)
+ (Current-Char #\Return :type character)
+ (Current-Index 1 :type fixnum)
+ (Last-Index 0 :type fixnum)
+ (Number 0 :type fixnum))
+
+(defun Line-Print (line)
+ (format out-stream "~&~5D> ~A~%" (Line-Number line) (Line-Buffer Line))
+ (format out-stream "~v@T^~%" (+ 7 (Line-Current-Index line))))
+
+(defmacro Line-Clear (line)
+ `(let ((l ,line))
+ (setf (Line-Buffer l) (make-string 0)
+ (Line-Current-Char l) #\Return
+ (Line-Current-Index l) 1
+ (Line-Last-Index l) 0
+ (Line-Number l) 0)))
+
+(defun Line-Current-Segment (line)
+ "Buffer from current index to last index."
+ (if (line-at-end-p line) (make-string 0)
+ (subseq (Line-Buffer line)
+ (Line-Current-Index line)
+ (Line-Last-Index line))))
+
+(defun Line-New-Line (string line &optional (linenum nil))
+ "Sets string to be the next line stored in line."
+ (setf (Line-Last-Index line) (1- (length string))
+ (Line-Current-Index line) 0
+ (Line-Current-Char line) (or (and (> (length string) 0) (elt string 0)) #\Return)
+ (Line-Buffer line) string
+ (Line-Number line) (or linenum (1+ (Line-Number line)))))
+
+(defun Line-Advance-Char (line)
+ (setf (Line-Current-Char line)
+ (elt (Line-Buffer line) (incf (Line-Current-Index line)))))
+
+(defun Line-Next-Char (line)
+ (elt (Line-Buffer line) (1+ (Line-Current-Index line))))
+
+(defun Line-Past-End-P (line)
+ "Tests if line is empty or positioned past the last character."
+ (> (line-current-index line) (line-last-index line)))
+
+(defun Line-At-End-P (line)
+ "Tests if line is empty or positioned past the last character."
+ (>= (line-current-index line) (line-last-index line)))
+
+; *** Next Line
+
+(defparameter Echo-Meta nil "T if you want a listing of what has been read.")
+(defparameter Line-Handler 'next-META-line "Who grabs lines for us.")
+
+(defun next-line (&optional (in-stream t)) (funcall Line-Handler in-stream))
+
+(defun make-string-adjustable (s)
+ (cond ((adjustable-array-p s) s)
+ (t (make-array (array-dimensions s) :element-type 'character
+ :adjustable t :initial-contents s))))
+
+(defun get-a-line (stream)
+ (if (IS-CONSOLE stream) (princ (MKPROMPT)))
+ (let ((ll (read-a-line stream)))
+ (if (stringp ll) (make-string-adjustable ll) ll)))
+
+(defparameter Current-Fragment nil
+ "A string containing remaining chars from readline; needed because
+Symbolics read-line returns embedded newlines in a c-m-Y.")
+
+(defun input-clear () (setq Current-Fragment nil))
+
+
+(defparameter Boot-Line-Stack nil "List of lines returned from PREPARSE.")
+
+(defun Next-Lines-Clear () (setq Boot-Line-Stack nil))
+
+(defun Next-Lines-Show ()
+ (and Boot-Line-Stack (format t "Currently preparsed lines are:~%~%"))
+ (mapcar #'(lambda (line)
+ (format t "~&~5D> ~A~%" (car line) (cdr Line)))
+ Boot-Line-Stack))
+
+
+; 3. Routines for handling lexical scanning
+;
+; Lexical scanning of tokens is performed off of the current line. No
+; token can span more than 1 line. All real I/O is handled in a line-oriented
+; fashion (in a slight paradox) below the character level. All character
+; routines implicitly assume the parameter Current-Line. We do not make
+; Current-Line an explicit optional parameter for reasons of efficiency.
+
+(defparameter Current-Line (make-line) "Current input line.")
+
+(defmacro current-line-print () '(Line-Print Current-Line))
+
+(defmacro current-line-show ()
+ `(if (line-past-end-p current-line)
+ (format t "~&The current line is empty.~%")
+ (progn (format t "~&The current line is:~%~%")
+ (current-line-print))))
+
+(defmacro current-line-clear () `(Line-Clear Current-Line))
+
+(defun read-a-line (&optional (stream t))
+ (let (cp)
+ (if (and Current-Fragment (> (length Current-Fragment) 0))
+ (let ((line (with-input-from-string
+ (s Current-Fragment :index cp :start 0)
+ (read-line s nil nil))))
+ (setq Current-Fragment (subseq Current-Fragment cp))
+ line)
+ (prog nil
+ (if (stream-eof in-stream)
+ (progn (setq File-Closed t *EOF* t)
+ (Line-New-Line (make-string 0) Current-Line)
+ (return nil)))
+ (if (setq Current-Fragment (read-line stream))
+ (return (read-a-line stream)))))))
+
+; *** Print New Line
+
+(defparameter Printer-Line-Stack (make-stack)
+ "Stack of output listing lines waiting to print. [local to PRINT-NEW-LINE]")
+
+(defparameter Read-Quietly nil
+ "Whether or not to produce an output listing. [local to PRINT-NEW-LINE]")
+
+(defun Print-New-Line (string &optional (strm *terminal-io*))
+ "Makes output listings."
+ (if Read-Quietly (stack-push (copy-tree string) Printer-Line-Stack)
+ (progn (mapc #'(lambda (x) (format strm "; ~A~%" x) (terpri))
+ (nreverse (stack-store Printer-Line-Stack)))
+ (stack-clear Printer-Line-Stack)
+ (format strm "~&; ~A~%" string))))
+
+
+; 3A (2) Character handling.
+
+; FUNCTIONS DEFINED IN THIS SECTION:
+;
+; Current-Char, Next-Char, Advance-Char
+
+; *** Current Char, Next Char, Advance Char
+
+(defparameter xcape #\_ "Escape character for Boot code.")
+
+(defun Current-Char ()
+ "Returns the current character of the line, initially blank for an unread line."
+ (if (Line-Past-End-P Current-Line) #\Return (Line-Current-Char Current-Line)))
+
+(defun Next-Char ()
+ "Returns the character after the current character, blank if at end of line.
+The blank-at-end-of-line assumption is allowable because we assume that end-of-line
+is a token separator, which blank is equivalent to."
+
+ (if (Line-At-End-P Current-Line) #\Return (Line-Next-Char Current-Line)))
+
+(defun Advance-Char ()
+ "Advances IN-STREAM, invoking Next Line if necessary."
+ (loop (cond ((not (Line-At-End-P Current-Line))
+ (return (Line-Advance-Char Current-Line)))
+ ((next-line in-stream)
+ (return (current-char)))
+ ((return nil)))))
+
+; 1C. Token
+
+; FUNCTIONS DEFINED IN THIS SECTION:
+;
+; Make-Token, Token-Symbol, Token-Type, Token-Install, Token-Print
+
+(defstruct Token
+ "A token is a Symbol with a Type.
+The type is either NUMBER, IDENTIFIER or SPECIAL-CHAR.
+NonBlank is true if the token is not preceded by a blank."
+ (Symbol nil)
+ (Type nil)
+ (NonBlank t))
+
+(defparameter Prior-Token (make-token) "What did I see last")
+(defparameter nonblank t "Is there no blank in front of the current token.")
+(defparameter Current-Token (make-token) "Token at head of input stream.")
+(defparameter Next-Token (make-token) "Next token in input stream.")
+(defparameter Valid-Tokens 0 "Number of tokens in buffer (0, 1 or 2)")
+
+(defun Token-Install (symbol type token &optional (nonblank t))
+ (setf (token-symbol token) symbol (token-type token) type
+ (token-nonblank token) nonblank)
+ token)
+
+; *** Match Token
+
+(defun match-token (token type &optional (symbol nil))
+ (if (and token (eq (token-type token) type))
+ (if symbol (if (equal symbol (token-symbol token)) token) token)))
+
+(defun match-current-token (type &optional (symbol nil))
+ "Returns the current token if it has EQ type and (optionally) equal symbol."
+ (match-token (current-token) type symbol))
+
+(defun match-next-token (type &optional (symbol nil))
+ "Returns the next token if it has equal type and (optionally) equal symbol."
+ (match-token (next-token) type symbol))
+
+; *** Current Token, Next Token, Advance Token
+
+(defun try-get-token (token)
+ (let ((tok (get-token token)))
+ (if tok (progn (incf Valid-Tokens) token))))
+
+(defun current-symbol () (make-symbol-of (current-token)))
+
+(defun make-symbol-of (token)
+ (let ((u (and token (token-symbol token))))
+ (cond ((not u) nil)
+ ((characterp u) (intern (string u)))
+ (u))))
+
+(defun Token-Print (token)
+ (format out-stream "(token (symbol ~S) (type ~S))~%"
+ (Token-Symbol token) (Token-Type token)))
+
+(defun current-token ()
+ "Returns the current token getting a new one if necessary."
+ (if (> Valid-Tokens 0)
+ Current-Token
+ (try-get-token Current-Token)))
+
+(defun next-token ()
+ "Returns the token after the current token, or NIL if there is none after."
+ (current-token)
+ (if (> Valid-Tokens 1)
+ Next-Token
+ (try-get-token Next-Token)))
+
+(defun advance-token ()
+ (current-token) ;don't know why this is needed
+ "Makes the next token be the current token."
+ (case Valid-Tokens
+ (0 (try-get-token (Current-Token)))
+ (1 (decf Valid-Tokens)
+ (setq Prior-Token (copy-token Current-Token))
+ (try-get-token Current-Token))
+ (2 (setq Prior-Token (copy-token Current-Token))
+ (setq Current-Token (copy-token Next-Token))
+ (decf Valid-Tokens))))
+
+
+(defparameter XTokenReader 'get-meta-token "Name of tokenizing function")
+
+; *** Get Token
+
+(defun get-token (token) (funcall XTokenReader token))
+
+
+
+; 1D. A Reduction
+;
+
+(defstruct (Reduction (:type list))
+"A reduction of a rule is any S-Expression the rule chooses to stack."
+ (Rule nil) ; Name of rule
+ (Value nil))
+
+; 2. Recursive descent parsing support routines (semantically related to MetaLanguage)
+;
+; This section of the code contains:
+;
+; A. Routines for stacking and retrieving reductions of rules.
+; B. Routines for applying certain metagrammatical elements
+; of a production (e.g., Star).
+; C. Token-level parsing utilities (keywords, strings, identifiers).
+
+; 2A. Routines for stacking and retrieving reductions of rules.
+
+; FUNCTIONS DEFINED IN THIS SECTION:
+;
+; Push-Reduction Pop-Reduction
+
+(defparameter Reduce-Stack (make-stack) "Stack of results of reduced productions.")
+
+(defun Push-Reduction (rule redn)
+ (stack-push (make-reduction :rule rule :value redn) Reduce-Stack))
+
+(defun reduce-stack-show ()
+ (let ((store (stack-store reduce-stack))
+ (*print-pretty* t))
+ (if store
+ (progn (format t "~%Reduction stack contains:~%")
+ (mapcar #'(lambda (x) (if (eq (type-of x) 'token)
+ #+Symbolics (zl:describe-defstruct x)
+ #-Symbolics (describe x)
+ (print x)))
+ (stack-store reduce-stack)))
+ (format t "~%There is nothing on the reduction stack.~%"))))
+
+(defmacro reduce-stack-clear () `(stack-load nil reduce-stack))
+
+(defun Pop-Reduction () (stack-pop Reduce-Stack))
+
+(defmacro pop-stack-1 () '(reduction-value (Pop-Reduction)))
+
+(defmacro pop-stack-2 ()
+ `(let* ((top (Pop-Reduction)) (next (Pop-Reduction)))
+ (stack-push top Reduce-Stack)
+ (reduction-value next)))
+
+(defmacro pop-stack-3 ()
+ `(let* ((top (Pop-Reduction)) (next (Pop-Reduction)) (nnext (Pop-Reduction)))
+ (stack-push next Reduce-Stack)
+ (stack-push top Reduce-Stack)
+ (reduction-value nnext)))
+
+(defmacro pop-stack-4 ()
+ `(let* ((top (Pop-Reduction))
+ (next (Pop-Reduction))
+ (nnext (Pop-Reduction))
+ (nnnext (Pop-Reduction)))
+ (stack-push nnext Reduce-Stack)
+ (stack-push next Reduce-Stack)
+ (stack-push top Reduce-Stack)
+ (reduction-value nnnext)))
+
+(defmacro nth-stack (x)
+ `(reduction-value (nth (1- ,x) (stack-store Reduce-Stack))))
+
; *** 2. META Line Handling
@@ -95,12 +496,142 @@ empty (if File-Closed (return nil))
; BSTRING: "[" ... "]*"
; ID: letters, _ and then numbers
; NUMBER: digits, ., digits, e, +-, digits
+
+; 3A (1) Token Handling.
+
+; Tokens are acquired from a stream of characters. Lexical analysis is performed
+; by the functiond Get Token. One-token lookahead is maintained in variables
+; Current-Token and Next-Token by procedures Current Token, Next Token, and
+; Advance Token. The functions Match Current Token and Match Next Token recognize
+; classes of tokens, by type, or by type and symbol. The current and next tokens
+; can be shoved back on the input stream (to the current line) with Unget-Tokens.
+
+(defmacro Defun-Parse-Token (token)
+ `(defun ,(intern (concatenate 'string "PARSE-" (string token))) ()
+ (let* ((tok (match-current-token ',token))
+ (symbol (if tok (token-symbol tok))))
+ (if tok (progn (Push-Reduction
+ ',(intern (concatenate 'string (string token)
+ "-TOKEN"))
+ (copy-tree symbol))
+ (advance-token)
+ t)))))
+
+(defun token-stack-show ()
+ (if (= Valid-Tokens 0) (format t "~%There are no valid tokens.~%")
+ (format t "~%The number of valid tokens is ~S.~%" Valid-Tokens))
+ (if (> Valid-Tokens 0)
+ (progn (format t "The current token is~%")
+ #+Symbolics (zl:describe-defstruct current-token)
+ #-Symbolics (describe current-token)
+ ))
+ (if (> Valid-Tokens 1)
+ (progn (format t "The next token is~%")
+ #+Symbolics (zl:describe-defstruct next-token)
+ #-Symbolics (describe next-token)
+ ))
+ (if (token-type prior-token)
+ (progn (format t "The prior token was~%")
+ #+Symbolics (zl:describe-defstruct prior-token)
+ #-Symbolics (describe prior-token)
+ )))
+
+(defmacro token-stack-clear ()
+ `(progn (setq valid-tokens 0)
+ (token-install nil nil current-token nil)
+ (token-install nil nil next-token nil)
+ (token-install nil nil prior-token nil)))
+
+; Unget-Tokens
+
+(defun quote-if-string (token)
+ (if token ;only use token-type on non-null tokens
+ (case (token-type token)
+ (bstring (strconc "[" (token-symbol token) "]*"))
+ (string (strconc "'" (token-symbol token) "'"))
+ (spadstring (strconc "\"" (underscore (token-symbol token)) "\""))
+ (number (format nil "~v,'0D" (token-nonblank token)
+ (token-symbol token)))
+ (special-char (string (token-symbol token)))
+ (identifier (let ((id (symbol-name (token-symbol token)))
+ (pack (package-name (symbol-package
+ (token-symbol token)))))
+ (if (or $BOOT $SPAD)
+ (if (equal pack "BOOT")
+ (escape-keywords (underscore id) (token-symbol token))
+ (concatenate 'string
+ (underscore pack) "'" (underscore id)))
+ id)))
+ (t (token-symbol token)))
+ nil))
+
+
+(defconstant Keywords
+ '(|or| |and| |isnt| |is| |otherwise| |when| |where|
+ |has| |with| |add| |case| |in| |by| |pretend| |mod|
+ |exquo| |div| |quo| |else| |rem| |then| |suchthat|
+ |if| |yield| |iterate| |from| |exit| |leave| |return|
+ |not| |unless| |repeat| |until| |while| |for| |import|)
+
+"Alphabetic literal strings occurring in the New Meta code constitute
+keywords. These are recognized specifically by the AnyId production,
+GET-BOOT-IDENTIFIER will recognize keywords but flag them
+as keywords.")
+
+
+
+(defun escape-keywords (pname id)
+ (if (member id keywords)
+ (concatenate 'string "_" pname)
+ pname))
+
+(defun underscore (string)
+ (if (every #'alpha-char-p string) string
+ (let* ((size (length string))
+ (out-string (make-array (* 2 size)
+ :element-type 'character
+ :fill-pointer 0))
+ next-char)
+ (dotimes (i size)
+ (setq next-char (char string i))
+ (if (not (alpha-char-p next-char))
+ (vector-push #\_ out-string))
+ (vector-push next-char out-string))
+ out-string)))
+
+(defun Unget-Tokens ()
+ (case Valid-Tokens
+ (0 t)
+ (1 (let* ((cursym (quote-if-string current-token))
+ (curline (line-current-segment current-line))
+ (revised-line (strconc cursym curline (copy-seq " "))))
+ (line-new-line revised-line current-line (line-number current-line))
+ (setq NonBlank (token-nonblank current-token))
+ (setq Valid-Tokens 0)))
+ (2 (let* ((cursym (quote-if-string current-token))
+ (nextsym (quote-if-string next-token))
+ (curline (line-current-segment current-line))
+ (revised-line
+ (strconc (if (token-nonblank current-token) "" " ")
+ cursym
+ (if (token-nonblank next-token) "" " ")
+ nextsym curline " ")))
+ (setq NonBlank (token-nonblank current-token))
+ (line-new-line revised-line current-line (line-number current-line))
+ (setq Valid-Tokens 0)))
+ (t (error "How many tokens do you think you have?"))))
(defun-parse-token STRING)
(defun-parse-token BSTRING)
(defun-parse-token IDENTIFIER)
(defun-parse-token NUMBER)
+; Parsing of operator tokens depends on tables initialized by BOTTOMUP.LISP
+
+(defun-parse-token SPADSTRING)
+(defun-parse-token KEYWORD)
+(defun-parse-token ARGUMENT-DESIGNATOR)
+
; Meta tokens fall into the following categories:
;
; Number
@@ -232,6 +763,8 @@ special character be the atom whose print name is the character itself."
; *** 4. META Auxiliary Parsing Actions
+(defparameter Meta_Prefix nil)
+
(defun make-defun (nametok vars body)
(let ((name (INTERN (STRCONC |META_PREFIX| nametok))))
(if vars
@@ -246,8 +779,6 @@ special character be the atom whose print name is the character itself."
(defun print-package (package)
(format out-stream "~&~%(IN-PACKAGE ~S )~%~%" package))
-(defparameter Meta_Prefix nil)
-
(defun set-prefix (prefix) (setq META_PREFIX prefix))
(defun print-rule (x) (print x out-stream) (format out-stream "~%~%"))
@@ -255,6 +786,13 @@ special character be the atom whose print name is the character itself."
; *** 5. META Error Handling
(defparameter $num_of_meta_errors 0)
+
+(defparameter Meta_Errors_Occurred nil "Did any errors occur")
+
+(defparameter Meta_Error_Handler 'meta-meta-error-handler)
+
+(defun meta-syntax-error (&optional (wanted nil) (parsing nil))
+ (funcall Meta_Error_Handler wanted parsing))
(defun meta-meta-error-handler (&optional (wanted nil) (parsing nil))
"Print syntax error indication, underline character, scrub line."
diff --git a/src/interp/newaux.lisp.pamphlet b/src/interp/newaux.lisp.pamphlet
index 11295fbd..687b2fbf 100644
--- a/src/interp/newaux.lisp.pamphlet
+++ b/src/interp/newaux.lisp.pamphlet
@@ -73,7 +73,7 @@
(SETQ OPASSOC (ADDASSOC Y (CONS (CONS X X) (LASSOC Y OPASSOC)) OPASSOC))
(SECOND X))
-(setq |PARSE-NewKEY| nil) ;;list of keywords
+(defvar |PARSE-NewKEY| nil) ;;list of keywords
(mapcar #'(LAMBDA(J) (MAKENEWOP J '|Led|))
'((* 800 801) (|rem| 800 801) (|mod| 800 801)
@@ -235,7 +235,8 @@ is [[+]] for Integers.
@
<<*>>=
<<license>>
-
+
+(IMPORT-MODULE "macros")
(in-package "BOOT")
<<LEDNUDTables>>
diff --git a/src/interp/nlib.lisp.pamphlet b/src/interp/nlib.lisp.pamphlet
index 24f86ccd..e16a57b7 100644
--- a/src/interp/nlib.lisp.pamphlet
+++ b/src/interp/nlib.lisp.pamphlet
@@ -79,6 +79,7 @@ but has been changed to read:
<<*>>=
<<license>>
+(IMPORT-MODULE "macros")
(in-package "BOOT")
#+:AKCL (defvar *lisp-bin-filetype* "o")
@@ -101,10 +102,7 @@ but has been changed to read:
:direction :output :if-exists :supersede))
optionlist)))
-(defun directory? (filename) (boot::|directoryp| filename))
-
;; (RDEFIOSTREAM ((MODE . IO) (FILE fn ft dir))) IO is I,O,INPUT,OUTPUT
-#+:AKCL
(defun rdefiostream (options &optional (missing-file-error-flag t))
(let ((mode (cdr (assoc 'mode options)))
(file (assoc 'file options))
@@ -127,7 +125,7 @@ but has been changed to read:
((equal (elt (string mode) 0) #\O)
;;(setq fullname (make-full-namestring (cdr file) 'LISPLIB))
(setq fullname (make-full-namestring (cdr file) 'NIL))
- (case (directory? fullname)
+ (case (|directoryp| fullname)
(-1 (makedir fullname))
(0 (error (format nil "~s is an existing file, not a library" fullname)))
(otherwise))
@@ -137,36 +135,6 @@ but has been changed to read:
:indexstream stream ))
('t (ERROR "Unknown MODE")))))
-#+:CCL
-(defun rdefiostream (options &optional (missing-file-error-flag t))
- (let ((mode (cdr (assoc 'mode options)))
- (file (assoc 'file options))
- (stream nil)
- (fullname nil)
- (indextable nil))
- (cond ((equal (elt (string mode) 0) #\I)
- (setq fullname (make-input-filename (cdr file) NIL))
- (setq stream (get-input-index-stream fullname))
- (if (null stream)
- (if missing-file-error-flag
- (ERROR (format nil "Library ~s doesn't exist"
- (make-filename (cdr file) NIL)))
- NIL)
- (make-libstream :mode 'input :dirname fullname
- :indextable (get-index-table-from-stream stream)
- :indexstream stream)))
- ((equal (elt (string mode) 0) #\O)
- (setq fullname (make-full-namestring (cdr file) NIL))
- (create-directory fullname)
- (multiple-value-setq (stream indextable)
- (get-io-index-stream fullname))
- (make-libstream :mode 'output :dirname fullname
- :indextable indextable
- :indexstream stream ))
- ('t (ERROR "Unknown MODE")))))
-
-#+:AKCL (defvar *index-filename* "index.KAF")
-#+:CCL (defvar *index-filename* "index.KAF")
;get the index table of the lisplib in dirname
(defun getindextable (dirname)
@@ -188,7 +156,6 @@ but has been changed to read:
(read stream))
(t pos))))
-#+:AKCL
(defun get-io-index-stream (dirname)
(let* ((index-file (concat dirname "/" *index-filename*))
(stream (open index-file :direction :io :if-exists :overwrite
@@ -204,24 +171,6 @@ but has been changed to read:
(setq indextable pos)))
(values stream indextable)))
-#+:CCL
-(defun get-io-index-stream (dirname)
- (let ((index-file (concat dirname "/" *index-filename*))
- (indextable ())
- (stream) (pos))
- (cond ((probe-file index-file)
- (setq stream (open index-file :direction :io :if-exists :overwrite))
- (setq pos (read stream))
- (file-position stream pos)
- (setq indextable (read stream))
- (file-position stream pos))
- (t (setq stream (open index-file :direction :io
- :if-does-not-exist :create))
- ;(file-position stream 0)
- (princ " " stream)))
- (values stream indextable)))
-
-
;substitute indextable in dirname
(defun write-indextable (indextable stream)
@@ -248,10 +197,11 @@ but has been changed to read:
(file-position stream :end)
(write-indextable indextable stream)))
-;makedir (fname) fname is a directory name.
-#+:AKCL
+;; makedir (fname) fname is a directory name.
(defun makedir (fname)
- (system (concat "mkdir " fname)))
+ #+ (and (not :GCL) :COMMON-LISP) (ensure-directories-exist fname)
+ #+ :GCL (system (concat "mkdir " fname))
+ )
;; (RREAD key rstream)
(defun rread (key rstream &optional (error-val nil error-val-p))
@@ -366,14 +316,14 @@ but has been changed to read:
(if (or (not mdate) (datelessp mdate ldate))
(seq
(if (null output-library)
- (boot::|openOutputLibrary|
- (setq boot::|$outputLibraryName|
- (if (null boot::|$outputLibraryName|)
+ (|openOutputLibrary|
+ (setq |$outputLibraryName|
+ (if (null |$outputLibraryName|)
(make-pathname :directory (get-current-directory)
:name "user.lib")
- (if (filep boot::|$outputLibraryName|)
- (truename boot::|$outputLibraryName|)
- boot::|$outputLibraryName|)))))
+ (if (filep |$outputLibraryName|)
+ (truename |$outputLibraryName|)
+ |$outputLibraryName|)))))
(compile-file lfile
:output-file (intern (pathname-name
(directory-namestring lfile))))))))
@@ -444,10 +394,9 @@ but has been changed to read:
(defun probe-name (file)
(if (probe-file file) (namestring file) nil))
-(defun get-directory-list (ft &aux (cd (namestring $current-directory)))
- (declare (special $current-directory))
+(defun get-directory-list (ft &aux (cd (namestring (get-current-directory))))
(cond ((member ft '("NRLIB" "DAASE" "EXPOSED") :test #'string=)
- (if (eq BOOT::|$UserLevel| 'BOOT::|development|)
+ (if (eq |$UserLevel| '|development|)
(cons cd $library-directory-list)
$library-directory-list))
(t (adjoin cd
@@ -511,24 +460,6 @@ but has been changed to read:
(system (concat "cp " namestring1 " " namestring2)))
-(defvar $filetype-table
- '((BOOT::LISPLIB . |LILIB|)
- (BOOT::SPADLIB . |slib|)
- (BOOT::HISTORY . |hist|)
- (BOOT::HELPSPAD . |help|)
- (BOOT::INPUT . |input|)
- (BOOT::SPAD . |spad|)
- (BOOT::BOOT . |boot|)
- (BOOT::LISP . |lsp|)
- (BOOT::META . |meta|)
- (BOOT::OUTPUT . |splog|)
- (BOOT::ERRORLIB . |erlib|)
- (BOOT::DATABASE . |DAASE|)
- (BOOT::SPADDATA . |sdata|)
- (BOOT::SPADFORT . |sfort|)
- (BOOT::SPADFORM . |sform|)
- (BOOT::SPADTEX . |stex|)
- (BOOT::SPADOUT . |spout|)))
@
\eject
\begin{thebibliography}{99}
diff --git a/src/interp/parsing.lisp b/src/interp/parsing.lisp
index d607ce93..54ee8efd 100644
--- a/src/interp/parsing.lisp
+++ b/src/interp/parsing.lisp
@@ -74,15 +74,9 @@
; NEWMETA.LISP: Boot parsing
-(import-module "vmlisp")
+(import-module "metalex")
(in-package "BOOT")
-; 0. Current I/O Stream definition
-
-(defparameter in-stream t "Current input stream.")
-(defparameter out-stream t "Current output stream.")
-(defparameter File-Closed nil "Way to stop EOF tests for console input.")
-
(defun IOStreams-Show ()
(format t "~&Input is coming from ~A, and output is going to ~A.~%"
(or (streamp in-stream) "the keyboard")
@@ -97,218 +91,6 @@
(setq File-Closed nil)
(IOStreams-Set ,in ,out)))
-; 1. Data structure declarations (defstructs) for parsing objects
-;
-; A. Line Buffer
-; B. Stack
-; C. Token
-; D. Reduction
-
-; 1A. A Line Buffer
-;
-; The philosophy of lines is that
-;
-; a) NEXT LINE will always get you a non-blank line or fail.
-; b) Every line is terminated by a blank character.
-;
-; Hence there is always a current character, because there is never a non-blank line,
-; and there is always a separator character between tokens on separate lines.
-; Also, when a line is read, the character pointer is always positioned ON the first
-; character.
-
-; FUNCTIONS DEFINED IN THIS SECTION:
-;
-; Line-Buffer, Line-Current-Char, Line-Current-Index, Line-Last-Index, Line-Number
-; Line-New-Line, Line-Advance-Char, Line-Past-End-P, Line-At-End-P
-; Make-Line
-
-(defstruct Line "Line of input file to parse."
- (Buffer (make-string 0) :type string)
- (Current-Char #\Return :type character)
- (Current-Index 1 :type fixnum)
- (Last-Index 0 :type fixnum)
- (Number 0 :type fixnum))
-
-(defun Line-Print (line)
- (format out-stream "~&~5D> ~A~%" (Line-Number line) (Line-Buffer Line))
- (format out-stream "~v@T^~%" (+ 7 (Line-Current-Index line))))
-
-(defmacro Line-Clear (line)
- `(let ((l ,line))
- (setf (Line-Buffer l) (make-string 0)
- (Line-Current-Char l) #\Return
- (Line-Current-Index l) 1
- (Line-Last-Index l) 0
- (Line-Number l) 0)))
-
-(defun Line-Current-Segment (line)
- "Buffer from current index to last index."
- (if (line-at-end-p line) (make-string 0)
- (subseq (Line-Buffer line)
- (Line-Current-Index line)
- (Line-Last-Index line))))
-
-(defun Line-New-Line (string line &optional (linenum nil))
- "Sets string to be the next line stored in line."
- (setf (Line-Last-Index line) (1- (length string))
- (Line-Current-Index line) 0
- (Line-Current-Char line) (or (and (> (length string) 0) (elt string 0)) #\Return)
- (Line-Buffer line) string
- (Line-Number line) (or linenum (1+ (Line-Number line)))))
-
-(defun Line-Advance-Char (line)
- (setf (Line-Current-Char line)
- (elt (Line-Buffer line) (incf (Line-Current-Index line)))))
-
-(defun Line-Next-Char (line)
- (elt (Line-Buffer line) (1+ (Line-Current-Index line))))
-
-(defun Line-Past-End-P (line)
- "Tests if line is empty or positioned past the last character."
- (> (line-current-index line) (line-last-index line)))
-
-(defun Line-At-End-P (line)
- "Tests if line is empty or positioned past the last character."
- (>= (line-current-index line) (line-last-index line)))
-
-; 1B. A Stack (of lines, tokens, or whatever)
-
-; FUNCTIONS DEFINED IN THIS SECTION:
-;
-; Make-Stack, Stack-Store, Stack-Size, Stack-Top, Stack-Load, Stack-Clear,
-; Stack-/-Empty, Stack-Push, Stack-Pop
-
-(defstruct Stack "A stack"
- (Store nil) ; contents of the stack
- (Size 0) ; number of elements in Store
- (Top nil) ; first element of Store
-
- (Updated nil) ; whether something has been pushed on the stack
- ; since this flag was last set to NIL
-)
-
-(defun stack-load (list stack)
- (setf (stack-store stack) list
- (stack-size stack) (length list)
- (stack-top stack) (car list)))
-
-(defun stack-clear (stack)
- (setf (stack-store stack) nil (stack-size stack) 0 (stack-top stack) nil
- (stack-updated stack) nil))
-
-(defmacro stack-/-empty (stack) `(> (stack-size ,stack) 0))
-
-(defun stack-push (x stack)
- (push x (stack-store stack))
- (setf (stack-top stack) x (stack-updated stack) t)
- (incf (stack-size stack))
- x)
-
-(defun stack-pop (stack)
- (let ((y (pop (stack-store stack))))
- (decf (stack-size stack))
- (setf (stack-top stack) (if (stack-/-empty stack) (car (stack-store stack))))
- y))
-
-; 1C. Token
-
-; FUNCTIONS DEFINED IN THIS SECTION:
-;
-; Make-Token, Token-Symbol, Token-Type, Token-Install, Token-Print
-
-(defstruct Token
- "A token is a Symbol with a Type.
-The type is either NUMBER, IDENTIFIER or SPECIAL-CHAR.
-NonBlank is true if the token is not preceded by a blank."
- (Symbol nil)
- (Type nil)
- (NonBlank t))
-
-(defparameter Prior-Token (make-token) "What did I see last")
-(defparameter nonblank t "Is there no blank in front of the current token.")
-(defparameter Current-Token (make-token) "Token at head of input stream.")
-(defparameter Next-Token (make-token) "Next token in input stream.")
-(defparameter Valid-Tokens 0 "Number of tokens in buffer (0, 1 or 2)")
-
-(defun Token-Install (symbol type token &optional (nonblank t))
- (setf (token-symbol token) symbol (token-type token) type
- (token-nonblank token) nonblank)
- token)
-
-(defun Token-Print (token)
- (format out-stream "(token (symbol ~S) (type ~S))~%"
- (Token-Symbol token) (Token-Type token)))
-
-; 1D. A Reduction
-;
-
-(defstruct (Reduction (:type list))
-"A reduction of a rule is any S-Expression the rule chooses to stack."
- (Rule nil) ; Name of rule
- (Value nil))
-
-; 2. Recursive descent parsing support routines (semantically related to MetaLanguage)
-;
-; This section of the code contains:
-;
-; A. Routines for stacking and retrieving reductions of rules.
-; B. Routines for applying certain metagrammatical elements
-; of a production (e.g., Star).
-; C. Token-level parsing utilities (keywords, strings, identifiers).
-
-; 2A. Routines for stacking and retrieving reductions of rules.
-
-; FUNCTIONS DEFINED IN THIS SECTION:
-;
-; Push-Reduction Pop-Reduction
-
-(defparameter Reduce-Stack (make-stack) "Stack of results of reduced productions.")
-
-(defun Push-Reduction (rule redn)
- (stack-push (make-reduction :rule rule :value redn) Reduce-Stack))
-
-(defun reduce-stack-show ()
- (let ((store (stack-store reduce-stack))
- (*print-pretty* t))
- (if store
- (progn (format t "~%Reduction stack contains:~%")
- (mapcar #'(lambda (x) (if (eq (type-of x) 'token)
- #+Symbolics (zl:describe-defstruct x)
- #-Symbolics (describe x)
- (print x)))
- (stack-store reduce-stack)))
- (format t "~%There is nothing on the reduction stack.~%"))))
-
-(defmacro reduce-stack-clear () `(stack-load nil reduce-stack))
-
-(defun Pop-Reduction () (stack-pop Reduce-Stack))
-
-(defmacro pop-stack-1 () '(reduction-value (Pop-Reduction)))
-
-(defmacro pop-stack-2 ()
- `(let* ((top (Pop-Reduction)) (next (Pop-Reduction)))
- (stack-push top Reduce-Stack)
- (reduction-value next)))
-
-(defmacro pop-stack-3 ()
- `(let* ((top (Pop-Reduction)) (next (Pop-Reduction)) (nnext (Pop-Reduction)))
- (stack-push next Reduce-Stack)
- (stack-push top Reduce-Stack)
- (reduction-value nnext)))
-
-(defmacro pop-stack-4 ()
- `(let* ((top (Pop-Reduction))
- (next (Pop-Reduction))
- (nnext (Pop-Reduction))
- (nnnext (Pop-Reduction)))
- (stack-push nnext Reduce-Stack)
- (stack-push next Reduce-Stack)
- (stack-push top Reduce-Stack)
- (reduction-value nnnext)))
-
-(defmacro nth-stack (x)
- `(reduction-value (nth (1- ,x) (stack-store Reduce-Stack))))
-
; 2B. Routines for applying certain metagrammatical elements
; of a production (e.g., Star).
@@ -316,7 +98,7 @@ NonBlank is true if the token is not preceded by a blank."
; FUNCTIONS DEFINED IN THIS SECTION:
;
-; Star, Bang, Must, Optional, Action, Sequence
+; Star, Bang, Must, Optional, Action
(defmacro Star (lab prod)
@@ -377,34 +159,6 @@ the stack, then stack a NIL. Return the value of prod."
(defun action (dothis) (or dothis t))
-; A sequence consists of a head, which if recognized implies that the
-; tail must follow. Following tail are actions, which
-; are performed upon recognizing the head and tail.
-
-(defmacro sequence (subrules &optional (actions nil))
- `(and ,(pop subrules) . ,(append (mapcar #'(lambda (x) (list 'must x)) subrules)
- (if actions `((progn . ,(append actions '(t))))))))
-
-; 3. Routines for handling lexical scanning
-;
-; Lexical scanning of tokens is performed off of the current line. No
-; token can span more than 1 line. All real I/O is handled in a line-oriented
-; fashion (in a slight paradox) below the character level. All character
-; routines implicitly assume the parameter Current-Line. We do not make
-; Current-Line an explicit optional parameter for reasons of efficiency.
-
-(defparameter Current-Line (make-line) "Current input line.")
-
-(defmacro current-line-print () '(Line-Print Current-Line))
-
-(defmacro current-line-show ()
- `(if (line-past-end-p current-line)
- (format t "~&The current line is empty.~%")
- (progn (format t "~&The current line is:~%~%")
- (current-line-print))))
-
-(defmacro current-line-clear () `(Line-Clear Current-Line))
-
; 3A. Manipulating the token stack and reading tokens
; This section is broken up into 3 levels:
@@ -464,200 +218,7 @@ the stack, then stack a NIL. Return the value of prod."
(let ((x (string-not-greaterp part whole)))
(and x (= x (length part)) x)))
-; 3A (1) Token Handling.
-
-; Tokens are acquired from a stream of characters. Lexical analysis is performed
-; by the functiond Get Token. One-token lookahead is maintained in variables
-; Current-Token and Next-Token by procedures Current Token, Next Token, and
-; Advance Token. The functions Match Current Token and Match Next Token recognize
-; classes of tokens, by type, or by type and symbol. The current and next tokens
-; can be shoved back on the input stream (to the current line) with Unget-Tokens.
-
-(defmacro Defun-Parse-Token (token)
- `(defun ,(intern (concatenate 'string "PARSE-" (string token))) ()
- (let* ((tok (match-current-token ',token))
- (symbol (if tok (token-symbol tok))))
- (if tok (progn (Push-Reduction
- ',(intern (concatenate 'string (string token)
- "-TOKEN"))
- (copy-tree symbol))
- (advance-token)
- t)))))
-
-(defun token-stack-show ()
- (if (= Valid-Tokens 0) (format t "~%There are no valid tokens.~%")
- (format t "~%The number of valid tokens is ~S.~%" Valid-Tokens))
- (if (> Valid-Tokens 0)
- (progn (format t "The current token is~%")
- #+Symbolics (zl:describe-defstruct current-token)
- #-Symbolics (describe current-token)
- ))
- (if (> Valid-Tokens 1)
- (progn (format t "The next token is~%")
- #+Symbolics (zl:describe-defstruct next-token)
- #-Symbolics (describe next-token)
- ))
- (if (token-type prior-token)
- (progn (format t "The prior token was~%")
- #+Symbolics (zl:describe-defstruct prior-token)
- #-Symbolics (describe prior-token)
- )))
-
-(defmacro token-stack-clear ()
- `(progn (setq valid-tokens 0)
- (token-install nil nil current-token nil)
- (token-install nil nil next-token nil)
- (token-install nil nil prior-token nil)))
-
-; Unget-Tokens
-
-(defun quote-if-string (token)
- (if token ;only use token-type on non-null tokens
- (case (token-type token)
- (bstring (strconc "[" (token-symbol token) "]*"))
- (string (strconc "'" (token-symbol token) "'"))
- (spadstring (strconc "\"" (underscore (token-symbol token)) "\""))
- (number (format nil "~v,'0D" (token-nonblank token)
- (token-symbol token)))
- (special-char (string (token-symbol token)))
- (identifier (let ((id (symbol-name (token-symbol token)))
- (pack (package-name (symbol-package
- (token-symbol token)))))
- (if (or $BOOT $SPAD)
- (if (equal pack "BOOT")
- (escape-keywords (underscore id) (token-symbol token))
- (concatenate 'string
- (underscore pack) "'" (underscore id)))
- id)))
- (t (token-symbol token)))
- nil))
-
-(defun escape-keywords (pname id)
- (if (member id keywords)
- (concatenate 'string "_" pname)
- pname))
-
-(defun underscore (string)
- (if (every #'alpha-char-p string) string
- (let* ((size (length string))
- (out-string (make-array (* 2 size)
- :element-type 'character
- :fill-pointer 0))
- next-char)
- (dotimes (i size)
- (setq next-char (char string i))
- (if (not (alpha-char-p next-char))
- (vector-push #\_ out-string))
- (vector-push next-char out-string))
- out-string)))
-
-(defun Unget-Tokens ()
- (case Valid-Tokens
- (0 t)
- (1 (let* ((cursym (quote-if-string current-token))
- (curline (line-current-segment current-line))
- (revised-line (strconc cursym curline (copy-seq " "))))
- (line-new-line revised-line current-line (line-number current-line))
- (setq NonBlank (token-nonblank current-token))
- (setq Valid-Tokens 0)))
- (2 (let* ((cursym (quote-if-string current-token))
- (nextsym (quote-if-string next-token))
- (curline (line-current-segment current-line))
- (revised-line
- (strconc (if (token-nonblank current-token) "" " ")
- cursym
- (if (token-nonblank next-token) "" " ")
- nextsym curline " ")))
- (setq NonBlank (token-nonblank current-token))
- (line-new-line revised-line current-line (line-number current-line))
- (setq Valid-Tokens 0)))
- (t (error "How many tokens do you think you have?"))))
-
-; *** Match Token
-
-(defun match-token (token type &optional (symbol nil))
- (if (and token (eq (token-type token) type))
- (if symbol (if (equal symbol (token-symbol token)) token) token)))
-
-(defun match-current-token (type &optional (symbol nil))
- "Returns the current token if it has EQ type and (optionally) equal symbol."
- (match-token (current-token) type symbol))
-
-(defun match-next-token (type &optional (symbol nil))
- "Returns the next token if it has equal type and (optionally) equal symbol."
- (match-token (next-token) type symbol))
-
-; *** Current Token, Next Token, Advance Token
-
-(defun try-get-token (token)
- (let ((tok (get-token token)))
- (if tok (progn (incf Valid-Tokens) token))))
-
-(defun current-symbol () (make-symbol-of (current-token)))
-
-(defun make-symbol-of (token)
- (let ((u (and token (token-symbol token))))
- (cond ((not u) nil)
- ((characterp u) (intern (string u)))
- (u))))
-
-(defun current-token ()
- "Returns the current token getting a new one if necessary."
- (if (> Valid-Tokens 0)
- Current-Token
- (try-get-token Current-Token)))
-
-(defun next-token ()
- "Returns the token after the current token, or NIL if there is none after."
- (current-token)
- (if (> Valid-Tokens 1)
- Next-Token
- (try-get-token Next-Token)))
-
-(defun advance-token ()
- (current-token) ;don't know why this is needed
- "Makes the next token be the current token."
- (case Valid-Tokens
- (0 (try-get-token (Current-Token)))
- (1 (decf Valid-Tokens)
- (setq Prior-Token (copy-token Current-Token))
- (try-get-token Current-Token))
- (2 (setq Prior-Token (copy-token Current-Token))
- (setq Current-Token (copy-token Next-Token))
- (decf Valid-Tokens))))
-
-(defparameter XTokenReader 'get-meta-token "Name of tokenizing function")
-
-; *** Get Token
-
-(defun get-token (token) (funcall XTokenReader token))
-
-; 3A (2) Character handling.
-
-; FUNCTIONS DEFINED IN THIS SECTION:
-;
-; Current-Char, Next-Char, Advance-Char
-
-; *** Current Char, Next Char, Advance Char
-
-(defun Current-Char ()
- "Returns the current character of the line, initially blank for an unread line."
- (if (Line-Past-End-P Current-Line) #\Return (Line-Current-Char Current-Line)))
-
-(defun Next-Char ()
- "Returns the character after the current character, blank if at end of line.
-The blank-at-end-of-line assumption is allowable because we assume that end-of-line
-is a token separator, which blank is equivalent to."
- (if (Line-At-End-P Current-Line) #\Return (Line-Next-Char Current-Line)))
-
-(defun Advance-Char ()
- "Advances IN-STREAM, invoking Next Line if necessary."
- (loop (cond ((not (Line-At-End-P Current-Line))
- (return (Line-Advance-Char Current-Line)))
- ((next-line in-stream)
- (return (current-char)))
- ((return nil)))))
; 3A 3. Line Handling.
@@ -665,75 +226,10 @@ is a token separator, which blank is equivalent to."
;
; Echo-Meta
-; *** Next Line
-
-(defparameter Echo-Meta nil "T if you want a listing of what has been read.")
-(defparameter Line-Handler 'next-META-line "Who grabs lines for us.")
-
-(defun next-line (&optional (in-stream t)) (funcall Line-Handler in-stream))
-
-(defun make-string-adjustable (s)
- (cond ((adjustable-array-p s) s)
- (t (make-array (array-dimensions s) :element-type 'character
- :adjustable t :initial-contents s))))
-
-(defun get-a-line (stream)
- (if (IS-CONSOLE stream) (princ (MKPROMPT)))
- (let ((ll (read-a-line stream)))
- (if (stringp ll) (make-string-adjustable ll) ll)))
-
-(defparameter Current-Fragment nil
- "A string containing remaining chars from readline; needed because
-Symbolics read-line returns embedded newlines in a c-m-Y.")
-
-(defun input-clear () (setq Current-Fragment nil))
-
-#-:CCL
-(defun read-a-line (&optional (stream t))
- (let (cp)
- (if (and Current-Fragment (> (length Current-Fragment) 0))
- (let ((line (with-input-from-string
- (s Current-Fragment :index cp :start 0)
- (read-line s nil nil))))
- (setq Current-Fragment (subseq Current-Fragment cp))
- line)
- (prog nil
- (if (stream-eof in-stream)
- (progn (setq File-Closed t *EOF* t)
- (Line-New-Line (make-string 0) Current-Line)
- (return nil)))
- (if (setq Current-Fragment (read-line stream))
- (return (read-a-line stream)))))))
-#+:CCL
-(defun read-a-line (&optional (stream t))
- (let ((line (read-line stream nil nil)))
- (if (null line)
- (progn (setq File-Closed t *EOF* t)
- (Line-New-Line (make-string 0) Current-Line)
- nil)
- line)))
-
-; *** Print New Line
-
-(defparameter Printer-Line-Stack (make-stack)
- "Stack of output listing lines waiting to print. [local to PRINT-NEW-LINE]")
-
-(defparameter Read-Quietly nil
- "Whether or not to produce an output listing. [local to PRINT-NEW-LINE]")
-
-(defun Print-New-Line (string &optional (strm *terminal-io*))
- "Makes output listings."
- (if Read-Quietly (stack-push (copy-tree string) Printer-Line-Stack)
- (progn (mapc #'(lambda (x) (format strm "; ~A~%" x) (terpri))
- (nreverse (stack-store Printer-Line-Stack)))
- (stack-clear Printer-Line-Stack)
- (format strm "~&; ~A~%" string))))
-
; 3B. Error handling
(defparameter errcol nil)
(defparameter line nil)
-(defparameter count nil)
(defun conversation (x y)
(prog (u)
@@ -762,13 +258,6 @@ Symbolics read-line returns embedded newlines in a c-m-Y.")
(defun compfin () (or (match-string ")fin") (match-string ".FIN")))
-(defparameter Meta_Errors_Occurred nil "Did any errors occur")
-
-(defparameter Meta_Error_Handler 'meta-meta-error-handler)
-
-(defun meta-syntax-error (&optional (wanted nil) (parsing nil))
- (funcall Meta_Error_Handler wanted parsing))
-
; 3 C. Constructing parsing procedures
; FUNCTIONS DEFINED IN THIS SECTION:
@@ -893,7 +382,9 @@ Symbolics read-line returns embedded newlines in a c-m-Y.")
(set flnam pfx-funlist)
(if (not (lessp (setq n (length metapfx)) 0))
(setq unpfx-funlist
- (mapcar #'(lambda (x) (intern (subseq (copy-symbol (pname x)) n)))
+ (mapcar #'(lambda (x)
+ (intern (subseq
+ (symbol-name (copy-symbol (pname x))) n)))
pfx-funlist)))
(if unpfx-funlist (list pfx-funlist unpfx-funlist))))
@@ -977,6 +468,8 @@ Symbolics read-line returns embedded newlines in a c-m-Y.")
(terpri)
(/embed-q x y))
+(defvar /embednames)
+
(defun /embed-q (x y)
(setq /embednames (cons x /embednames))
(embed x
@@ -993,8 +486,6 @@ Symbolics read-line returns embedded newlines in a c-m-Y.")
(if (atom (embedded)) '(|none| |embedded|)
(append (embedded) (list '|embedded|))))
-(defun numofargs (fn) (numberofargs (car (/mdef (cons fn '(x))))))
-
(defparameter mdeftrace nil "")
(defun /mdef (x)
diff --git a/src/interp/patches.lisp.pamphlet b/src/interp/patches.lisp.pamphlet
index 04fcc390..17a3e1bc 100644
--- a/src/interp/patches.lisp.pamphlet
+++ b/src/interp/patches.lisp.pamphlet
@@ -93,15 +93,15 @@ previous definition.
(setq ,streamvar *terminal-io*)))
(defun |cd| (args)
- (cond ((null args)
-#+(and :lucid :ibm/370)
- (setq $current-directory "")
-#-(and :lucid :ibm/370)
- (setq $current-directory (truename (user-homedir-pathname))) )
- ((eql (|directoryp| (interp-make-directory (car args))) 1)
- (setq $current-directory (namestring (truename (interp-make-directory (car args)))))))
-#+(or :kcl :ibcl :CCL) (system:CHDIR $current-directory)
- (|sayKeyedMsg| 'S2IZ0070 (list (namestring $current-directory))))
+ (let ((dir (truename (string (or (car args) "")))))
+ #+ :SBCL (sb-posix::chdir (namestring dir))
+ #+ :GCL (system::chdir (namestring dir))
+ #- (or :SBCL :GCL) (error "don't know how to chdir in this Lisp")
+ ;; FIXME: some Lisps may not properly end the name with slash
+ ;; investigate.
+ (setf *default-pathname-defaults* dir)
+ (|sayKeyedMsg| 'S2IZ0070
+ (list (namestring *default-pathname-defaults*)))))
<<toplevel>>
(define-function 'top-level #'toplevel)
@@ -123,14 +123,17 @@ previous definition.
(obey string))
(|terminateSystemCommand|))
(setq *print-escape* nil) ;; so stringimage doesn't escape idents?
-#+(or :IEEE-FLOATING-POINT)
+#+(and :GCL :IEEE-FLOATING-POINT )
(setq system:*print-nans* T)
+
(defun /RF (&rest foo &aux (Echo-Meta 'T))
(declare (special Echo-Meta))
(/RF-1 nil))
+
(defun /RQ (&rest foo &aux (Echo-Meta nil))
(declare (special Echo-Meta))
(/RF-1 nil))
+
(defun |/RQ,LIB| (&rest foo &aux (Echo-Meta nil) ($LISPLIB T))
(declare (special Echo-Meta $LISPLIB))
(/RF-1 nil))
@@ -188,7 +191,6 @@ previous definition.
(set-file-getter (strconc asharprootlib "axextend.o")))
)
-(defun AKCL-VERSION () system::*akcl-version*)
(defun SHAREDITEMS (x) T) ;;checked in history code
(defun whocalled (n) nil) ;; no way to look n frames up the stack
(defun setletprintflag (x) x)
diff --git a/src/interp/postpar.boot.pamphlet b/src/interp/postpar.boot.pamphlet
index 4e4d01e7..67cf814a 100644
--- a/src/interp/postpar.boot.pamphlet
+++ b/src/interp/postpar.boot.pamphlet
@@ -49,6 +49,7 @@
<<*>>=
<<license>>
+import '"postprop"
)package "BOOT"
$postStack := []
@@ -151,7 +152,7 @@ postConstruct u ==
postError msg ==
BUMPERRORCOUNT 'precompilation
xmsg:=
- $defOp ^= '$defOp and not InteractiveMode => [$defOp,'": ",:msg]
+ $defOp ^= '$defOp and not $InteractiveMode => [$defOp,'": ",:msg]
msg
$postStack:= [xmsg,:$postStack]
nil
diff --git a/src/interp/postprop.lisp b/src/interp/postprop.lisp
index 921c58c3..30ac7248 100644
--- a/src/interp/postprop.lisp
+++ b/src/interp/postprop.lisp
@@ -30,6 +30,7 @@
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+(IMPORT-MODULE "macros")
(in-package "BOOT")
(mapcar #'(lambda (x) (MAKEPROP (CAR X) '|special| (CADR X)))
diff --git a/src/interp/preparse.lisp.pamphlet b/src/interp/preparse.lisp.pamphlet
index 12229874..55eb34d9 100644
--- a/src/interp/preparse.lisp.pamphlet
+++ b/src/interp/preparse.lisp.pamphlet
@@ -72,7 +72,7 @@ PURPOSE: BOOT lines are massaged by PREPARSE to make them easier to parse:
<<*>>=
<<license>>
-(provide 'Boot)
+(IMPORT-MODULE "fnewmeta")
(in-package "BOOT")
@@ -105,6 +105,10 @@ PURPOSE: BOOT lines are massaged by PREPARSE to make them easier to parse:
(initialize-preparse in-stream)
(do ((lines (PREPARSE in-stream) (PREPARSE in-stream))) ((null lines)))))
T)
+
+
+(defvar $skipme)
+(defvar $COMBLOCKLIST)
(defun PREPARSE (Strm &aux (stack ()))
(SETQ $COMBLOCKLIST NIL $skipme NIL)
diff --git a/src/interp/setq.lisp.pamphlet b/src/interp/setq.lisp.pamphlet
index 8a500f6c..ae3011b7 100644
--- a/src/interp/setq.lisp.pamphlet
+++ b/src/interp/setq.lisp.pamphlet
@@ -92,14 +92,12 @@
(SETQ |$newCompCompare| NIL)
(SETQ |$permitWhere| NIL)
(SETQ |$newSystem| T)
-(SETQ |$noSubsumption| NIL)
(SETQ |$compileDontDefineFunctions| 'T)
(SETQ |$compileOnlyCertainItems| NIL)
(SETQ |$devaluateList| NIL)
(SETQ |$doNotCompressHashTableIfTrue| NIL)
(SETQ |$mutableChecking| NIL) ; used in DEFINE BOOT
(SETQ |$mutableDomains| NIL) ; checked in DEFINE BOOT
-(SETQ |$maxSignatureLineNumber| 0)
(SETQ |$functionLocations| NIL)
(SETQ |$functorLocalParameters| NIL) ; used in compSymbol
(SETQ /RELEASE '"UNKNOWN")
@@ -193,11 +191,6 @@
(SETQ OPASSOC NIL)
(SETQ SPADSYSKEY '(EOI EOL))
-;; following 2 variables are referenced by PREPARSE1
-
-(defvar |$byConstructors| () "list of constructors to be compiled")
-(defvar |$constructorsSeen| () "list of constructors found")
-
;; These are for the output routines in OUT BOOT
(SETQ $LINELENGTH 77)
@@ -288,10 +281,6 @@
(SETQ |$useIntegerSubdomain| 'T)
(SETQ |$useNewFloat| 'T)
-;; Directories/disks on which to place various kinds of files
-(SETQ |$libraryDirectory| 'A)
-(SETQ |$listingDirectory| 'A)
-
;; the following symbol holds the canonical "failed" value
(SETQ |$failed| "failed")
diff --git a/src/interp/spad.lisp.pamphlet b/src/interp/spad.lisp.pamphlet
index bfd0a1be..010aa043 100644
--- a/src/interp/spad.lisp.pamphlet
+++ b/src/interp/spad.lisp.pamphlet
@@ -57,11 +57,11 @@
; NAME: Scratchpad Package
; PURPOSE: This is an initialization and system-building file for Scratchpad.
+(IMPORT-MODULE "bootlex")
(in-package "BOOT")
;;; Common Block
-(defvar |$UserLevel| '|development|)
(defvar |$preserveSystemLisplib| t "if nil finalizeLisplib does MA REP")
(defvar |$incrementalLisplibFlag| nil "checked in compDefineLisplib")
(defvar |$reportInstantiations| nil)
@@ -146,7 +146,6 @@
(RETURN (PROGN (S-PROCESS X) NIL))))
;; NIL needed below since END\_UNIT is not generated by current parser
-(defun |isTokenDelimiter| () (MEMBER (CURRENT-SYMBOL) '(\) END\_UNIT NIL)))
(defun |traceComp| ()
(SETQ |$compCount| 0)
@@ -365,11 +364,11 @@
(declare (special CURSTRM |$s| |$x| |$m| CUROUTSTREAM))
(SETQ |$exitModeStack| ())
(SETQ |$postStack| nil)
- (SETQ $TRACEFLAG T)
+ (SETQ |$TraceFlag| T)
(if (NOT X) (RETURN NIL))
(setq X (if $BOOT (DEF-RENAME (|new2OldLisp| X))
(|parseTransform| (|postTransform| X))))
- (if |$TranslateOnly| (RETURN (SETQ |$Translation| X)))
+ ;; (if |$TranslateOnly| (RETURN (SETQ |$Translation| X)))
(when |$postStack| (|displayPreCompilationErrors|) (RETURN NIL))
(COND (|$PrintOnly|
(format t "~S =====>~%" |$currentLine|)
@@ -432,12 +431,6 @@
(setq *prompt* 'new)
-(defun parserState ()
- (PRINT (LIST 'CHR= CHR 'NBLNK= NBLNK 'TOK= TOK 'ISID= ISID
- 'COUNT= COUNT 'COLUMN= COLUMN))
- (PRINT (LIST 'STACK= STACK 'STACKX= STACKX))
- (PRINT (LIST '$TOKSTACK= $TOKSTACK 'INPUTSTREAM= INPUTSTREAM)))
-
(defmacro try (X)
`(LET ((|$autoLine|))
(declare (special |$autoLine|))
diff --git a/src/interp/sys-constants.boot b/src/interp/sys-constants.boot
index cd8df2ac..3f75d77e 100644
--- a/src/interp/sys-constants.boot
+++ b/src/interp/sys-constants.boot
@@ -544,3 +544,27 @@ $noEnv == nil
++
IDENTITY ==
function IDENTITY
+
++++
+_*INDEX_-FILENAME_* ==
+ '"index.KAF"
+
+++
+$FILETYPE_-TABLE ==
+ [["LISPLIB", :"LILIB"],
+ ["SPADLIB", :"slib"],
+ ["HISTORY", :"hist"],
+ ["HELPSPAD", :"help"],
+ ["INPUT", :"input"],
+ ["SPAD", :"spad"],
+ ["BOOT", :"boot"],
+ ["LISP", :"lsp"],
+ ["META", :"meta"],
+ ["OUTPUT", :"splog"],
+ ["ERRORLIB", :"erlib"],
+ ["DATABASE", :"DAASE"],
+ ["SPADDATA", :"sdata"],
+ ["SPADFORT", :"sfort"],
+ ["SPADFORM", :"sform"],
+ ["SPADTEX", :"stex"],
+ ["SPADOUT", :"spout"]]
diff --git a/src/interp/sys-globals.boot b/src/interp/sys-globals.boot
index b6aadefa..723c9593 100644
--- a/src/interp/sys-globals.boot
+++ b/src/interp/sys-globals.boot
@@ -358,3 +358,43 @@ $insideCoerceInteractive := false
++
$insideEvalMmCondIfTrue := false
+++
+$libraryDirectory := "A"
+
+++
+$listingDirectory := "A"
+
+++
+$texOutputStream := MAKE_-SYNONYM_-STREAM '_*TERMINAL_-IO_*
+
+++
+$UserLevel := "development"
+
+++
+$DIRECTORY_-LIST := []
+
+++
+$LIBRARY_-DIRECTORY_-LIST := []
+
+++
+$byConstructors := nil
+
+++
+$constructorsSeen := nil
+
+++
+$docList := []
+
+++
+$headerDocumentation := nil
+
+++
+$constructorLineNumber := 0
+
+++
+$maxSignatureLineNumber := 0
+
+++
+$noSubsumption := false
+
+SPADERRORSTREAM := _*ERROR_-OUTPUT_*
diff --git a/src/interp/sys-macros.lisp b/src/interp/sys-macros.lisp
index 557ac834..3608e2ad 100644
--- a/src/interp/sys-macros.lisp
+++ b/src/interp/sys-macros.lisp
@@ -967,6 +967,13 @@
'APPEND-N)
((FAIL))))
((FAIL))))
+
+
+
+ ;; # Gives the number of elements of a list, 0 for atoms.
+ ;; If we quote it, then an interpreter trip is necessary every time
+ ;; we call #, and this costs us - 4% in the RATINT DEMO."
+ (define-function '|#| #'SIZE)
))
diff --git a/src/interp/util.lisp.pamphlet b/src/interp/util.lisp.pamphlet
index 51564c35..80d2443e 100644
--- a/src/interp/util.lisp.pamphlet
+++ b/src/interp/util.lisp.pamphlet
@@ -158,15 +158,6 @@ on the system we are using.
@
-\subsubsection{directory-list}
-
-This is the system-wide list of directories to search.
-It is set up in the {\bf reroot} function.
-<<directory-list>>=
-(defvar $directory-list ())
-
-@
-
\subsubsection{relative-directory-list}
@@ -184,15 +175,6 @@ NAG distribution back to the original form.
@
-\subsubsection{library-directory-list}
-
-This is the system-wide search path for library files.
-It is set up in the {\bf reroot} function.
-<<library-directory-list>>=
-(defvar $library-directory-list ())
-
-@
-
\subsubsection{relative-library-directory-list}
The relative directory list specifies how to find the algebra
@@ -1480,8 +1462,6 @@ function assumes that \\ can only appear as first character of name.
<<translist>>
<<relative-directory-list>>
<<relative-library-directory-list>>
-<<directory-list>>
-<<library-directory-list>>
<<boottocl>>
(in-package "BOOT")
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-26 03:23:17 +0000