diff options
| author | dos-reis <gdr@axiomatics.org> | 2007-09-19 15:30:04 +0000 |
|---|---|---|
| committer | dos-reis <gdr@axiomatics.org> | 2007-09-19 15:30:04 +0000 |
| commit | 1d71a43cca77e1576cc1568298d5886a60c9b884 (patch) | |
| tree | 270a5e091dc621fd0023f2261938cea235b0cbe9 /src | |
| parent | 1ee7a0030053e2447302d8157b9d3356a54e9b3a (diff) | |
| download | open-axiom-1d71a43cca77e1576cc1568298d5886a60c9b884.tar.gz | |
2007-09-19 Gabriel Dos Reis <gdr@cs.tamu.edu>
* Makefile.pamphlet (all-interpsys): Now depend on all-depsys.
src/interp/
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.
Diffstat (limited to 'src')
26 files changed, 930 insertions, 874 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index e4d7f549..f760fad5 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,7 @@ +2007-09-19 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet (all-interpsys): Now depend on all-depsys. + 2007-08-21 Gabriel Dos Reis <gdr@cs.tamu.edu> * Makefile.pamphlet (all-check): New rule. diff --git a/src/Makefile.in b/src/Makefile.in index b9f6bca2..2f309a78 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -43,16 +43,16 @@ all-boot: all-lisp all-depsys: all-boot cd interp && $(MAKE) all-depsys -all-interpsys: all-depsys all-lisp +ifeq (@axiom_use_x@,yes) +all-interpsys: all-depsys all-hyper +else +all-interpsys: all-depsys +endif cd interp && ${MAKE} all-interpsys all-axiomsys: all-asq cd interp && $(MAKE) all-axiomsys -ifeq (@axiom_use_x@,yes) -all-algebra: all-interpsys all-share all-hyper -else all-algebra: all-interpsys all-share -endif @ $(mkinstalldirs) algebra/strap cd algebra && ${MAKE} all-input: all-axiomsys diff --git a/src/Makefile.pamphlet b/src/Makefile.pamphlet index 4a8636b2..b6514576 100644 --- a/src/Makefile.pamphlet +++ b/src/Makefile.pamphlet @@ -141,7 +141,11 @@ same Makefile. all-depsys: all-boot cd interp && $(MAKE) all-depsys -all-interpsys: all-depsys all-lisp +ifeq (@axiom_use_x@,yes) +all-interpsys: all-depsys all-hyper +else +all-interpsys: all-depsys +endif cd interp && ${MAKE} all-interpsys all-axiomsys: all-asq @@ -191,11 +195,7 @@ steps. The first step uses the [[document]] command to extract the normal Makefile information. <<algebradir>>= -ifeq (@axiom_use_x@,yes) -all-algebra: all-interpsys all-share all-hyper -else all-algebra: all-interpsys all-share -endif @ $(mkinstalldirs) algebra/strap cd algebra && ${MAKE} @ 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") |