aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/interp/ChangeLog45
-rw-r--r--src/interp/Makefile.in100
-rw-r--r--src/interp/Makefile.pamphlet184
-rw-r--r--src/interp/apply.boot6
-rw-r--r--src/interp/i-analy.boot.pamphlet3
-rw-r--r--src/interp/i-code.boot.pamphlet3
-rw-r--r--src/interp/i-coerce.boot.pamphlet5
-rw-r--r--src/interp/i-coerfn.boot.pamphlet7
-rw-r--r--src/interp/i-eval.boot.pamphlet9
-rw-r--r--src/interp/i-funsel.boot.pamphlet76
-rw-r--r--src/interp/i-intern.boot.pamphlet388
-rw-r--r--src/interp/i-map.boot.pamphlet29
-rw-r--r--src/interp/i-object.boot273
-rw-r--r--src/interp/i-output.boot18
-rw-r--r--src/interp/i-resolv.boot.pamphlet13
-rw-r--r--src/interp/i-spec1.boot.pamphlet121
-rw-r--r--src/interp/i-spec2.boot.pamphlet175
-rw-r--r--src/interp/i-syscmd.boot.pamphlet115
-rw-r--r--src/interp/i-toplev.boot.pamphlet9
-rw-r--r--src/interp/i-util.boot.pamphlet5
-rw-r--r--src/interp/pspad1.boot2
-rw-r--r--src/interp/pspad2.boot4
-rw-r--r--src/interp/setq.lisp72
-rw-r--r--src/interp/spad.lisp8
-rw-r--r--src/interp/sys-globals.boot4
-rw-r--r--src/interp/sys-macros.lisp10
-rw-r--r--src/interp/wi2.boot2
27 files changed, 849 insertions, 837 deletions
diff --git a/src/interp/ChangeLog b/src/interp/ChangeLog
index f40fbd5f..9309fc94 100644
--- a/src/interp/ChangeLog
+++ b/src/interp/ChangeLog
@@ -1,3 +1,48 @@
+2007-11-07 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ * Makefile.pamphlet (i-toplev.$(FASLEXT)): New rule.
+ (i-syscmd.$(FASLEXT)): Likewise.
+ (i-spec2.$(FASLEXT)): Likewise.
+ (i-spec1.$(FASLEXT)): Likewise.
+ (i-funsel.$(FASLEXT)): Likewise.
+ (i-map.$(FASLEXT)): Likewise.
+ (i-eval.$(FASLEXT)): Likewise.
+ (i-coerfn.$(FASLEXT)): Likewise.
+ (i-coerce.$(FASLEXT)): Likewise.
+ (i-resolv.$(FASLEXT)): Likewise.
+ (i-analy.$(FASLEXT)): Likewise.
+ (i-code.$(FASLEXT)): Likewise.
+ (i-intern.$(FASLEXT)): Likewise.
+ (<<i-analy.clisp>>): Remove.
+ (<<i-code.clisp>>): Likewise.
+ (<<i-coerce.clisp>>): Likewise.
+ (<<i-coerfn.clisp>>): Likewise.
+ (<<i-eval.clisp>>): Likewise.
+ (<<i-funsel.clisp>>): Likewise.
+ (<<i-intern.clisp>>): Likewise.
+ (<<i-map.clisp>>): Likewise.
+ (<<i-resolv.clisp>>): Likewise.
+ (<<i-spec1.clisp>>): Likewise.
+ (<<i-spec2.clisp>>): Likewise.
+ (<<i-syscmd.clisp>>): Likewise.
+ (<<i-toplev.clisp>>): Likewise.
+ (<<i-util.clisp>>): Likewise.
+ * apply.boot (compFormWithModemap): Fix syntax.
+ * i-analy.boot.pamphlet: Push into package "BOOT".
+ * i-code.boot.pamphlet: Likewise.
+ * i-coerce.boot.pamphlet: Likewise.
+ * i-coerfn.boot.pamphlet: Likewise.
+ * i-eval.boot.pamphlet: Likewise.
+ * i-funsel.boot.pamphlet: Likewise.
+ * i-intern.boot.pamphlet: Likewise.
+ * i-map.boot.pamphlet: Likewise.
+ * i-resolv.boot.pamphlet: Likewise.
+ * i-spec1.boot.pamphlet: Likewise.
+ * i-spec2.boot.pamphlet: Likewise.
+ * i-syscmd.bot.pamphlet: Likewise.
+ * i-toplev.boot.pamphlet: Likewise.
+ * i-util.boot.pamphlet: Likewise.
+
2007-11-05 Gabriel Dos Reis <gdr@cs.tamu.edu>
* Makefile.pamphlet (compiler.$(FASLEXT)): New rule.
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index 1bc269bf..29cd5263 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -421,10 +421,52 @@ profile.$(FASLEXT): profile.boot macros.$(FASLEXT)
rulesets.$(FASLEXT): rulesets.boot vmlisp.$(FASLEXT)
$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+i-toplev.$(FASLEXT): i-toplev.boot i-analy.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-syscmd.$(FASLEXT): i-syscmd.boot i-object.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
i-output.$(FASLEXT): i-output.boot sys-macros.$(FASLEXT)
$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
-i-object.$(FASLEXT): i-object.boot sys-macros.$(FASLEXT)
+i-spec2.$(FASLEXT): i-spec2.boot i-spec1.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-spec1.$(FASLEXT): i-spec1.boot i-analy.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-funsel.$(FASLEXT): i-funsel.boot i-coerfn.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-map.$(FASLEXT): i-map.boot i-object.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-eval.$(FASLEXT): i-eval.boot i-analy.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-coerfn.$(FASLEXT): i-coerfn.boot i-coerce.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-coerce.$(FASLEXT): i-coerce.boot i-analy.$(FASLEXT) i-resolv.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-resolv.$(FASLEXT): i-resolv.boot i-object.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-analy.$(FASLEXT): i-analy.boot i-object.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-intern.$(FASLEXT): i-intern.boot i-object.$(FASLEXT) ptrees.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-code.$(FASLEXT): i-code.boot i-object.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-object.$(FASLEXT): i-object.boot g-util.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-util.$(FASLEXT): i-util.boot g-util.$(FASLEXT)
$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
format.$(FASLEXT): format.boot macros.$(FASLEXT)
@@ -691,66 +733,10 @@ clammed.clisp: clammed.boot
@ echo 226 making $@ from $<
@ echo '(old-boot::boot "clammed.boot")' | ${DEPSYS}
-i-analy.clisp: i-analy.boot
- @ echo 280 making $@ from $<
- @ echo '(old-boot::boot "i-analy.boot")' | ${DEPSYS}
-
-i-code.clisp: i-code.boot
- @ echo 283 making $@ from $<
- @ echo '(old-boot::boot "i-code.boot")' | ${DEPSYS}
-
-i-coerce.clisp: i-coerce.boot
- @ echo 286 making $@ from $<
- @ echo '(old-boot::boot "i-coerce.boot")' | ${DEPSYS}
-
-i-coerfn.clisp: i-coerfn.boot
- @ echo 289 making $@ from $<
- @ echo '(old-boot::boot "i-coerfn.boot")' | ${DEPSYS}
-
-i-eval.clisp: i-eval.boot
- @ echo 292 making $@ from $<
- @ echo '(old-boot::boot "i-eval.boot")' | ${DEPSYS}
-
-i-funsel.clisp: i-funsel.boot
- @ echo 295 making $@ from $<
- @ echo '(old-boot::boot "i-funsel.boot")' | ${DEPSYS}
-
bookvol5.lisp: $(srcdir)/bookvol5.pamphlet
@ echo 298 making $@ from $<
$(axiom_build_document) --tangle=Interpreter --output=$@ $<
-i-intern.clisp: i-intern.boot
- @ echo 301 making $@ from $<
- @ echo '(old-boot::boot "i-intern.boot")' | ${DEPSYS}
-
-i-map.clisp: i-map.boot
- @ echo 304 making $@ from $<
- @ echo '(old-boot::boot "i-map.boot")' | ${DEPSYS}
-
-i-resolv.clisp: i-resolv.boot
- @ echo 310 making $@ from $<
- @ echo '(old-boot::boot "i-resolv.boot")' | ${DEPSYS}
-
-i-spec1.clisp: i-spec1.boot
- @ echo 313 making $@ from $<
- @ echo '(old-boot::boot "i-spec1.boot")' | ${DEPSYS}
-
-i-spec2.clisp: i-spec2.boot
- @ echo 316 making $@ from i-spec2.boot
- @ echo '(old-boot::boot "i-spec2.boot")' | ${DEPSYS}
-
-i-syscmd.clisp: i-syscmd.boot
- @ echo 319 making $@ from $<
- @ echo '(old-boot::boot "i-syscmd.boot")' | ${DEPSYS}
-
-i-toplev.clisp: i-toplev.boot
- @ echo 322 making $@ from $<
- @ echo '(old-boot::boot "i-toplev.boot")' | ${DEPSYS}
-
-i-util.clisp: i-util.boot
- @ echo 325 making $@ from $<
- @ echo '(old-boot::boot "i-util.boot")' | ${DEPSYS}
-
nruncomp.clisp: nruncomp.boot
@ echo 353 making $@ from $<
@ echo '(old-boot::boot "nruncomp.boot")' | ${DEPSYS}
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet
index 94c1b16d..5689459a 100644
--- a/src/interp/Makefile.pamphlet
+++ b/src/interp/Makefile.pamphlet
@@ -832,54 +832,6 @@ clammed.clisp: clammed.boot
@ echo '(old-boot::boot "clammed.boot")' | ${DEPSYS}
@
-\subsection{i-analy.boot}
-
-<<i-analy.clisp>>=
-i-analy.clisp: i-analy.boot
- @ echo 280 making $@ from $<
- @ echo '(old-boot::boot "i-analy.boot")' | ${DEPSYS}
-@
-
-\subsection{i-code.boot}
-
-<<i-code.clisp>>=
-i-code.clisp: i-code.boot
- @ echo 283 making $@ from $<
- @ echo '(old-boot::boot "i-code.boot")' | ${DEPSYS}
-@
-
-\subsection{i-coerce.boot}
-
-<<i-coerce.clisp>>=
-i-coerce.clisp: i-coerce.boot
- @ echo 286 making $@ from $<
- @ echo '(old-boot::boot "i-coerce.boot")' | ${DEPSYS}
-@
-
-\subsection{i-coerfn.boot}
-
-<<i-coerfn.clisp>>=
-i-coerfn.clisp: i-coerfn.boot
- @ echo 289 making $@ from $<
- @ echo '(old-boot::boot "i-coerfn.boot")' | ${DEPSYS}
-@
-
-\subsection{i-eval.boot}
-
-<<i-eval.clisp>>=
-i-eval.clisp: i-eval.boot
- @ echo 292 making $@ from $<
- @ echo '(old-boot::boot "i-eval.boot")' | ${DEPSYS}
-@
-
-\subsection{i-funsel.boot}
-
-<<i-funsel.clisp>>=
-i-funsel.clisp: i-funsel.boot
- @ echo 295 making $@ from $<
- @ echo '(old-boot::boot "i-funsel.boot")' | ${DEPSYS}
-@
-
\subsection{bookvol5.lsp}
@@ -889,70 +841,6 @@ bookvol5.lisp: $(srcdir)/bookvol5.pamphlet
$(axiom_build_document) --tangle=Interpreter --output=$@ $<
@
-\subsection{i-intern.boot}
-
-<<i-intern.clisp>>=
-i-intern.clisp: i-intern.boot
- @ echo 301 making $@ from $<
- @ echo '(old-boot::boot "i-intern.boot")' | ${DEPSYS}
-@
-
-\subsection{i-map.boot}
-
-<<i-map.clisp>>=
-i-map.clisp: i-map.boot
- @ echo 304 making $@ from $<
- @ echo '(old-boot::boot "i-map.boot")' | ${DEPSYS}
-@
-
-\subsection{i-resolv.boot}
-
-<<i-resolv.clisp>>=
-i-resolv.clisp: i-resolv.boot
- @ echo 310 making $@ from $<
- @ echo '(old-boot::boot "i-resolv.boot")' | ${DEPSYS}
-@
-
-\subsection{i-spec1.boot}
-
-<<i-spec1.clisp>>=
-i-spec1.clisp: i-spec1.boot
- @ echo 313 making $@ from $<
- @ echo '(old-boot::boot "i-spec1.boot")' | ${DEPSYS}
-@
-
-\subsection{i-spec2.boot}
-
-<<i-spec2.clisp>>=
-i-spec2.clisp: i-spec2.boot
- @ echo 316 making $@ from i-spec2.boot
- @ echo '(old-boot::boot "i-spec2.boot")' | ${DEPSYS}
-@
-
-\subsection{i-syscmd.boot}
-
-<<i-syscmd.clisp>>=
-i-syscmd.clisp: i-syscmd.boot
- @ echo 319 making $@ from $<
- @ echo '(old-boot::boot "i-syscmd.boot")' | ${DEPSYS}
-@
-
-\subsection{i-toplev.boot}
-
-<<i-toplev.clisp>>=
-i-toplev.clisp: i-toplev.boot
- @ echo 322 making $@ from $<
- @ echo '(old-boot::boot "i-toplev.boot")' | ${DEPSYS}
-@
-
-\subsection{i-util.boot}
-
-<<i-util.clisp>>=
-i-util.clisp: i-util.boot
- @ echo 325 making $@ from $<
- @ echo '(old-boot::boot "i-util.boot")' | ${DEPSYS}
-@
-
\subsection{nruncomp.boot}
<<nruncomp.clisp>>=
@@ -1206,10 +1094,52 @@ profile.$(FASLEXT): profile.boot macros.$(FASLEXT)
rulesets.$(FASLEXT): rulesets.boot vmlisp.$(FASLEXT)
$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+i-toplev.$(FASLEXT): i-toplev.boot i-analy.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-syscmd.$(FASLEXT): i-syscmd.boot i-object.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
i-output.$(FASLEXT): i-output.boot sys-macros.$(FASLEXT)
$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
-i-object.$(FASLEXT): i-object.boot sys-macros.$(FASLEXT)
+i-spec2.$(FASLEXT): i-spec2.boot i-spec1.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-spec1.$(FASLEXT): i-spec1.boot i-analy.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-funsel.$(FASLEXT): i-funsel.boot i-coerfn.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-map.$(FASLEXT): i-map.boot i-object.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-eval.$(FASLEXT): i-eval.boot i-analy.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-coerfn.$(FASLEXT): i-coerfn.boot i-coerce.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-coerce.$(FASLEXT): i-coerce.boot i-analy.$(FASLEXT) i-resolv.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-resolv.$(FASLEXT): i-resolv.boot i-object.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-analy.$(FASLEXT): i-analy.boot i-object.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-intern.$(FASLEXT): i-intern.boot i-object.$(FASLEXT) ptrees.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-code.$(FASLEXT): i-code.boot i-object.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-object.$(FASLEXT): i-object.boot g-util.$(FASLEXT)
+ $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+i-util.$(FASLEXT): i-util.boot g-util.$(FASLEXT)
$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
format.$(FASLEXT): format.boot macros.$(FASLEXT)
@@ -1460,36 +1390,8 @@ boot-pkg.$(FASLEXT): boot-pkg.lisp
<<clammed.clisp>>
-<<i-analy.clisp>>
-
-<<i-code.clisp>>
-
-<<i-coerce.clisp>>
-
-<<i-coerfn.clisp>>
-
-<<i-eval.clisp>>
-
-<<i-funsel.clisp>>
-
<<bookvol5.lisp>>
-<<i-intern.clisp>>
-
-<<i-map.clisp>>
-
-<<i-resolv.clisp>>
-
-<<i-spec1.clisp>>
-
-<<i-spec2.clisp>>
-
-<<i-syscmd.clisp>>
-
-<<i-toplev.clisp>>
-
-<<i-util.clisp>>
-
<<nruncomp.clisp>>
<<nrunfast.clisp>>
diff --git a/src/interp/apply.boot b/src/interp/apply.boot
index 144f9cbf..c02e4646 100644
--- a/src/interp/apply.boot
+++ b/src/interp/apply.boot
@@ -1,5 +1,7 @@
-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
+-- Copyright (C) 2007, Gabriel Dos Reis.
+-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
@@ -116,8 +118,8 @@ compFormWithModemap(form is [op,:argl],m,e,modemap) ==
-- try to deal with new-style Unions where we know the conditions
op = "elt" and f is ['XLAM,:.] and IDENTP(z:=CAR argl) and
(c:=get(z,'condition,e)) and
- c is [['case,=z,c1]] and
- (c1 is ['_:,=(CADR argl),=m] or EQ(c1,CADR argl) ) =>
+ c is [["case",=z,c1]] and
+ (c1 is [":",=(CADR argl),=m] or EQ(c1,CADR argl) ) =>
-- first is a full tag, as placed by getInverseEnvironment
-- second is what getSuccessEnvironment will place there
["CDR",z]
diff --git a/src/interp/i-analy.boot.pamphlet b/src/interp/i-analy.boot.pamphlet
index ff751ace..b89b1df8 100644
--- a/src/interp/i-analy.boot.pamphlet
+++ b/src/interp/i-analy.boot.pamphlet
@@ -46,6 +46,9 @@
<<*>>=
<<license>>
+import '"i-object"
+)package "BOOT"
+
--% Interpreter Analysis Functions
getMinimalVariableTower(var,t) ==
diff --git a/src/interp/i-code.boot.pamphlet b/src/interp/i-code.boot.pamphlet
index c6551bb5..e014e55b 100644
--- a/src/interp/i-code.boot.pamphlet
+++ b/src/interp/i-code.boot.pamphlet
@@ -46,6 +46,9 @@
<<*>>=
<<license>>
+import '"i-object"
+)package "BOOT"
+
--% Interpreter Code Generation Routines
--Modified by JHD 9/9/93 to fix a problem with coerces inside
diff --git a/src/interp/i-coerce.boot.pamphlet b/src/interp/i-coerce.boot.pamphlet
index ff43961f..b488ce9d 100644
--- a/src/interp/i-coerce.boot.pamphlet
+++ b/src/interp/i-coerce.boot.pamphlet
@@ -100,6 +100,11 @@ getConstantFromDomain(form,domainForm) ==
@
<<*>>=
<<license>>
+
+import '"i-analy"
+import '"i-resolv"
+)package "BOOT"
+
--% Algebraic coercions using interactive code
algCoerceInteractive(p,source,target) ==
diff --git a/src/interp/i-coerfn.boot.pamphlet b/src/interp/i-coerfn.boot.pamphlet
index 16eb1850..24f14bf5 100644
--- a/src/interp/i-coerfn.boot.pamphlet
+++ b/src/interp/i-coerfn.boot.pamphlet
@@ -112,7 +112,10 @@ all these coercion functions have the following result:
<<*>>=
<<license>>
-SETANDFILEQ($coerceFailure,GENSYM())
+import '"i-coerce"
+)package "BOOT"
+
+$coerceFailure := GENSYM()
position1(x,y) ==
-- this is used where we want to assume a 1-based index
@@ -684,7 +687,7 @@ L2M(u,[.,D],[.,R]) ==
L2Record(l,[.,D],[.,:al]) ==
l = '_$fromCoerceable_$ => nil
#l = #al =>
- v:= [u for x in l for [":",.,D'] in al] where u ==
+ v:= [u for x in l for [":",.,D'] in al] where u() ==
T:= coerceInt(objNewWrap(x,D),D') or return 'failed
objValUnwrap(T)
v = 'failed => coercionFailure()
diff --git a/src/interp/i-eval.boot.pamphlet b/src/interp/i-eval.boot.pamphlet
index 3ec9050b..ed05090d 100644
--- a/src/interp/i-eval.boot.pamphlet
+++ b/src/interp/i-eval.boot.pamphlet
@@ -46,6 +46,9 @@
<<*>>=
<<license>>
+import '"i-analy"
+)package "BOOT"
+
--% Constructor Evaluation
$noEvalTypeMsg := nil
@@ -70,7 +73,7 @@ mkEvalable form ==
loadIfNecessary op
kind:= GETDATABASE(op,'CONSTRUCTORKIND)
cosig := GETDATABASE(op, 'COSIG) =>
- [op,:[val for x in argl for typeFlag in rest cosig]] where val ==
+ [op,:[val for x in argl for typeFlag in rest cosig]] where val() ==
typeFlag =>
kind = 'category => MKQ x
VECP x => MKQ x
@@ -178,7 +181,7 @@ evaluateType1 form ==
ml := replaceSharps(ml,form)
# argl ^= #ml => throwEvalTypeMsg("S2IE0003",[form,form])
for x in argl for m in ml for argnum in 1.. repeat
- typeList := [v,:typeList] where v ==
+ typeList := [v,:typeList] where v() ==
categoryForm?(m) =>
m := evaluateType MSUBSTQ(x,'_$,m)
evalCategory(x' := (evaluateType x), m) => x'
@@ -187,7 +190,7 @@ evaluateType1 form ==
GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'domain and
(tree := mkAtree x) and putTarget(tree,m) and ((bottomUp tree) is [m1]) =>
[zt,:zv]:= z1:= getAndEvalConstructorArgument tree
- (v:= coerceOrRetract(z1,m)) => objValUnwrap v
+ (v' := coerceOrRetract(z1,m)) => objValUnwrap v'
throwKeyedMsgCannotCoerceWithValue(zv,zt,m)
if x = $EmptyMode then x := $quadSymbol
throwEvalTypeMsg("S2IE0006",[makeOrdinal argnum,m,form])
diff --git a/src/interp/i-funsel.boot.pamphlet b/src/interp/i-funsel.boot.pamphlet
index 3ba29f64..5f5d4278 100644
--- a/src/interp/i-funsel.boot.pamphlet
+++ b/src/interp/i-funsel.boot.pamphlet
@@ -79,7 +79,10 @@ isPartialMode m ==
<<*>>=
<<license>>
-SETANDFILEQ($constructorExposureList, '(Boolean Integer String))
+import '"i-coerfn"
+)package "BOOT"
+
+$constructorExposureList := '(Boolean Integer String)
sayFunctionSelection(op,args,target,dc,func) ==
$abbreviateTypes : local := true
@@ -442,7 +445,7 @@ defaultTarget(opNode,op,nargs,args) ==
target
target
- op = '_/ =>
+ op = "/" =>
isEqualOrSubDomain(a1, $Integer) and isEqualOrSubDomain(a2, $Integer) =>
putTarget(opNode, target := $RationalNumber)
target
@@ -1094,39 +1097,12 @@ selectMmsGen(op,tar,args1,args2) ==
sayMSG ['%l,:bright '"Modemaps from Associated Packages"]
if haves then
- [havesExact,havesInexact] := exact?(haves,tar,args1) where
- exact?(mmS,tar,args) ==
- ex := inex := NIL
- for (mm := [sig,[mmC,:.],:.]) in mmS repeat
- [c,t,:a] := sig
- ok := true
- for pat in a for arg in args while ok repeat
- not CONTAINED(['isDomain,pat,arg],mmC) => ok := NIL
- ok => ex := CONS(mm,ex)
- inex := CONS(mm,inex)
- [ex,inex]
+ [havesExact,havesInexact] := exact?(haves,tar,args1)
if $reportBottomUpFlag then
for mm in APPEND(havesExact,havesInexact) for i in 1.. repeat
sayModemapWithNumber(mm,i)
if havesExact then
- mmS := matchMms(havesExact,op,tar,args1,args2) where
- matchMms(mmaps,op,tar,args1,args2) ==
- mmS := NIL
- for [sig,mmC] in mmaps repeat
- -- sig is [dc,result,:args]
- $Subst :=
- tar and not isPartialMode tar =>
- -- throw in the target if it is not the same as one
- -- of the arguments
- res := CADR sig
- member(res,CDDR sig) => NIL
- [[res,:tar]]
- NIL
- [c,t,:a] := sig
- if a then matchTypes(a,args1,args2)
- not EQ($Subst,'failed) =>
- mmS := nconc(evalMm(op,tar,sig,mmC),mmS)
- mmS
+ mmS := matchMms(havesExact,op,tar,args1,args2)
if mmS then
if $reportBottomUpFlag then
sayMSG '" found an exact match!"
@@ -1153,6 +1129,34 @@ selectMmsGen(op,tar,args1,args2) ==
mmS := matchMms(havesNInexact,op,tar,args1,args2)
else if $reportBottomUpFlag then sayMSG '" no modemaps"
mmS
+ where
+ exact?(mmS,tar,args) ==
+ ex := inex := NIL
+ for (mm := [sig,[mmC,:.],:.]) in mmS repeat
+ [c,t,:a] := sig
+ ok := true
+ for pat in a for arg in args while ok repeat
+ not CONTAINED(['isDomain,pat,arg],mmC) => ok := NIL
+ ok => ex := CONS(mm,ex)
+ inex := CONS(mm,inex)
+ [ex,inex]
+ matchMms(mmaps,op,tar,args1,args2) ==
+ mmS := NIL
+ for [sig,mmC] in mmaps repeat
+ -- sig is [dc,result,:args]
+ $Subst :=
+ tar and not isPartialMode tar =>
+ -- throw in the target if it is not the same as one
+ -- of the arguments
+ res := CADR sig
+ member(res,CDDR sig) => NIL
+ [[res,:tar]]
+ NIL
+ [c,t,:a] := sig
+ if a then matchTypes(a,args1,args2)
+ not EQ($Subst,'failed) =>
+ mmS := nconc(evalMm(op,tar,sig,mmC),mmS)
+ mmS
matchTypes(pm,args1,args2) ==
-- pm is a list of pattern variables, args1 a list of argument types,
@@ -1658,11 +1662,11 @@ hasAtt(dom,att,SL) ==
'failed
hasCatExpression(cond,SL) ==
- cond is ['OR,:l] =>
+ cond is ["OR",:l] =>
or/[(y:=hasCatExpression(x,SL)) ^= 'failed for x in l] => y
- cond is ['AND,:l] =>
+ cond is ["AND",:l] =>
and/[(SL:= hasCatExpression(x,SL)) ^= 'failed for x in l] => SL
- cond is ['has,a,b] => hasCate(a,b,SL)
+ cond is ["has",a,b] => hasCate(a,b,SL)
keyedSystemError("S2GE0016",
['"hasSig",'"unexpected condition for attribute"])
@@ -1670,8 +1674,8 @@ unifyStruct(s1,s2,SL) ==
-- tests for equality of s1 and s2 under substitutions SL and $Subst
-- the result is a substitution list or 'failed
s1=s2 => SL
- if s1 is ['_:,x,.] then s1:= x
- if s2 is ['_:,x,.] then s2:= x
+ if s1 is [":",x,.] then s1:= x
+ if s2 is [":",x,.] then s2:= x
if ^atom s1 and CAR s1 = '_# then s1:= LENGTH CADR s1
if ^atom s2 and CAR s2 = '_# then s2:= LENGTH CADR s2
s1=s2 => SL
diff --git a/src/interp/i-intern.boot.pamphlet b/src/interp/i-intern.boot.pamphlet
index 1ac1079b..aabd6a7e 100644
--- a/src/interp/i-intern.boot.pamphlet
+++ b/src/interp/i-intern.boot.pamphlet
@@ -9,30 +9,7 @@
\eject
\tableofcontents
\eject
-\begin{verbatim}
-Internal Interpreter Facilities
-
-Vectorized Attributed Trees
-
-The interpreter translates parse forms into vats for analysis.
-These contain a number of slots in each node for information.
-The leaves are now all vectors, though the leaves for basic types
-such as integers and strings used to just be the objects themselves.
-The vectors for the leaves with such constants now have the value
-of $immediateDataSymbol as their name. Their are undoubtably still
-some functions that still check whether a leaf is a constant. Note
-that if it is not a vector it is a subtree.
-
-attributed tree nodes have the following form:
-slot description
----- -----------------------------------------------------
- 0 operation name or literal
- 1 declared mode of variable
- 2 computed value of subtree from this node
- 3 modeset: list of single computed mode of subtree
- 4 prop list for extra things
-
-\end{verbatim}
+
\section{License}
<<license>>=
-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
@@ -70,16 +47,14 @@ slot description
<<*>>=
<<license>>
-SETANDFILEQ($useParserSrcPos, NIL)
-SETANDFILEQ($transferParserSrcPos, NIL)
+import '"i-object"
+import '"ptrees"
+)package "BOOT"
--- Making Trees
+$useParserSrcPos := NIL
+$transferParserSrcPos := NIL
-mkAtreeNode x ==
- -- maker of attrib tree node
- v := MAKE_-VEC 5
- v.0 := x
- v
+-- Making Trees
mkAtree x ==
-- maker of attrib tree from parser form
@@ -111,14 +86,14 @@ transferSrcPosInfo(pf, atree) ==
mkAtreeExpandMacros x ==
-- handle macro expansion. if the macros have args we require that
-- we match the correct number of args
- if x isnt ['MDEF,:.] and x isnt ['DEF,['macro,:.],:.] then
+ if x isnt ["MDEF",:.] and x isnt ["DEF",["macro",:.],:.] then
atom x and (m := isInterpMacro x) =>
[args,:body] := m
- args => 'doNothing
+ args => "doNothing"
x := body
x is [op,:argl] =>
- op = 'QUOTE => 'doNothing
- op = 'where and argl is [before,after] =>
+ op = "QUOTE" => "doNothing"
+ op = "where" and argl is [before,after] =>
-- in a where clause, what follows "where" (the "after" parm
-- above) might be a local macro, so do not expand the "before"
-- part yet
@@ -160,23 +135,23 @@ mkAtree1 x ==
mkAtree2(x,op,argl) ==
nargl := #argl
- (op= '_-) and (nargl = 1) and (INTEGERP CAR argl) =>
+ (op= "-") and (nargl = 1) and (INTEGERP CAR argl) =>
mkAtree1(MINUS CAR argl)
- op='_: and argl is [y,z] => [mkAtreeNode 'Declare,:argl]
- op='COLLECT => [mkAtreeNode op,:transformCollect argl]
- op= 'break =>
+ op=":" and argl is [y,z] => [mkAtreeNode "Declare",:argl]
+ op="COLLECT" => [mkAtreeNode op,:transformCollect argl]
+ op= "break" =>
argl is [.,val] =>
if val = '$NoValue then val := '(void)
[mkAtreeNode op,mkAtree1 val]
[mkAtreeNode op,mkAtree1 '(void)]
- op= 'return =>
+ op= "return" =>
argl is [val] =>
if val = '$NoValue then val := '(void)
[mkAtreeNode op,mkAtree1 val]
[mkAtreeNode op,mkAtree1 '(void)]
- op='exit => mkAtree1 CADR argl
- op = 'QUOTE => [mkAtreeNode op,:argl]
- op='SEGMENT =>
+ op="exit" => mkAtree1 CADR argl
+ op = "QUOTE" => [mkAtreeNode op,:argl]
+ op="SEGMENT" =>
argl is [a] => [mkAtreeNode op, mkAtree1 a]
z :=
null argl.1 => nil
@@ -184,9 +159,9 @@ mkAtree2(x,op,argl) ==
[mkAtreeNode op, mkAtree1 argl.0,z]
op in '(pretend is isnt) =>
[mkAtreeNode op,mkAtree1 first argl,:rest argl]
- op = '_:_: =>
- [mkAtreeNode 'COERCE,mkAtree1 first argl,CADR argl]
- x is ['_@, expr, type] =>
+ op = "::" =>
+ [mkAtreeNode "COERCE",mkAtree1 first argl,CADR argl]
+ x is ["@", expr, type] =>
t := evaluateType unabbrev type
t = '(DoubleFloat) and expr is [['_$elt, '(Float), 'float], :args] =>
mkAtree1 [['_$elt, '(DoubleFloat), 'float], :args]
@@ -199,18 +174,18 @@ mkAtree2(x,op,argl) ==
typeIsASmallInteger(t) and INTEGERP expr =>
mkAtree1 ["::", expr, t]
[mkAtreeNode 'TARGET,mkAtree1 expr, type]
- (op='case) and (nargl = 2) =>
- [mkAtreeNode 'case,mkAtree1 first argl,unabbrev CADR argl]
- op='REPEAT => [mkAtreeNode op,:transformREPEAT argl]
- op='LET and argl is [['construct,:.],rhs] =>
- [mkAtreeNode 'LET,first argl,mkAtree1 rhs]
- op='LET and argl is [['_:,a,.],rhs] =>
- mkAtree1 ['SEQ,first argl,['LET,a,rhs]]
+ (op="case") and (nargl = 2) =>
+ [mkAtreeNode "case",mkAtree1 first argl,unabbrev CADR argl]
+ op="REPEAT" => [mkAtreeNode op,:transformREPEAT argl]
+ op="LET" and argl is [['construct,:.],rhs] =>
+ [mkAtreeNode "LET",first argl,mkAtree1 rhs]
+ op="LET" and argl is [[":",a,.],rhs] =>
+ mkAtree1 ["SEQ",first argl,["LET",a,rhs]]
op is ['_$elt,D,op1] =>
- op1 is '_= =>
+ op1 is "=" =>
a' := [mkAtreeNode '_=,:[mkAtree1 arg for arg in argl]]
- [mkAtreeNode 'Dollar,D,a']
- [mkAtreeNode 'Dollar,D,mkAtree1 [op1,:argl]]
+ [mkAtreeNode "Dollar",D,a']
+ [mkAtreeNode "Dollar",D,mkAtree1 [op1,:argl]]
op='_$elt =>
argl is [D,a] =>
INTEGERP a =>
@@ -222,20 +197,20 @@ mkAtree2(x,op,argl) ==
putValue(v,objNewWrap(a, t))
v
mkAtree1 ["*",a,[['_$elt,D,'One]]]
- [mkAtreeNode 'Dollar,D,mkAtree1 a]
+ [mkAtreeNode "Dollar",D,mkAtree1 a]
keyedSystemError("S2II0003",['"$",argl,
'"not qualifying an operator"])
mkAtree3(x,op,argl)
mkAtree3(x,op,argl) ==
- op='REDUCE and argl is [op1,axis,body] =>
+ op="REDUCE" and argl is [op1,axis,body] =>
[mkAtreeNode op,axis,mkAtree1 op1,mkAtree1 body]
- op='has => [mkAtreeNode op, :argl]
- op='_| => [mkAtreeNode 'AlgExtension,:[mkAtree1 arg for arg in argl]]
- op='_= => [mkAtreeNode 'equation,:[mkAtree1 arg for arg in argl]]
- op='not and argl is [["=",lhs,rhs]] =>
- [mkAtreeNode 'not,[mkAtreeNode "=",mkAtree1 lhs,mkAtree1 rhs]]
- op='in and argl is [var ,['SEGMENT,lb,ul]] =>
+ op="has" => [mkAtreeNode op, :argl]
+ op="|" => [mkAtreeNode "AlgExtension",:[mkAtree1 arg for arg in argl]]
+ op="=" => [mkAtreeNode "equation",:[mkAtree1 arg for arg in argl]]
+ op="not" and argl is [["=",lhs,rhs]] =>
+ [mkAtreeNode "not",[mkAtreeNode "=",mkAtree1 lhs,mkAtree1 rhs]]
+ op="in" and argl is [var ,["SEGMENT",lb,ul]] =>
upTest:=
null ul => NIL
mkLessOrEqual(var,ul)
@@ -244,13 +219,13 @@ mkAtree3(x,op,argl) ==
ul => ['and,lowTest,upTest]
lowTest
mkAtree1 z
- x is ['IF,p,'noBranch,a] => mkAtree1 ['IF,['not,p],a,'noBranch]
- x is ['RULEDEF,:.] => [mkAtreeNode 'RULEDEF,:CDR x]
- x is ['MDEF,sym,junk1,junk2,val] =>
+ x is ["IF",p,"noBranch",a] => mkAtree1 ["IF",["not",p],a,"noBranch"]
+ x is ["RULEDEF",:.] => [mkAtreeNode "RULEDEF",:CDR x]
+ x is ["MDEF",sym,junk1,junk2,val] =>
-- new macros look like macro f == or macro f(x) ===
-- so transform into that format
- mkAtree1 ['DEF,['macro,sym],junk1,junk2,val]
- x is ["~=",a,b] => mkAtree1 ['not,["=",a,b]]
+ mkAtree1 ["DEF",["macro",sym],junk1,junk2,val]
+ x is ["~=",a,b] => mkAtree1 ["not",["=",a,b]]
x is ["+->",funargs,funbody] =>
if funbody is [":",body,type] then
types := [type]
@@ -258,7 +233,7 @@ mkAtree3(x,op,argl) ==
else types := [NIL]
v := collectDefTypesAndPreds funargs
types := [:types,:v.1]
- [mkAtreeNode 'ADEF,[v.0,types,[NIL for a in types],funbody],
+ [mkAtreeNode "ADEF",[v.0,types,[NIL for a in types],funbody],
if v.2 then v.2 else true, false]
x is ['ADEF,arg,:r] =>
r := mkAtreeValueOf r
@@ -269,19 +244,14 @@ mkAtree3(x,op,argl) ==
null rest arg => collectDefTypesAndPreds first arg
collectDefTypesAndPreds arg
[types,:r'] := r
- at := [fn(x,y) for x in rest types for y in v.1] where
- fn(a,b) ==
- a and b =>
- if a = b then a
- else throwMessage '" double declaration of parameter"
- a or b
+ at := [fn(x,y) for x in rest types for y in v.1]
r := [[first types,:at],:r']
- [mkAtreeNode 'ADEF,[v.0,:r],if v.2 then v.2 else true,false]
- x is ['where,before,after] =>
- [mkAtreeNode 'where,before,mkAtree1 after]
- x is ['DEF,['macro,form],.,.,body] =>
- [mkAtreeNode 'MDEF,form,body]
- x is ['DEF,a,:r] =>
+ [mkAtreeNode "ADEF",[v.0,:r],if v.2 then v.2 else true,false]
+ x is ["where",before,after] =>
+ [mkAtreeNode "where",before,mkAtree1 after]
+ x is ["DEF",["macro",form],.,.,body] =>
+ [mkAtreeNode "MDEF",form,body]
+ x is ["DEF",a,:r] =>
r := mkAtreeValueOf r
a is [op,:arg] =>
v :=
@@ -313,6 +283,12 @@ mkAtree3(x,op,argl) ==
atom op => mkAtreeNode op
mkAtree1 op
[z,:[mkAtree1 y for y in argl]]
+ where
+ fn(a,b) ==
+ a and b =>
+ if a = b then a
+ else throwMessage '" double declaration of parameter"
+ a or b
collectDefTypesAndPreds args ==
-- given an arglist to a DEF-like form, this function returns
@@ -329,11 +305,7 @@ collectDefTypesAndPreds args ==
types := [type]
var is ["|",var',p] =>
vars := [var']
- pred := addPred(pred,p) where
- addPred(old,new) ==
- null new => old
- null old => new
- ['and,old,new]
+ pred := addPred(pred,p)
vars := [var]
args is ["|",var,p] =>
pred := addPred(pred,p)
@@ -356,211 +328,27 @@ collectDefTypesAndPreds args ==
types := [NIL]
vars := [args]
VECTOR(vars,types,pred)
+ where
+ addPred(old,new) ==
+ null new => old
+ null old => new
+ ['and,old,new]
mkAtreeValueOf l ==
-- scans for ['valueOf,atom]
- not CONTAINED('valueOf,l) => l
+ not CONTAINED("valueOf",l) => l
mkAtreeValueOf1 l
mkAtreeValueOf1 l ==
null l or atom l or null rest l => l
- l is ['valueOf,u] and IDENTP u =>
+ l is ["valueOf",u] and IDENTP u =>
v := mkAtreeNode $immediateDataSymbol
- putValue(v,get(u,'value,$InteractiveFrame) or
+ putValue(v,get(u,"value",$InteractiveFrame) or
objNewWrap(u,['Variable,u]))
v
[mkAtreeValueOf1 x for x in l]
-mkLessOrEqual(lhs,rhs) == ['not,['_<,rhs,lhs]]
-
-emptyAtree expr ==
- -- remove mode, value, and misc. info from attrib tree
- VECP expr =>
- $immediateDataSymbol = expr.0 => nil
- expr.1:= NIL
- expr.2:= NIL
- expr.3:= NIL
- -- kill proplist too?
- atom expr => nil
- for e in expr repeat emptyAtree e
-
-unVectorize body ==
- -- transforms from an atree back into a tree
- VECP body =>
- name := getUnname body
- name ^= $immediateDataSymbol => name
- objValUnwrap getValue body
- atom body => body
- body is [op,:argl] =>
- newOp:=unVectorize op
- if newOp = 'SUCHTHAT then newOp := '_|
- if newOp = 'COERCE then newOp := '_:_:
- if newOp = 'Dollar then newOp := "$elt"
- [newOp,:unVectorize argl]
- systemErrorHere '"unVectorize"
-
-
--- Stuffing and Getting Info
-
-putAtree(x,prop,val) ==
- x is [op,:.] =>
- -- only willing to add property if op is a vector
- -- otherwise will be pushing to deeply into calling structure
- if VECP op then putAtree(op,prop,val)
- x
- null VECP x => x -- just ignore it
- n := QLASSQ(prop,'((mode . 1) (value . 2) (modeSet . 3)))
- => x.n := val
- x.4 := insertShortAlist(prop,val,x.4)
- x
-
-getAtree(x,prop) ==
- x is [op,:.] =>
- -- only willing to get property if op is a vector
- -- otherwise will be pushing to deeply into calling structure
- VECP op => getAtree(op,prop)
- NIL
- null VECP x => NIL -- just ignore it
- n:= QLASSQ(prop,'((mode . 1) (value . 2) (modeSet . 3)))
- => x.n
- QLASSQ(prop,x.4)
-
-putTarget(x, targ) ==
- -- want to put nil modes perhaps to clear old target
- if targ = $EmptyMode then targ := nil
- putAtree(x,'target,targ)
-
-getTarget(x) == getAtree(x,'target)
-
-insertShortAlist(prop,val,al) ==
- pair := QASSQ(prop,al) =>
- RPLACD(pair,val)
- al
- [[prop,:val],:al]
-
-transferPropsToNode(x,t) ==
- propList := getProplist(x,$env)
- QLASSQ('Led,propList) or QLASSQ('Nud,propList) => nil
- node :=
- VECP t => t
- first t
- for prop in '(mode localModemap value name generatedCode)
- repeat transfer(x,node,prop)
- where
- transfer(x,node,prop) ==
- u := get(x,prop,$env) => putAtree(node,prop,u)
- (not (x in $localVars)) and (u := get(x,prop,$e)) =>
- putAtree(node,prop,u)
- if not getMode(t) and (am := get(x,'automode,$env)) then
- putModeSet(t,[am])
- putMode(t,am)
- t
-
-isLeaf x == atom x --may be a number or a vector
-
-getMode x ==
- x is [op,:.] => getMode op
- VECP x => x.1
- m := getBasicMode x => m
- keyedSystemError("S2II0001",[x])
-
-putMode(x,y) ==
- x is [op,:.] => putMode(op,y)
- null VECP x => keyedSystemError("S2II0001",[x])
- x.1 := y
-
-getValue x ==
- VECP x => x.2
- atom x =>
- t := getBasicObject x => t
- keyedSystemError("S2II0001",[x])
- getValue first x
-
-putValue(x,y) ==
- x is [op,:.] => putValue(op,y)
- null VECP x => keyedSystemError("S2II0001",[x])
- x.2 := y
-
-putValueValue(vec,val) ==
- putValue(vec,val)
- vec
-
-getUnnameIfCan x ==
- VECP x => x.0
- x is [op,:.] => getUnnameIfCan op
- atom x => x
- nil
-
-getUnname x ==
- x is [op,:.] => getUnname op
- getUnname1 x
-
-getUnname1 x ==
- VECP x => x.0
- null atom x => keyedSystemError("S2II0001",[x])
- x
-
-computedMode t ==
- getModeSet t is [m] => m
- keyedSystemError("S2GE0016",['"computedMode",'"non-singleton modeset"])
-
-putModeSet(x,y) ==
- x is [op,:.] => putModeSet(op,y)
- not VECP x => keyedSystemError("S2II0001",[x])
- x.3 := y
- y
-
-getModeOrFirstModeSetIfThere x ==
- x is [op,:.] => getModeOrFirstModeSetIfThere op
- VECP x =>
- m := x.1 => m
- val := x.2 => objMode val
- y := x.aModeSet =>
- (y = [$EmptyMode]) and ((m := getMode x) is ['Mapping,:.]) => m
- first y
- NIL
- m := getBasicMode x => m
- NIL
-
-getModeSet x ==
- x and PAIRP x => getModeSet first x
- VECP x =>
- y:= x.aModeSet =>
- (y = [$EmptyMode]) and ((m := getMode x) is ['Mapping,:.]) =>
- [m]
- y
- keyedSystemError("S2GE0016",['"getModeSet",'"no mode set"])
- m:= getBasicMode x => [m]
- null atom x => getModeSet first x
- keyedSystemError("S2GE0016",['"getModeSet",
- '"not an attributed tree"])
-
-getModeSetUseSubdomain x ==
- x and PAIRP x => getModeSetUseSubdomain first x
- VECP(x) =>
- -- don't play subdomain games with retracted args
- getAtree(x,'retracted) => getModeSet x
- y := x.aModeSet =>
- (y = [$EmptyMode]) and ((m := getMode x) is ['Mapping,:.]) =>
- [m]
- val := getValue x
- (x.0 = $immediateDataSymbol) and (y = [$Integer]) =>
- val := objValUnwrap val
- m := getBasicMode0(val,true)
- x.2 := objNewWrap(val,m)
- x.aModeSet := [m]
- [m]
- null val => y
- isEqualOrSubDomain(objMode(val),$Integer) and
- INTEGERP(f := objValUnwrap val) =>
- [getBasicMode0(f,true)]
- y
- keyedSystemError("S2GE0016",
- ['"getModeSetUseSubomain",'"no mode set"])
- m := getBasicMode0(x,true) => [m]
- null atom x => getModeSetUseSubdomain first x
- keyedSystemError("S2GE0016",
- ['"getModeSetUseSubomain",'"not an attributed tree"])
+mkLessOrEqual(lhs,rhs) == ["not",["<",rhs,lhs]]
atree2EvaluatedTree x == atree2Tree1(x,true)
@@ -682,44 +470,6 @@ addIntSymTabBinding(var,proplist,e is [[curContour,:.],:.]) ==
e
---% Source and position information
-
--- In the following, src is a string containing an original input line,
--- line is the line number of the string within the source file,
--- and col is the index within src of the start of the form represented
--- by x. x is a VAT.
-
-putSrcPos(x, file, src, line, col) ==
- putAtree(x, 'srcAndPos, srcPos_New(file, src, line, col))
-
-getSrcPos(x) == getAtree(x, 'srcAndPos)
-
-srcPosNew(file, src, line, col) == LIST2VEC [file, src, line, col]
-
-srcPosFile(sp) ==
- if sp then sp.0 else nil
-
-srcPosSource(sp) ==
- if sp then sp.1 else nil
-
-srcPosLine(sp) ==
- if sp then sp.2 else nil
-
-srcPosColumn(sp) ==
- if sp then sp.3 else nil
-
-srcPosDisplay(sp) ==
- null sp => nil
- s := STRCONC('"_"", srcPosFile sp, '"_", line ",
- STRINGIMAGE srcPosLine sp, '": ")
- sayBrightly [s, srcPosSource sp]
- col := srcPosColumn sp
- dots :=
- col = 0 => '""
- fillerSpaces(col, '".")
- sayBrightly [fillerSpaces(#s, '" "), dots, '"^"]
- true
-
@
\eject
\begin{thebibliography}{99}
diff --git a/src/interp/i-map.boot.pamphlet b/src/interp/i-map.boot.pamphlet
index b66f02b9..c64a4318 100644
--- a/src/interp/i-map.boot.pamphlet
+++ b/src/interp/i-map.boot.pamphlet
@@ -50,18 +50,21 @@
<<*>>=
<<license>>
+import '"i-object"
+)package "BOOT"
+
--% User Function Creation and Analysis Code
-SETANDFILEQ($mapTarget,nil)
-SETANDFILEQ($mapReturnTypes,nil)
-SETANDFILEQ($mapName,'noMapName)
-SETANDFILEQ($mapThrowCount, 0) -- times a "return" occurs in map
-SETANDFILEQ($compilingMap, NIL)
-SETANDFILEQ($definingMap, NIL)
+$mapTarget := nil
+$mapReturnTypes := nil
+$mapName := 'noMapName
+$mapThrowCount := 0 -- times a "return" occurs in map
+$compilingMap := NIL
+$definingMap := NIL
--% Generating internal names for functions
-SETANDFILEQ($specialMapNameSuffix, NIL)
+$specialMapNameSuffix := NIL
makeInternalMapName(userName,numArgs,numMms,extraPart) ==
name := CONCAT('"*",STRINGIMAGE numArgs,'";",
@@ -183,7 +186,7 @@ addMap(lhs,rhs,pred) ==
for x in argl for s in $FormalMapVariableList]
argList:=
[fn for x in formalArgList] where
- fn ==
+ fn() ==
if x is ["SUCHTHAT",s,p] then (predList:= [p,:predList]; x:= s)
x
mkMapAlias(op,argl)
@@ -223,7 +226,7 @@ augmentMap(op,args,pred,body,oldMap) ==
deleteMap(op,pattern,map) ==
map is ["MAP",:tail] =>
- newMap:= ['MAP,:[x for x in tail | w]] where w ==
+ newMap:= ['MAP,:[x for x in tail | w]] where w() ==
x is [=pattern,:replacement] => sayDroppingFunctions(op,[x])
true
null rest newMap => nil
@@ -244,7 +247,7 @@ getUserIdentifiersIn body ==
body is [op,:l] =>
argIdList:= "append"/[getUserIdentifiersIn y for y in l]
bodyIdList :=
- CONSP op or not (GET(op,'Nud) or GET(op,'Led) or GET(op,'up))=>
+ CONSP op or not (GETL(op,'Nud) or GETL(op,'Led) or GETL(op,'up))=>
NCONC(getUserIdentifiersIn op, argIdList)
argIdList
REMDUP bodyIdList
@@ -384,7 +387,7 @@ clearDep1(x,toDoList,doneList,depList) ==
a:= ASSQ(x,depList)
a =>
depList:= delete(a,depList)
- toDoList:= setUnion(toDoList,
+ toDoList:= union(toDoList,
setDifference(CDR a,doneList))
toDoList is [a,:res] => clearDep1(a,res,newDone,depList)
'done
@@ -551,7 +554,7 @@ mkInterpFun(op,opName,argTypes) ==
getMode op isnt ['Mapping,:sig] => nil
parms := [var for type in argTypes for var in $FormalMapVariableList]
arglCode := ['LIST,:[argCode for type in argTypes
- for argName in parms]] where argCode ==
+ for argName in parms]] where argCode() ==
['putValueValue,['mkAtreeNode,MKQ argName],
objNewCode(['wrap,argName],type)]
funName := GENSYM()
@@ -567,7 +570,7 @@ rewriteMap(op,opName,argl) ==
get(opName,'mode,$e) isnt ['Mapping,:sig] =>
compFailure ['" Cannot compile map:",:bright opName]
arglCode := ['LIST,:[argCode for arg in argl for argName in
- $FormalMapVariableList]] where argCode ==
+ $FormalMapVariableList]] where argCode() ==
['putValueValue,['mkAtreeNode,MKQ argName],
objNewCode(['wrap,wrapped2Quote(objVal getValue arg)],
getMode arg)]
diff --git a/src/interp/i-object.boot b/src/interp/i-object.boot
index 0543e466..8443c55e 100644
--- a/src/interp/i-object.boot
+++ b/src/interp/i-object.boot
@@ -31,7 +31,7 @@
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-import '"sys-macros"
+import '"g-util"
)package "BOOT"
--% Functions on interpreter objects
@@ -69,7 +69,7 @@ objCodeMode obj == CADR obj
wrap x ==
isWrapped x => x
- ['WRAPPED,:x]
+ ["WRAPPED",:x]
isWrapped x == x is ['WRAPPED,:.] or NUMBERP x or FLOATP x or CVECP x
@@ -83,7 +83,7 @@ wrapped2Quote x ==
x
quote2Wrapped x ==
- x is ['QUOTE,y] => wrap y
+ x is ["QUOTE",y] => wrap y
x
removeQuote x ==
@@ -142,3 +142,270 @@ getBasicObject x ==
FLOATP x => objNewWrap(x,$DoubleFloat)
NIL
+
+--%% Vectorized Attributed Trees
+
+--% The interpreter translates parse forms into vats for analysis.
+--% These contain a number of slots in each node for information.
+--% The leaves are now all vectors, though the leaves for basic types
+--% such as integers and strings used to just be the objects themselves.
+--% The vectors for the leaves with such constants now have the value
+--% of $immediateDataSymbol as their name. Their are undoubtably still
+--% some functions that still check whether a leaf is a constant. Note
+--% that if it is not a vector it is a subtree.
+
+--% attributed tree nodes have the following form:
+--% slot description
+--% ---- -----------------------------------------------------
+--% 0 operation name or literal
+--% 1 declared mode of variable
+--% 2 computed value of subtree from this node
+--% 3 modeset: list of single computed mode of subtree
+--% 4 prop list for extra things
+
+
+++ create a leaf VAT node.
+mkAtreeNode x ==
+ -- maker of attrib tree node
+ v := MAKE_-VEC 5
+ v.0 := x
+ v
+
+++ remove mode, value, and misc. info from attrib tree
+emptyAtree expr ==
+ VECP expr =>
+ $immediateDataSymbol = expr.0 => nil
+ expr.1:= NIL
+ expr.2:= NIL
+ expr.3:= NIL
+ -- kill proplist too?
+ atom expr => nil
+ for e in expr repeat emptyAtree e
+
+
+++ returns true if x is a leaf VAT object.
+isLeaf x ==
+ atom x --may be a number or a vector
+
+++ returns the mode of the VAT node x.
+getMode x ==
+ x is [op,:.] => getMode op
+ VECP x => x.1
+ m := getBasicMode x => m
+ keyedSystemError("S2II0001",[x])
+
+++ sets the mode for the VAT node x to y.
+putMode(x,y) ==
+ x is [op,:.] => putMode(op,y)
+ null VECP x => keyedSystemError("S2II0001",[x])
+ x.1 := y
+
+++ returns an interpreter object that represents the value of node x.
+++ Note that an interpreter object is a pair of mode and value.
+getValue x ==
+ VECP x => x.2
+ atom x =>
+ t := getBasicObject x => t
+ keyedSystemError("S2II0001",[x])
+ getValue first x
+
+++ sets the value of VAT node x to interpreter object y.
+putValue(x,y) ==
+ x is [op,:.] => putValue(op,y)
+ null VECP x => keyedSystemError("S2II0001",[x])
+ x.2 := y
+
+++ same as putValue(vec, val), except that vec is returned instead of val.
+putValueValue(vec,val) ==
+ putValue(vec,val)
+ vec
+
+++ Returns the node class of x, if possible; otherwise nil.
+getUnnameIfCan x ==
+ VECP x => x.0
+ x is [op,:.] => getUnnameIfCan op
+ atom x => x
+ nil
+
+++ Returns the node class of x; otherwise raise an error.
+getUnname x ==
+ x is [op,:.] => getUnname op
+ getUnname1 x
+
+++ Subroutine of getUnname.
+getUnname1 x ==
+ VECP x => x.0
+ null atom x => keyedSystemError("S2II0001",[x])
+ x
+
+++ returns the mode-set of VAT node x.
+getModeSet x ==
+ x and PAIRP x => getModeSet first x
+ VECP x =>
+ y:= x.aModeSet =>
+ (y = [$EmptyMode]) and ((m := getMode x) is ['Mapping,:.]) =>
+ [m]
+ y
+ keyedSystemError("S2GE0016",['"getModeSet",'"no mode set"])
+ m:= getBasicMode x => [m]
+ not atom x => getModeSet first x
+ keyedSystemError("S2GE0016",['"getModeSet",
+ '"not an attributed tree"])
+
+++ Sets the mode-set of VAT node x to y.
+putModeSet(x,y) ==
+ x is [op,:.] => putModeSet(op,y)
+ not VECP x => keyedSystemError("S2II0001",[x])
+ x.3 := y
+ y
+
+getModeOrFirstModeSetIfThere x ==
+ x is [op,:.] => getModeOrFirstModeSetIfThere op
+ VECP x =>
+ m := x.1 => m
+ val := x.2 => objMode val
+ y := x.aModeSet =>
+ (y = [$EmptyMode]) and ((m := getMode x) is ['Mapping,:.]) => m
+ first y
+ NIL
+ m := getBasicMode x => m
+ NIL
+
+getModeSetUseSubdomain x ==
+ x and PAIRP x => getModeSetUseSubdomain first x
+ VECP(x) =>
+ -- don't play subdomain games with retracted args
+ getAtree(x,'retracted) => getModeSet x
+ y := x.aModeSet =>
+ (y = [$EmptyMode]) and ((m := getMode x) is ['Mapping,:.]) =>
+ [m]
+ val := getValue x
+ (x.0 = $immediateDataSymbol) and (y = [$Integer]) =>
+ val := objValUnwrap val
+ m := getBasicMode0(val,true)
+ x.2 := objNewWrap(val,m)
+ x.aModeSet := [m]
+ [m]
+ null val => y
+ isEqualOrSubDomain(objMode(val),$Integer) and
+ INTEGERP(f := objValUnwrap val) =>
+ [getBasicMode0(f,true)]
+ y
+ keyedSystemError("S2GE0016",
+ ['"getModeSetUseSubomain",'"no mode set"])
+ m := getBasicMode0(x,true) => [m]
+ null atom x => getModeSetUseSubdomain first x
+ keyedSystemError("S2GE0016",
+ ['"getModeSetUseSubomain",'"not an attributed tree"])
+
+
+computedMode t ==
+ getModeSet t is [m] => m
+ keyedSystemError("S2GE0016",['"computedMode",'"non-singleton modeset"])
+
+--% Other VAT properties
+
+insertShortAlist(prop,val,al) ==
+ pair := QASSQ(prop,al) =>
+ RPLACD(pair,val)
+ al
+ [[prop,:val],:al]
+
+putAtree(x,prop,val) ==
+ x is [op,:.] =>
+ -- only willing to add property if op is a vector
+ -- otherwise will be pushing to deeply into calling structure
+ if VECP op then putAtree(op,prop,val)
+ x
+ null VECP x => x -- just ignore it
+ n := QLASSQ(prop,'((mode . 1) (value . 2) (modeSet . 3)))
+ => x.n := val
+ x.4 := insertShortAlist(prop,val,x.4)
+ x
+
+getAtree(x,prop) ==
+ x is [op,:.] =>
+ -- only willing to get property if op is a vector
+ -- otherwise will be pushing to deeply into calling structure
+ VECP op => getAtree(op,prop)
+ NIL
+ null VECP x => NIL -- just ignore it
+ n:= QLASSQ(prop,'((mode . 1) (value . 2) (modeSet . 3)))
+ => x.n
+ QLASSQ(prop,x.4)
+
+putTarget(x, targ) ==
+ -- want to put nil modes perhaps to clear old target
+ if targ = $EmptyMode then targ := nil
+ putAtree(x,'target,targ)
+
+getTarget(x) ==
+ getAtree(x,'target)
+
+--% Source and position information
+
+-- In the following, src is a string containing an original input line,
+-- line is the line number of the string within the source file,
+-- and col is the index within src of the start of the form represented
+-- by x. x is a VAT.
+
+++ returns source position information for VAT node x.
+getSrcPos(x) ==
+ getAtree(x, 'srcAndPos)
+
+++ sets the source location information for VAT node x.
+putSrcPos(x, file, src, line, col) ==
+ putAtree(x, 'srcAndPos, srcPos_New(file, src, line, col))
+
+srcPosNew(file, src, line, col) ==
+ LIST2VEC [file, src, line, col]
+
+++ returns the name of source file for source location `sp'.
+srcPosFile(sp) ==
+ if sp then sp.0 else nil
+
+++ returns the input source string for source location `sp'.
+srcPosSource(sp) ==
+ if sp then sp.1 else nil
+
+++ returns the line number for source location `sp'.
+srcPosLine(sp) ==
+ if sp then sp.2 else nil
+
+++ returns the column number for source location `sp'.
+srcPosColumn(sp) ==
+ if sp then sp.3 else nil
+
+srcPosDisplay(sp) ==
+ null sp => nil
+ s := STRCONC('"_"", srcPosFile sp, '"_", line ",
+ STRINGIMAGE srcPosLine sp, '": ")
+ sayBrightly [s, srcPosSource sp]
+ col := srcPosColumn sp
+ dots :=
+ col = 0 => '""
+ fillerSpaces(col, '".")
+ sayBrightly [fillerSpaces(#s, '" "), dots, '"^"]
+ true
+
+
+--% Transfer of VAT properties.
+
+
+transferPropsToNode(x,t) ==
+ propList := getProplist(x,$env)
+ QLASSQ('Led,propList) or QLASSQ('Nud,propList) => nil
+ node :=
+ VECP t => t
+ first t
+ for prop in '(mode localModemap value name generatedCode)
+ repeat transfer(x,node,prop)
+ where
+ transfer(x,node,prop) ==
+ u := get(x,prop,$env) => putAtree(node,prop,u)
+ (not (x in $localVars)) and (u := get(x,prop,$e)) =>
+ putAtree(node,prop,u)
+ if not getMode(t) and (am := get(x,'automode,$env)) then
+ putModeSet(t,[am])
+ putMode(t,am)
+ t
diff --git a/src/interp/i-output.boot b/src/interp/i-output.boot
index e2c83fd9..833f070f 100644
--- a/src/interp/i-output.boot
+++ b/src/interp/i-output.boot
@@ -335,9 +335,9 @@ outputTran x ==
x is ['MAP,:l] => outputMapTran l
x is ['brace, :l] =>
['BRACE, ['AGGLST,:[outputTran y for y in l]]]
- x is ['return,l] => ['return,outputTran l]
- x is ['return,.,:l] => ['return,:outputTran l]
- x is ['construct,:l] =>
+ x is ["return",l] => ["return",outputTran l]
+ x is ["return",.,:l] => ["return",:outputTran l]
+ x is ["construct",:l] =>
['BRACKET,['AGGLST,:[outputTran y for y in l]]]
x is [["$elt",domain,"float"], x, y, z] and (domain = $DoubleFloat or
@@ -963,11 +963,11 @@ maprin0 x ==
maprinChk x ==
null $MatrixList => maPrin x
- ATOM x and (u:= ASSOC(x,$MatrixList)) =>
+ ATOM x and (u:= assoc(x,$MatrixList)) =>
$MatrixList := delete(u,$MatrixList)
maPrin deMatrix CDR u
x is ["=",arg,y] => --case for tracing with )math and printing matrices
- u:=ASSOC(y,$MatrixList) =>
+ u:=assoc(y,$MatrixList) =>
-- we don't want to print matrix1 = matrix2 ...
$MatrixList := delete(u,$MatrixList)
maPrin ["=",arg, deMatrix CDR u]
@@ -981,7 +981,7 @@ maprinChk x ==
-- m:=[[1,2,3],[4,5,6],[7,8,9]]
-- mm:=[[m,1,0],[0,m,1],[0,1,m]]
-- and try to print mm**5
- u := ASSOC(y,$MatrixList)
+ u := assoc(y,$MatrixList)
--$MatrixList := deleteAssoc(first u,$MatrixList)
-- deleteAssoc no longer exists
$MatrixList := delete(u,$MatrixList)
@@ -1556,8 +1556,8 @@ charyTrouble1(u,v,start,linelength) ==
d := GETL(x,'INFIXOP) => charyBinary(d,u,v,start,linelength)
x = 'OVER =>
charyBinary(GETL("/",'INFIXOP),u,v,start,linelength)
- EQ(3,LENGTH u) and GET(x,'Led) =>
- d:= PNAME first GET(x,'Led)
+ EQ(3,LENGTH u) and GETL(x,'Led) =>
+ d:= PNAME first GETL(x,'Led)
charyBinary(d,u,v,start,linelength)
EQ(x,'CONCAT) =>
concatTrouble(rest v,d,start,linelength,nil)
@@ -2199,7 +2199,7 @@ qTWidth(u) ==
remWidth(x) ==
atom x => x
true => CONS( (atom first x => first x; true => CAAR x),
- MMAPCAR(remWidth, rest x) )
+ MMAPCAR(function remWidth, rest x) )
subSub(u) ==
height CDDR u
diff --git a/src/interp/i-resolv.boot.pamphlet b/src/interp/i-resolv.boot.pamphlet
index fd46a0e6..a9c2e362 100644
--- a/src/interp/i-resolv.boot.pamphlet
+++ b/src/interp/i-resolv.boot.pamphlet
@@ -87,6 +87,9 @@ this symmetric resolution is done the following way:
<<*>>=
<<license>>
+import '"i-object"
+)package "BOOT"
+
resolveTypeList u ==
u is [a,:tail] =>
@@ -391,7 +394,7 @@ resolveTTRed3(t) ==
t is ['SetUnion,a,b] => union(a,b)
t is ['VarEqual,a,b] => (a = b) and a
t is ['SetEqual,a,b] =>
- (and/[member(x,a) for x in b] and and/[member(x,b) for x in a]) and a
+ (and/[member(x,a) for x in b] and "and"/[member(x,b) for x in a]) and a
[( atom x and x ) or ((not cs and x and not interpOp? x and x)
or resolveTTRed3 x) or return NIL
for x in t for cs in GETDATABASE(CAR t, 'COSIG) ]
@@ -442,7 +445,7 @@ resolveTCat1(t,c) ==
null (conds := getConditionsForCategoryOnType(t,c)) => NIL
--rest(conds) => NIL -- will handle later
cond := first conds
- cond isnt [.,['has, pat, c1],:.] => NIL
+ cond isnt [.,["has", pat, c1],:.] => NIL
rest(c1) => NIL -- make it simple
argN := 0
@@ -498,7 +501,7 @@ matchUpToPatternVars(pat,form,patAlist) ==
EQUAL(pat,form) => true
isSharpVarWithNum(pat) =>
-- see is pattern variable is in alist
- (p := ASSOC(pat,patAlist)) => EQUAL(form,CDR p)
+ (p := assoc(pat,patAlist)) => EQUAL(form,CDR p)
patAlist := [[pat,:form],:patAlist]
true
PAIRP(pat) =>
@@ -738,12 +741,12 @@ resolveTMRed1(t) ==
resolveTM1(a,b)
t is ['Incl,a,b] => PAIRP b and member(a,b) and b
t is ['Diff,a,b] => PAIRP a and member(b,a) and SETDIFFERENCE(a,[b])
- t is ['SetIncl,a,b] => PAIRP b and and/[member(x,b) for x in a] and b
+ t is ['SetIncl,a,b] => PAIRP b and "and"/[member(x,b) for x in a] and b
t is ['SetDiff,a,b] => PAIRP b and PAIRP b and
intersection(a,b) and SETDIFFERENCE(a,b)
t is ['VarEqual,a,b] => (a = b) and b
t is ['SetComp,a,b] => PAIRP a and PAIRP b and
- and/[member(x,a) for x in b] and SETDIFFERENCE(a,b)
+ "and"/[member(x,a) for x in b] and SETDIFFERENCE(a,b)
t is ['SimpleAlgebraicExtension,a,b,p] => -- this is a hack. RSS
['SimpleAlgebraicExtension, resolveTMRed1 a, resolveTMRed1 b,p]
[( atom x and x ) or resolveTMRed1 x or return NIL for x in t]
diff --git a/src/interp/i-spec1.boot.pamphlet b/src/interp/i-spec1.boot.pamphlet
index 8175bc6a..2e178fe0 100644
--- a/src/interp/i-spec1.boot.pamphlet
+++ b/src/interp/i-spec1.boot.pamphlet
@@ -89,17 +89,20 @@ There are several special modes used in these functions:
<<*>>=
<<license>>
+import '"i-analy"
+)package "BOOT"
+
-- Functions which require special handlers (also see end of file)
-SETANDFILEQ($repeatLabel, NIL)
-SETANDFILEQ($breakCount, 0)
-SETANDFILEQ($anonymousMapCounter, 0)
+$repeatLabel := NIL
+$breakCount := 0
+$anonymousMapCounter := 0
-SETANDFILEQ($specialOps, '(
- ADEF AlgExtension and case COERCE COLLECT construct Declare DEF Dollar
- equation error free has IF is isnt iterate break LET local MDEF or
- pretend QUOTE REDUCE REPEAT return SEQ TARGET Tuple typeOf where ))
+$specialOps := '(
+ ADEF AlgExtension _and _case COERCE COLLECT construct Declare DEF Dollar
+ equation error free has IF _is _isnt iterate _break LET _local MDEF _or
+ pretend QUOTE REDUCE REPEAT _return SEQ TARGET Tuple typeOf _where )
--% Void stuff
@@ -185,9 +188,9 @@ mkInterpTargetedADEF(t,vars,types,oldBody) ==
null first types =>
throwKeyedMsg("S2IS0056",NIL)
throwMessage '" map result type needed but not present."
- arglCode := ['LIST,:[argCode for type in rest types for var in vars]]
- where argCode == ['putValueValue,['mkAtreeNode,MKQ var],
- objNewCode(['wrap,var],type)]
+ arglCode := ["LIST",:[argCode for type in rest types for var in vars]]
+ where argCode() == ['putValueValue,['mkAtreeNode,MKQ var],
+ objNewCode(["wrap",var],type)]
put($mapName,'mapBody,oldBody,$e)
body := ['rewriteMap1,MKQ $mapName,arglCode,MKQ types]
compileADEFBody(t,vars,types,body,first types)
@@ -227,7 +230,7 @@ compileADEFBody(t,vars,types,body,computedResultType) ==
--
-- MCD 13/3/96
if not $definingMap and ($genValue or $compilingMap) then
- fun := ['function,['LAMBDA,[:vars,'envArg],body]]
+ fun := ["function",["LAMBDA",[:vars,'envArg],body]]
code := wrap timedEVALFUN ['LIST,fun]
else
$freeVariables := []
@@ -235,8 +238,8 @@ compileADEFBody(t,vars,types,body,computedResultType) ==
-- CCL does not support upwards funargs, so we check for any free variables
-- and pass them into the lambda as part of envArg.
body := checkForFreeVariables(body,"ALL")
- fun := ['function,['LAMBDA,[:vars,'envArg],body]]
- code := ['CONS, fun, ["VECTOR", :reverse $freeVariables]]
+ fun := ["function",["LAMBDA",[:vars,'envArg],body]]
+ code := ["CONS", fun, ["VECTOR", :reverse $freeVariables]]
val := objNew(code,rt := ['Mapping,computedResultType,:rest types])
putValue(t,val)
@@ -316,9 +319,9 @@ upand x ==
ms := bottomUp term2
ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"and_""],term2)
-- generate an IF expression and let the rest of the code handle it
- cond := [mkAtreeNode "=",mkAtree 'false,term1]
+ cond := [mkAtreeNode "=",mkAtree "false",term1]
putTarget(cond,$Boolean)
- code := [mkAtreeNode 'IF,cond,mkAtree 'false,term2]
+ code := [mkAtreeNode "IF",cond,mkAtree "false",term2]
putTarget(code,$Boolean)
bottomUp code
putValue(x,getValue code)
@@ -346,9 +349,9 @@ upor x ==
ms := bottomUp term2
ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"or_""],term2)
-- generate an IF expression and let the rest of the code handle it
- cond := [mkAtreeNode "=",mkAtree 'true,term1]
+ cond := [mkAtreeNode "=",mkAtree "true",term1]
putTarget(cond,$Boolean)
- code := [mkAtreeNode 'IF,cond,mkAtree 'true,term2]
+ code := [mkAtreeNode "IF",cond,mkAtree "true",term2]
putTarget(code,$Boolean)
bottomUp code
putValue(x,getValue code)
@@ -363,16 +366,16 @@ upcase t ==
objMode(triple) isnt ['Union,:unionDoms] =>
throwKeyedMsg("S2IS0004",NIL)
if (rhs' := isDomainValuedVariable(rhs)) then rhs := rhs'
- if first unionDoms is ['_:,.,.] then
+ if first unionDoms is [":",.,.] then
for i in 0.. for d in unionDoms repeat
- if d is ['_:,=rhs,.] then rhstag := i
- if NULL rhstag then error "upcase: bad Union form"
+ if d is [":",=rhs,.] then rhstag := i
+ if NULL rhstag then error '"upcase: bad Union form"
$genValue =>
rhstag = first unwrap objVal triple => code := wrap 'TRUE
code := wrap NIL
code :=
- ['COND,
- [['EQL,rhstag,['CAR,['unwrap,objVal triple]]],
+ ["COND",
+ [["EQL",rhstag,["CAR",["unwrap",objVal triple]]],
''TRUE],
[''T,NIL]]
else
@@ -380,10 +383,10 @@ upcase t ==
t' := coerceUnion2Branch triple
rhs = objMode t' => code := wrap 'TRUE
code := wrap NIL
- triple' := objNewCode(['wrap,objVal triple],objMode triple)
+ triple' := objNewCode(["wrap",objVal triple],objMode triple)
code :=
- ['COND,
- [['EQUAL,MKQ rhs,['objMode,['coerceUnion2Branch,triple']]],
+ ["COND",
+ [["EQUAL",MKQ rhs,["objMode",['coerceUnion2Branch,triple']]],
''TRUE],
[''T,NIL]]
putValue(op,objNew(code,$Boolean))
@@ -463,29 +466,29 @@ evalCOERCE(op,tree,m) ==
transformCollect [:itrl,body] ==
-- syntactic transformation for COLLECT form, called from mkAtree1
- iterList:=[:iterTran1 for it in itrl] where iterTran1 ==
- it is ['STEP,index,lower,step,:upperList] =>
- [['STEP,index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper
+ iterList:=[:iterTran1 for it in itrl] where iterTran1() ==
+ it is ["STEP",index,lower,step,:upperList] =>
+ [["STEP",index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper
for upper in upperList]]]
- it is ['IN,index,s] =>
- [['IN,index,mkAtree1 s]]
- it is ['ON,index,s] =>
+ it is ["IN",index,s] =>
+ [["IN",index,mkAtree1 s]]
+ it is ["ON",index,s] =>
[['IN,index,mkAtree1 ['tails,s]]]
- it is ['WHILE,b] =>
- [['WHILE,mkAtree1 b]]
- it is ['_|,pred] =>
- [['SUCHTHAT,mkAtree1 pred]]
+ it is ["WHILE",b] =>
+ [["WHILE",mkAtree1 b]]
+ it is ["|",pred] =>
+ [["SUCHTHAT",mkAtree1 pred]]
it is [op,:.] and (op in '(VALUE UNTIL)) => nil
bodyTree:=mkAtree1 body
iterList:=NCONC(iterList,[:iterTran2 for it in itrl]) where
- iterTran2 ==
- it is ['STEP,:.] => nil
- it is ['IN,:.] => nil
- it is ['ON,:.] => nil
- it is ['WHILE,:.] => nil
+ iterTran2() ==
+ it is ["STEP",:.] => nil
+ it is ["IN",:.] => nil
+ it is ["ON",:.] => nil
+ it is ["WHILE",:.] => nil
it is [op,b] and (op in '(UNTIL)) =>
[[op,mkAtree1 b]]
- it is ['_|,pred] => nil
+ it is ["|",pred] => nil
keyedSystemError("S2GE0016",
['"transformCollect",'"Unknown type of iterator"])
[:iterList,bodyTree]
@@ -515,7 +518,7 @@ upCOLLECT1 t ==
ms:= bottomUpCompile body
[m]:= ms
for itr in itrl repeat
- itr is ['UNTIL, pred] => bottomUpCompilePredicate(pred,'"until")
+ itr is ["UNTIL", pred] => bottomUpCompilePredicate(pred,'"until")
mode:= ['Tuple,m]
evalCOLLECT(op,rest t,mode)
putModeSet(op,[mode])
@@ -523,15 +526,15 @@ upCOLLECT1 t ==
upLoopIters itrl ==
-- type analyze iterator loop iterators
for iter in itrl repeat
- iter is ['WHILE,pred] =>
+ iter is ["WHILE",pred] =>
bottomUpCompilePredicate(pred,'"while")
- iter is ['SUCHTHAT,pred] =>
+ iter is ["SUCHTHAT",pred] =>
bottomUpCompilePredicate(pred,'"|")
- iter is ['UNTIL,:.] =>
+ iter is ["UNTIL",:.] =>
NIL -- handle after body is analyzed
- iter is ['IN,index,s] =>
+ iter is ["IN",index,s] =>
upLoopIterIN(iter,index,s)
- iter is ['STEP,index,lower,step,:upperList] =>
+ iter is ["STEP",index,lower,step,:upperList] =>
upLoopIterSTEP(index,lower,step,upperList)
-- following is an optimization
typeIsASmallInteger(get(index,'mode,$env)) =>
@@ -985,10 +988,10 @@ subVecNodes(new,old,form) ==
mkIterVarSub(var,numVars) ==
n := iterVarPos var
n=2 =>
- [mkAtreeNode 'elt,mkNestedElts(numVars-2),mkAtreeNode 'part2]
+ [mkAtreeNode "elt",mkNestedElts(numVars-2),mkAtreeNode 'part2]
n=1 =>
- [mkAtreeNode 'elt,mkNestedElts(numVars-2),mkAtreeNode 'part1]
- [mkAtreeNode 'elt,mkNestedElts(numVars-n),mkAtreeNode 'part1]
+ [mkAtreeNode "elt",mkNestedElts(numVars-2),mkAtreeNode 'part1]
+ [mkAtreeNode "elt",mkNestedElts(numVars-n),mkAtreeNode 'part1]
iterVarPos var ==
for [index,:.] in reverse $indexVars for i in 1.. repeat
@@ -996,7 +999,7 @@ iterVarPos var ==
mkNestedElts n ==
n=0 => mkAtreeNode($index or ($index:= GENSYM()))
- [mkAtreeNode 'elt, mkNestedElts(n-1), mkAtreeNode 'part2]
+ [mkAtreeNode "elt", mkNestedElts(n-1), mkAtreeNode 'part2]
--% Handlers for construct
@@ -1135,8 +1138,8 @@ upRecordConstruct(op,l,tar) ==
for arg in l for ['_:,.,type] in types]
len := #l
code :=
- (len = 1) => ['CONS, :argCode, '()]
- (len = 2) => ['CONS,:argCode]
+ (len = 1) => ["CONS", :argCode, '()]
+ (len = 2) => ["CONS",:argCode]
['VECTOR,:argCode]
if $genValue then code := wrap timedEVALFUN code
putValue(op,objNew(code,tar))
@@ -1154,13 +1157,13 @@ upDeclare t ==
categoryForm?(mode) => throwKeyedMsgSP("S2IE0011",[mode, 'category],op)
packageForm?(mode) => throwKeyedMsgSP("S2IE0011",[mode, 'package],op)
junk :=
- lhs is ['free,['Tuple,:vars]] or lhs is ['free,['LISTOF,:vars]] or
- lhs is ['free,:vars] =>
+ lhs is ["free",['Tuple,:vars]] or lhs is ['free,['LISTOF,:vars]] or
+ lhs is ["free",:vars] =>
for var in vars repeat declare(['free,var],mode)
- lhs is ['local,['Tuple,:vars]] or lhs is ['local,['LISTOF,:vars]] or
- lhs is ['local,:vars] =>
- for var in vars repeat declare(['local,var],mode)
- lhs is ['Tuple,:vars] or lhs is ['LISTOF,:vars] =>
+ lhs is ["local",['Tuple,:vars]] or lhs is ['local,['LISTOF,:vars]] or
+ lhs is ["local",:vars] =>
+ for var in vars repeat declare(["local",var],mode)
+ lhs is ["Tuple",:vars] or lhs is ["LISTOF",:vars] =>
for var in vars repeat declare(var,mode)
declare(lhs,mode)
putValue(op,objNewWrap(voidValue(), $Void))
diff --git a/src/interp/i-spec2.boot.pamphlet b/src/interp/i-spec2.boot.pamphlet
index 8b16f053..8d57009a 100644
--- a/src/interp/i-spec2.boot.pamphlet
+++ b/src/interp/i-spec2.boot.pamphlet
@@ -89,6 +89,9 @@ There are several special modes used in these functions:
<<*>>=
<<license>>
+import '"i-spec1"
+)package "BOOT"
+
-- Functions which require special handlers (also see end of file)
--% Handlers for map definitions
@@ -96,7 +99,7 @@ There are several special modes used in these functions:
upDEF t ==
-- performs map definitions. value is thrown away
t isnt [op,def,pred,.] => nil
- v:=addDefMap(['DEF,:def],pred)
+ v:=addDefMap(["DEF",:def],pred)
null(LISTP(def)) or null(def) =>
keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"])
mapOp := first def
@@ -104,7 +107,7 @@ upDEF t ==
null mapOp =>
keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"])
mapOp := first mapOp
- put(mapOp,'value,v,$e)
+ put(mapOp,"value",v,$e)
putValue(op,objNew(voidValue(), $Void))
putModeSet(op,[$Void])
@@ -114,9 +117,9 @@ upDollar t ==
-- Puts "dollar" property in atree node, and calls bottom up
t isnt [op,D,form] => nil
t2 := t
- (not $genValue) and or/[CONTAINED(var,D) for var in $localVars] =>
+ (not $genValue) and "or"/[CONTAINED(var,D) for var in $localVars] =>
keyedMsgCompFailure("S2IS0032",NIL)
- EQ(D,'Lisp) => upLispCall(op,form)
+ EQ(D,"Lisp") => upLispCall(op,form)
if VECP D and (SIZE(D) > 0) then D := D.0
t := evaluateType unabbrev D
categoryForm? t =>
@@ -131,7 +134,7 @@ upDollar t ==
isPartialMode t => throwKeyedMsg("S2IS0020",NIL)
if $genValue then
val := wrap getConstantFromDomain([f],t)
- else val := ['getConstantFromDomain,['LIST,MKQ f],MKQ t]
+ else val := ["getConstantFromDomain",["LIST",MKQ f],MKQ t]
putValue(op,objNew(val,t))
putModeSet(op,[t])
@@ -139,12 +142,12 @@ upDollar t ==
(ms := upDollarTuple(op, f, t, t2, rest form, nargs)) => ms
- f ^= 'construct and null isOpInDomain(f,t,nargs) =>
+ f ^= "construct" and null isOpInDomain(f,t,nargs) =>
throwKeyedMsg("S2IS0023",[f,t])
if (sig := findCommonSigInDomain(f,t,nargs)) then
for x in sig for y in form repeat
if x then putTarget(y,x)
- putAtree(first form,'dollar,t)
+ putAtree(first form,"dollar",t)
ms := bottomUp form
f in '(One Zero) and PAIRP(ms) and CAR(ms) = $OutputForm =>
throwKeyedMsg("S2IS0021",[f,t])
@@ -167,7 +170,7 @@ upDollarTuple(op, f, t, t2, args, nargs) ==
ms := bottomUp newArg
first ms ^= tuple => NIL
form := [first form, newArg]
- putAtree(first form,'dollar,t)
+ putAtree(first form,"dollar",t)
ms := bottomUp form
putValue(op,getValue first form)
putModeSet(op,ms)
@@ -236,13 +239,13 @@ uphas t ==
t isnt [op,type,prop] => nil
-- handler for category and attribute queries
type :=
- isLocalVar(type) => ['unabbrev, type]
+ isLocalVar(type) => ["unabbrev", type]
MKQ unabbrev type
catCode :=
prop := unabbrev prop
- evaluateType0 prop => ['evaluateType, MKQ prop]
+ evaluateType0 prop => ["evaluateType", MKQ prop]
MKQ prop
- code:=['newHasTest,['evaluateType, type], catCode]
+ code:=["newHasTest",["evaluateType", type], catCode]
if $genValue then code := wrap timedEVALFUN code
putValue(op,objNew(code,$Boolean))
putModeSet(op,[$Boolean])
@@ -263,10 +266,10 @@ compileIF(op,cond,a,b,t) ==
-- IF are resolved.
ms1 := bottomUp a
[m1] := ms1
- b = 'noBranch =>
+ b = "noBranch" =>
evalIF(op,rest t,$Void)
putModeSet(op,[$Void])
- b = 'noMapVal =>
+ b = "noMapVal" =>
-- if this was a return statement, we take the mode to be that
-- of what is being returned.
if getUnname a = 'return then
@@ -280,9 +283,9 @@ compileIF(op,cond,a,b,t) ==
m2=m1 => m1
m2 = $Exit => m1
m1 = $Exit => m2
- if EQCAR(m1,'Symbol) then
+ if EQCAR(m1,"Symbol") then
m1:=getMinimalVarMode(getUnname a,$declaredMode)
- if EQCAR(m2,'Symbol) then
+ if EQCAR(m2,"Symbol") then
m2:=getMinimalVarMode(getUnname b,$declaredMode)
(r := resolveTTAny(m2,m1)) => r
rempropI($mapName,'localModemap)
@@ -295,14 +298,14 @@ compileIF(op,cond,a,b,t) ==
evalIF(op,[cond,a,b],m) ==
-- generate code form compiled IF
elseCode:=
- b='noMapVal =>
- [[MKQ true, ['throwKeyedMsg,MKQ "S2IM0018",
- ['CONS,MKQ object2Identifier $mapName,NIL]]]]
+ b="noMapVal" =>
+ [[MKQ true, ["throwKeyedMsg",MKQ "S2IM0018",
+ ["CONS",MKQ object2Identifier $mapName,NIL]]]]
b='noBranch =>
- $lastLineInSEQ => [[MKQ true,['voidValue]]]
+ $lastLineInSEQ => [[MKQ true,["voidValue"]]]
NIL
[[MKQ true,genIFvalCode(b,m)]]
- code:=['COND,[getArgValue(cond,$Boolean),
+ code:=["COND",[getArgValue(cond,$Boolean),
genIFvalCode(a,m)],:elseCode]
triple:= objNew(code,m)
putValue(op,triple)
@@ -318,9 +321,9 @@ genIFvalCode(t,m) ==
IFcodeTran(code,m,m1) ==
-- coerces values at branches of IF
null code => code
- code is ['spadThrowBrightly,:.] => code
+ code is ["spadThrowBrightly",:.] => code
m1 = $Exit => code
- code isnt ['COND,[p1,a1],[''T,a2]] =>
+ code isnt ["COND",[p1,a1],[''T,a2]] =>
m = $Void => code
code' := coerceInteractive(objNew(quote2Wrapped code,m1),m) =>
wrapped2Quote objVal code'
@@ -335,7 +338,7 @@ interpIF(op,cond,a,b) ==
val:= getValue cond
val:= coerceInteractive(val,$Boolean) =>
objValUnwrap(val) => upIFgenValue(op,a)
- EQ(b,'noBranch) =>
+ EQ(b,"noBranch") =>
putValue(op,objNew(voidValue(), $Void))
putModeSet(op,[$Void])
upIFgenValue(op,b)
@@ -371,13 +374,13 @@ upisAndIsnt(t:=[op,a,pattern]) ==
putPvarModes(pattern,m) ==
-- Puts the modes for the pattern variables into $env
- m isnt ['List,um] => throwKeyedMsg("S2IS0030",NIL)
+ m isnt ["List",um] => throwKeyedMsg("S2IS0030",NIL)
for pvar in pattern repeat
IDENTP pvar => (null (pvar=$quadSymbol)) and put(pvar,'mode,um,$env)
pvar is ['_:,var] =>
- null (var=$quadSymbol) and put(var,'mode,m,$env)
+ null (var=$quadSymbol) and put(var,"mode",m,$env)
pvar is ['_=,var] =>
- null (var=$quadSymbol) and put(var,'mode,um,$env)
+ null (var=$quadSymbol) and put(var,"mode",um,$env)
putPvarModes(pvar,um)
evalis(op,[a,pattern],mode) ==
@@ -398,8 +401,8 @@ isLocalPred pattern ==
-- returns true if the is predicate is to be compiled
for pat in pattern repeat
IDENTP pat and isLocalVar(pat) => return true
- pat is ['_:,var] and isLocalVar(var) => return true
- pat is ['_=,var] and isLocalVar(var) => return true
+ pat is [":",var] and isLocalVar(var) => return true
+ pat is ["=",var] and isLocalVar(var) => return true
compileIs(val,pattern) ==
-- produce code for compiled "is" predicate. makes pattern variables
@@ -407,15 +410,15 @@ compileIs(val,pattern) ==
vars:= NIL
for pat in CDR pattern repeat
IDENTP(pat) and isLocalVar(pat) => vars:=[pat,:vars]
- pat is ['_:,var] => vars:= [var,:vars]
- pat is ['_=,var] => vars:= [var,:vars]
- predCode:=['LET,g:=GENSYM(),['isPatternMatch,
+ pat is [":",var] => vars:= [var,:vars]
+ pat is ["=",var] => vars:= [var,:vars]
+ predCode:=["LET",g:=GENSYM(),["isPatternMatch",
getArgValue(val,computedMode val),MKQ removeConstruct pattern]]
for var in REMDUP vars repeat
- assignCode:=[['LET,var,['CDR,['ASSQ,MKQ var,g]]],:assignCode]
+ assignCode:=[["LET",var,["CDR",["ASSQ",MKQ var,g]]],:assignCode]
null $opIsIs =>
- ['COND,[['EQ,predCode,MKQ 'failed],['SEQ,:assignCode,MKQ 'T]]]
- ['COND,[['NOT,['EQ,predCode,MKQ 'failed]],['SEQ,:assignCode,MKQ 'T]]]
+ ["COND",[["EQ",predCode,MKQ "failed"],["SEQ",:assignCode,MKQ 'T]]]
+ ["COND",[["NOT",["EQ",predCode,MKQ "failed"]],["SEQ",:assignCode,MKQ 'T]]]
evalIsPredicate(value,pattern,mode) ==
--This function pattern matches value to pattern, and returns
@@ -435,8 +438,8 @@ evalIsntPredicate(value,pattern,mode) ==
removeConstruct pat ==
-- removes the "construct" from the beginning of patterns
- if pat is ['construct,:p] then pat:=p
- if pat is ['cons, a, b] then pat := [a, ['_:, b]]
+ if pat is ["construct",:p] then pat:=p
+ if pat is ["cons", a, b] then pat := [a, [":", b]]
atom pat => pat
RPLACA(pat,removeConstruct CAR pat)
RPLACD(pat,removeConstruct CDR pat)
@@ -454,26 +457,26 @@ isPatMatch(l,pats) ==
$subs:='failed
null l =>
null pats => $subs
- pats is [['_:,var]] =>
+ pats is [[":",var]] =>
$subs := [[var],:$subs]
$subs:='failed
pats is [pat,:restPats] =>
IDENTP pat =>
$subs:=[[pat,:first l],:$subs]
isPatMatch(rest l,restPats)
- pat is ['_=,var] =>
+ pat is ["=",var] =>
p:=ASSQ(var,$subs) =>
CAR l = CDR p => isPatMatch(rest l, restPats)
- $subs:='failed
- $subs:='failed
- pat is ['_:,var] =>
+ $subs:="failed"
+ $subs:="failed"
+ pat is [":",var] =>
n:=#restPats
m:=#l-n
- m<0 => $subs:='failed
+ m<0 => $subs:="failed"
ZEROP n => $subs:=[[var,:l],:$subs]
$subs:=[[var,:[x for x in l for i in 1..m]],:$subs]
isPatMatch(DROP(m,l),restPats)
- isPatMatch(first l,pat) = 'failed => 'failed
+ isPatMatch(first l,pat) = "failed" => "failed"
isPatMatch(rest l,restPats)
keyedSystemError("S2GE0016",['"isPatMatch",
'"unknown form of is predicate"])
@@ -483,7 +486,7 @@ isPatMatch(l,pats) ==
upiterate t ==
null $repeatBodyLabel => throwKeyedMsg("S2IS0029",['"iterate"])
$iterateCount := $iterateCount + 1
- code := ['THROW,$repeatBodyLabel,'(voidValue)]
+ code := ["THROW",$repeatBodyLabel,'(voidValue)]
$genValue => THROW(eval $repeatBodyLabel,voidValue())
putValue(t,objNew(code,$Void))
putModeSet(t,[$Void])
@@ -494,7 +497,7 @@ upbreak t ==
t isnt [op,.] => nil
null $repeatLabel => throwKeyedMsg("S2IS0029",['"break"])
$breakCount := $breakCount + 1
- code := ['THROW,$repeatLabel,'(voidValue)]
+ code := ["THROW",$repeatLabel,'(voidValue)]
$genValue => THROW(eval $repeatLabel,voidValue())
putValue(op,objNew(code,$Void))
putModeSet(op,[$Void])
@@ -508,8 +511,8 @@ upLET t ==
$declaredMode: local := NIL
PAIRP lhs =>
var:= getUnname first lhs
- var = 'construct => upLETWithPatternOnLhs t
- var = 'QUOTE => throwKeyedMsg("S2IS0027",['"A quoted form"])
+ var = "construct" => upLETWithPatternOnLhs t
+ var = "QUOTE" => throwKeyedMsg("S2IS0027",['"A quoted form"])
upLETWithFormOnLhs(op,lhs,rhs)
var:= getUnname lhs
var = $immediateDataSymbol =>
@@ -685,7 +688,7 @@ upLETWithFormOnLhs(op,lhs,rhs) ==
seteltable(lhs is [f,:argl],rhs) ==
-- produces the setelt form for trees such as "l.2:= 3"
null (g := getUnnameIfCan f) => NIL
- EQ(g,'elt) => altSeteltable [:argl, rhs]
+ EQ(g,"elt") => altSeteltable [:argl, rhs]
get(g,'value,$e) is [expr,:.] and isMapExpr expr => NIL
transferPropsToNode(g,f)
getValue(lhs) or getMode(lhs) =>
@@ -735,13 +738,28 @@ upTableSetelt(op,lhs is [htOp,:args],rhs) ==
-- function to give it an initial value.
bottomUp [mkAtreeNode 'LET,htOp,[mkAtreeNode 'table]]
tableCode := objVal getValue htOp
- r := upSetelt(op, lhs, [mkAtreeNode 'setelt,:lhs,rhs])
+ r := upSetelt(op, lhs, [mkAtreeNode "setelt",:lhs,rhs])
$genValue => r
-- construct code
t := getValue op
putValue(op,objNew(['PROGN,tableCode,objVal t],objMode t))
r
+unVectorize body ==
+ -- transforms from an atree back into a tree
+ VECP body =>
+ name := getUnname body
+ name ^= $immediateDataSymbol => name
+ objValUnwrap getValue body
+ atom body => body
+ body is [op,:argl] =>
+ newOp:=unVectorize op
+ if newOp = 'SUCHTHAT then newOp := "|"
+ if newOp = 'COERCE then newOp := "::"
+ if newOp = 'Dollar then newOp := "$elt"
+ [newOp,:unVectorize argl]
+ systemErrorHere '"unVectorize"
+
isType t ==
-- Returns the evaluated type if t is a tree representing a type,
-- and NIL otherwise
@@ -766,7 +784,7 @@ isType t ==
upLETtype(op,lhs,type) ==
-- performs type assignment
opName:= getUnname lhs
- (not $genValue) and or/[CONTAINED(var,type) for var in $localVars] =>
+ (not $genValue) and "or"/[CONTAINED(var,type) for var in $localVars] =>
compFailure ['" Cannot compile type assignment to",:bright opName]
mode :=
if isPartialMode type then '(Mode)
@@ -792,7 +810,7 @@ assignSymbol(symbol, value, domain) ==
getInterpMacroNames() ==
names := [n for [n,:.] in $InterpreterMacroAlist]
- if (e := CAAR $InteractiveFrame) and (m := ASSOC("--macros--",e)) then
+ if (e := CAAR $InteractiveFrame) and (m := assoc("--macros--",e)) then
names := append(names,[n for [n,:.] in CDR m])
MSORT names
@@ -804,7 +822,7 @@ isInterpMacro name ==
(m := get("--macros--",name,$e)) => m
(m := get("--macros--",name,$InteractiveFrame)) => m
-- $InterpreterMacroAlist will probably be phased out soon
- (sv := ASSOC(name,$InterpreterMacroAlist)) => CONS(NIL,CDR sv)
+ (sv := assoc(name,$InterpreterMacroAlist)) => CONS(NIL,CDR sv)
NIL
--% Handlers for prefix QUOTE
@@ -853,7 +871,7 @@ getReduceFunction(op,type,result, locale) ==
if locale then putAtree(vecOp,'dollar,locale)
mmS:= selectMms(vecOp,args,result)
mm:= or/[mm for (mm:=[[.,:sig],fun,cond]) in mmS |
- (isHomogeneousArgs sig) and and/[null c for c in cond]]
+ (isHomogeneousArgs sig) and "and"/[null c for c in cond]]
null mm => 'failed
[[dc,:sig],fun,:.]:=mm
dc='local => [MKQ [fun,:'local],:CAR sig]
@@ -878,25 +896,25 @@ isHomogeneousArgs sig ==
transformREPEAT [:itrl,body] ==
-- syntactic transformation of repeat iterators, called from mkAtree2
- iterList:=[:iterTran1 for it in itrl] where iterTran1 ==
- it is ['STEP,index,lower,step,:upperList] =>
- [['STEP,index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper
+ iterList:=[:iterTran1 for it in itrl] where iterTran1() ==
+ it is ["STEP",index,lower,step,:upperList] =>
+ [["STEP",index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper
for upper in upperList]]]
- it is ['IN,index,s] =>
+ it is ["IN",index,s] =>
[['IN,index,mkAtree1 s]]
- it is ['ON,index,s] =>
+ it is ["ON",index,s] =>
[['IN,index,mkAtree1 ['tails,s]]]
- it is ['WHILE,b] =>
- [['WHILE,mkAtree1 b]]
- it is ['_|,pred] =>
- [['SUCHTHAT,mkAtree1 pred]]
+ it is ["WHILE",b] =>
+ [["WHILE",mkAtree1 b]]
+ it is ["|",pred] =>
+ [["SUCHTHAT",mkAtree1 pred]]
it is [op,:.] and (op in '(VALUE UNTIL)) => nil
bodyTree:=mkAtree1 body
- iterList:=NCONC(iterList,[:iterTran2 for it in itrl]) where iterTran2 ==
- it is ['STEP,:.] => nil
- it is ['IN,:.] => nil
- it is ['ON,:.] => nil
- it is ['WHILE,:.] => nil
+ iterList:=NCONC(iterList,[:iterTran2 for it in itrl]) where iterTran2() ==
+ it is ["STEP",:.] => nil
+ it is ["IN",:.] => nil
+ it is ["ON",:.] => nil
+ it is ["WHILE",:.] => nil
it is [op,b] and (op in '(UNTIL VALUE)) =>
[[op,mkAtree1 b]]
it is ['_|,pred] => nil
@@ -942,7 +960,7 @@ upREPEAT1 t ==
-- now that the body is analyzed, we should know everything that
-- is in the UNTIL clause
for itr in itrl repeat
- itr is ['UNTIL, pred] => bottomUpCompilePredicate(pred,'"until")
+ itr is ["UNTIL", pred] => bottomUpCompilePredicate(pred,'"until")
-- now go do it
evalREPEAT(op,rest t,repeatMode)
@@ -953,7 +971,7 @@ evalREPEAT(op,[:itrl,body],repeatMode) ==
bodyMode := computedMode body
bodyCode := getArgValue(body,bodyMode)
if $iterateCount > 0 then
- bodyCode := ['CATCH,$repeatBodyLabel,bodyCode]
+ bodyCode := ["CATCH",$repeatBodyLabel,bodyCode]
code := ['REPEAT,:[evalLoopIter itr for itr in itrl], bodyCode]
if repeatMode = $Void then code := ['OR,code,'(voidValue)]
code := timedOptimization code
@@ -977,8 +995,8 @@ interpREPEAT(op,itrl,body,repeatMode) ==
$indexTypes: local := NIL
code :=
-- we must insert a CATCH for the iterate clause
- ['REPEAT,:[interpIter itr for itr in itrl],
- ['CATCH,$repeatBodyLabel,interpLoop(body,$indexVars,
+ ["REPEAT",:[interpIter itr for itr in itrl],
+ ["CATCH",$repeatBodyLabel,interpLoop(body,$indexVars,
$indexTypes,nil)]]
SPADCATCH(eval $repeatLabel,timedEVALFUN code)
val:= objNewWrap(voidValue(),repeatMode)
@@ -987,7 +1005,7 @@ interpREPEAT(op,itrl,body,repeatMode) ==
interpLoop(expr,indexList,indexTypes,requiredType) ==
-- generates code for interp-only repeat body
- ['interpLoopIter,MKQ expr,MKQ indexList,['LIST,:indexList],
+ ['interpLoopIter,MKQ expr,MKQ indexList,["LIST",:indexList],
MKQ indexTypes, MKQ requiredType]
interpLoopIter(exp,indexList,indexVals,indexTypes,requiredType) ==
@@ -1184,15 +1202,10 @@ copyHack(env) ==
-- Creates the function names of the special function handlers and puts
-- them on the property list of the function name
-EVALANDFILEACTQ
- (
- for name in $specialOps repeat
- (
- functionName:=INTERNL('up,name) ;
- MAKEPROP(name,'up,functionName) ;
- CREATE_-SBC functionName
- )
- )
+for name in $specialOps repeat
+ functionName:=INTERNL('up,name)
+ MAKEPROP(name,'up,functionName)
+ CREATE_-SBC functionName
@
\eject
diff --git a/src/interp/i-syscmd.boot.pamphlet b/src/interp/i-syscmd.boot.pamphlet
index 8bffe842..37eb1209 100644
--- a/src/interp/i-syscmd.boot.pamphlet
+++ b/src/interp/i-syscmd.boot.pamphlet
@@ -128,17 +128,22 @@ This will have to be pushed down from the top level Makefile.
<<*>>=
<<license>>
+import '"i-object"
+)package "BOOT"
+
--% Utility Variable Initializations
-SETANDFILEQ($cacheAlist,nil)
-SETANDFILEQ($compileRecurrence,true)
-SETANDFILEQ($errorReportLevel,'warning)
-SETANDFILEQ($sourceFileTypes,'(INPUT SPAD BOOT LISP LISP370 META))
+$cacheAlist := nil
+$compileRecurrence := true
+$errorReportLevel := 'warning
+$sourceFileTypes := '(INPUT SPAD BOOT LISP LISP370 META)
+
+$SYSCOMMANDS := [CAR x for x in $systemCommands]
-SETANDFILEQ($SYSCOMMANDS,[CAR x for x in $systemCommands])
+UNDERBAR == '"__"
-SETANDFILEQ($whatOptions, '( _
+$whatOptions := '( _
operations _
categories _
domains _
@@ -146,17 +151,17 @@ SETANDFILEQ($whatOptions, '( _
commands _
synonyms _
things _
- ))
+ )
-SETANDFILEQ($clearOptions, '( _
+$clearOptions := '( _
modes _
operations _
properties _
types _
values _
- ))
+ )
-SETANDFILEQ($displayOptions, '( _
+$displayOptions := '( _
abbreviations _
all _
macros _
@@ -166,9 +171,9 @@ SETANDFILEQ($displayOptions, '( _
properties _
types _
values _
- ))
+ )
-SETANDFILEQ($countAssoc,'( (cache countCache) ))
+$countAssoc := '( (cache countCache) )
--% Top level system command
@@ -431,7 +436,7 @@ clearCmdParts(l is [opt,:vl]) ==
if option='properties and x in imacs and ^(x in pmacs) then
sayMessage ['" You cannot clear the definition of the system-defined macro ",
fixObjectForPrinting x,"."]
- p1 := ASSOC(x,CAAR $InteractiveFrame) =>
+ p1 := assoc(x,CAAR $InteractiveFrame) =>
option='properties =>
if isMap x then
(lm := get(x,'localModemap,$InteractiveFrame)) =>
@@ -442,7 +447,7 @@ clearCmdParts(l is [opt,:vl]) ==
recordOldValue(x,prop,CDR p2)
recordNewValue(x,prop,NIL)
SETF(CAAR $InteractiveFrame,deleteAssoc(x,CAAR $InteractiveFrame))
- p2:= ASSOC(option,CDR p1) =>
+ p2:= assoc(option,CDR p1) =>
recordOldValue(x,option,CDR p2)
recordNewValue(x,option,NIL)
RPLACD(p2,NIL)
@@ -846,6 +851,78 @@ copyright () ==
--% )credits -- display credit list
+CREDITS := '(
+ "An alphabetical listing of contributors to AXIOM (to October, 2006):"
+ "Cyril Alberga Roy Adler Christian Aistleitner"
+ "Richard Anderson George Andrews"
+ "Henry Baker Stephen Balzac Yurij Baransky"
+ "David R. Barton Gerald Baumgartner Gilbert Baumslag"
+ "Fred Blair Vladimir Bondarenko Mark Botch"
+ "Alexandre Bouyer Peter A. Broadbery Martin Brock"
+ "Manuel Bronstein Florian Bundschuh Luanne Burns"
+ "William Burge"
+ "Quentin Carpent Robert Caviness Bruce Char"
+ "Cheekai Chin David V. Chudnovsky Gregory V. Chudnovsky"
+ "Josh Cohen Christophe Conil Don Coppersmith"
+ "George Corliss Robert Corless Gary Cornell"
+ "Meino Cramer Claire Di Crescenzo"
+ "Timothy Daly Sr. Timothy Daly Jr. James H. Davenport"
+ "Jean Della Dora Gabriel Dos Reis Michael Dewar"
+ "Claire DiCrescendo Sam Dooley Lionel Ducos"
+ "Martin Dunstan Brian Dupee Dominique Duval"
+ "Robert Edwards Heow Eide-Goodman Lars Erickson"
+ "Richard Fateman Bertfried Fauser Stuart Feldman"
+ "Brian Ford Albrecht Fortenbacher George Frances"
+ "Constantine Frangos Timothy Freeman Korrinn Fu"
+ "Marc Gaetano Rudiger Gebauer Kathy Gerber"
+ "Patricia Gianni Holger Gollan Teresa Gomez-Diaz"
+ "Laureano Gonzalez-Vega Stephen Gortler Johannes Grabmeier"
+ "Matt Grayson James Griesmer Vladimir Grinberg"
+ "Oswald Gschnitzer Jocelyn Guidry"
+ "Steve Hague Vilya Harvey Satoshi Hamaguchi"
+ "Martin Hassner Waldek Hebisch Ralf Hemmecke"
+ "Henderson Antoine Hersen"
+ "Pietro Iglio"
+ "Richard Jenks"
+ "Kai Kaminski Grant Keady Tony Kennedy"
+ "Paul Kosinski Klaus Kusche Bernhard Kutzler"
+ "Larry Lambe Frederic Lehobey Michel Levaud"
+ "Howard Levy Rudiger Loos Michael Lucks"
+ "Richard Luczak"
+ "Camm Maguire Bob McElrath Michael McGettrick"
+ "Ian Meikle David Mentre Victor S. Miller"
+ "Gerard Milmeister Mohammed Mobarak H. Michael Moeller"
+ "Michael Monagan Marc Moreno-Maza Scott Morrison"
+ "Mark Murray"
+ "William Naylor C. Andrew Neff John Nelder"
+ "Godfrey Nolan Arthur Norman Jinzhong Niu"
+ "Michael O'Connor Kostas Oikonomou"
+ "Julian A. Padget Bill Page Susan Pelzel"
+ "Michel Petitot Didier Pinchon Jose Alfredo Portes"
+ "Claude Quitte"
+ "Norman Ramsey Michael Richardson Renaud Rioboo"
+ "Jean Rivlin Nicolas Robidoux Simon Robinson"
+ "Michael Rothstein Martin Rubey"
+ "Philip Santas Alfred Scheerhorn William Schelter"
+ "Gerhard Schneider Martin Schoenert Marshall Schor"
+ "Frithjof Schulze Fritz Schwarz Nick Simicich"
+ "William Sit Elena Smirnova Jonathan Steinbach"
+ "Christine Sundaresan Robert Sutor Moss E. Sweedler"
+ "Eugene Surowitz"
+ "James Thatcher Balbir Thomas Mike Thomas"
+ "Dylan Thurston Barry Trager Themos T. Tsikas"
+ "Gregory Vanuxem"
+ "Bernhard Wall Stephen Watt Jaap Weel"
+ "Juergen Weiss M. Weller Mark Wegman"
+ "James Wen Thorsten Werther Michael Wester"
+ "John M. Wiley Berhard Will Clifton J. Williamson"
+ "Stephen Wilson Shmuel Winograd Robert Wisbauer"
+ "Sandra Wityak Waldemar Wiwianka Knut Wolf"
+ "Clifford Yapp David Yun"
+ "Richard Zippel Evelyn Zoernack Bruno Zuercher"
+ "Dan Zwillinger"
+ )
+
credits() ==
for i in CREDITS repeat
PRINC(i)
@@ -929,7 +1006,7 @@ getParserMacroNames() ==
--------------------> NEW DEFINITION (override in patches.lisp.pamphlet)
clearParserMacro(macro) ==
-- first see if it is one
- not IFCDR ASSOC(macro, ($pfMacros)) => NIL
+ not IFCDR assoc(macro, ($pfMacros)) => NIL
$pfMacros := REMALIST($pfMacros, macro)
displayMacro name ==
@@ -2040,7 +2117,7 @@ dewritify ob ==
HPUT($seen, nob, nob)
nob
type = 'PLACE =>
- nob := READ MAKE_-INSTREAM NIL
+ nob := VMREAD MAKE_-INSTREAM NIL
HPUT($seen, ob, nob)
HPUT($seen, nob, nob)
nob
@@ -2447,7 +2524,7 @@ spool filename ==
systemError CONCAT('"file ", STRING car filename, '" already exists")
DRIBBLE car filename
TERPRI()
- clearHighlight
+ clearHighlight()
--% )synonym
@@ -2530,7 +2607,7 @@ diffAlist(new,old) ==
acc := [[name,:[[prop] for [prop,:.] in proplist]],:acc]
deltas := nil
for (propval := [prop,:val]) in proplist repeat
- null (oldPropval := ASSOC(prop,oldProplist)) => --missing property
+ null (oldPropval := assoc(prop,oldProplist)) => --missing property
deltas := [[prop],:deltas]
EQ(CDR oldPropval,val) => 'skip
deltas := [oldPropval,:deltas]
@@ -2632,7 +2709,7 @@ undoSingleStep(changes,env) ==
env
undoLocalModemapHack changeList ==
- [newPair for (pair := [name,:value]) in changeList | newPair] where newPair ==
+ [newPair for (pair := [name,:value]) in changeList | newPair] where newPair() ==
name = 'localModemap => [name]
pair
diff --git a/src/interp/i-toplev.boot.pamphlet b/src/interp/i-toplev.boot.pamphlet
index d8021246..411d9b05 100644
--- a/src/interp/i-toplev.boot.pamphlet
+++ b/src/interp/i-toplev.boot.pamphlet
@@ -52,15 +52,18 @@ from LISP.
<<*>>=
<<license>>
+import '"i-analy"
+)package "BOOT"
+
--% Top Level Interpreter Code
-- When $QuiteCommand is true Spad will not produce any output from
-- a top level command
-SETANDFILEQ($QuietCommand, NIL)
+$QuietCommand := NIL
-- When $ProcessInteractiveValue is true, we don't want the value printed
-- or recorded.
-SETANDFILEQ($ProcessInteractiveValue, NIL)
-SETANDFILEQ($HTCompanionWindowID, NIL)
+$ProcessInteractiveValue := NIL
+$HTCompanionWindowID := NIL
--% Starting the interpreter from LISP
diff --git a/src/interp/i-util.boot.pamphlet b/src/interp/i-util.boot.pamphlet
index 899cc18f..3539c195 100644
--- a/src/interp/i-util.boot.pamphlet
+++ b/src/interp/i-util.boot.pamphlet
@@ -58,6 +58,9 @@ lisp code is unwrapped.
<<*>>=
<<license>>
+import '"g-util"
+)package "BOOT"
+
--% The function for making prompts
spadPrompt() ==
@@ -145,7 +148,7 @@ Undef(:u) ==
u':= LAST u
[[domain,slot],op,sig]:= u'
domain':=eval mkEvalable domain
- ^EQ(CAR ELT(domain',slot),Undef) =>
+ ^EQ(CAR ELT(domain',slot), function Undef) =>
-- OK - thefunction is now defined
[:u'',.]:=u
if $reportBottomUpFlag then
diff --git a/src/interp/pspad1.boot b/src/interp/pspad1.boot
index ce580b14..89fe6b79 100644
--- a/src/interp/pspad1.boot
+++ b/src/interp/pspad1.boot
@@ -260,7 +260,7 @@ format(x,:options) ==
qualification := IFCAR options
newCOrNil:=
x is [op,:argl] =>
- if op = 'return then argl := rest argl
+ if op = "return" then argl := rest argl
n := #argl
op is ['elt,y,"construct"] => formatDollar(y,'construct,argl)
op is ['elt,name,p] and UPPER_-CASE_-P (STRINGIMAGE opOf name).0 =>
diff --git a/src/interp/pspad2.boot b/src/interp/pspad2.boot
index e5af3357..4f5a729b 100644
--- a/src/interp/pspad2.boot
+++ b/src/interp/pspad2.boot
@@ -118,9 +118,9 @@ formatDeftranRepper([op,a],SEQflag) ==
a is ['LET,a,b] => formatDeftran(['LET,a,[op,b]],SEQflag)
a is ['not,[op,a,b]] and (op1 := LASSOC(op,$pspadRelationAlist)) =>
formatDeftran [op1,a,b]
- a is ['return,n,r] =>
+ a is ["return",n,r] =>
MEMQ(opOf r,'(true false)) => a
- ['return,n,[op,formatDeftran(r,SEQflag)]]
+ ["return",n,[op,formatDeftran(r,SEQflag)]]
a is ['error,:.] => a
[op,formatDeftran(a,SEQflag)]
diff --git a/src/interp/setq.lisp b/src/interp/setq.lisp
index 195a1c84..b1872dfc 100644
--- a/src/interp/setq.lisp
+++ b/src/interp/setq.lisp
@@ -187,7 +187,6 @@
(SETQ RPAR ")")
(SETQ SLASH "/")
(SETQ STAR "*")
-(SETQ UNDERBAR "_")
(SETQ |$fortranArrayStartingIndex| 0)
;; These were originally in INIT LISP
@@ -392,75 +391,4 @@
;; By default, don't generate info files with old compiler.
(setq |$profileCompiler| nil)
-(setq credits '(
-"An alphabetical listing of contributors to AXIOM (to October, 2006):"
-"Cyril Alberga Roy Adler Christian Aistleitner"
-"Richard Anderson George Andrews"
-"Henry Baker Stephen Balzac Yurij Baransky"
-"David R. Barton Gerald Baumgartner Gilbert Baumslag"
-"Fred Blair Vladimir Bondarenko Mark Botch"
-"Alexandre Bouyer Peter A. Broadbery Martin Brock"
-"Manuel Bronstein Florian Bundschuh Luanne Burns"
-"William Burge"
-"Quentin Carpent Robert Caviness Bruce Char"
-"Cheekai Chin David V. Chudnovsky Gregory V. Chudnovsky"
-"Josh Cohen Christophe Conil Don Coppersmith"
-"George Corliss Robert Corless Gary Cornell"
-"Meino Cramer Claire Di Crescenzo"
-"Timothy Daly Sr. Timothy Daly Jr. James H. Davenport"
-"Jean Della Dora Gabriel Dos Reis Michael Dewar"
-"Claire DiCrescendo Sam Dooley Lionel Ducos"
-"Martin Dunstan Brian Dupee Dominique Duval"
-"Robert Edwards Heow Eide-Goodman Lars Erickson"
-"Richard Fateman Bertfried Fauser Stuart Feldman"
-"Brian Ford Albrecht Fortenbacher George Frances"
-"Constantine Frangos Timothy Freeman Korrinn Fu"
-"Marc Gaetano Rudiger Gebauer Kathy Gerber"
-"Patricia Gianni Holger Gollan Teresa Gomez-Diaz"
-"Laureano Gonzalez-Vega Stephen Gortler Johannes Grabmeier"
-"Matt Grayson James Griesmer Vladimir Grinberg"
-"Oswald Gschnitzer Jocelyn Guidry"
-"Steve Hague Vilya Harvey Satoshi Hamaguchi"
-"Martin Hassner Waldek Hebisch Ralf Hemmecke"
-"Henderson Antoine Hersen"
-"Pietro Iglio"
-"Richard Jenks"
-"Kai Kaminski Grant Keady Tony Kennedy"
-"Paul Kosinski Klaus Kusche Bernhard Kutzler"
-"Larry Lambe Frederic Lehobey Michel Levaud"
-"Howard Levy Rudiger Loos Michael Lucks"
-"Richard Luczak"
-"Camm Maguire Bob McElrath Michael McGettrick"
-"Ian Meikle David Mentre Victor S. Miller"
-"Gerard Milmeister Mohammed Mobarak H. Michael Moeller"
-"Michael Monagan Marc Moreno-Maza Scott Morrison"
-"Mark Murray"
-"William Naylor C. Andrew Neff John Nelder"
-"Godfrey Nolan Arthur Norman Jinzhong Niu"
-"Michael O'Connor Kostas Oikonomou"
-"Julian A. Padget Bill Page Susan Pelzel"
-"Michel Petitot Didier Pinchon Jose Alfredo Portes"
-"Claude Quitte"
-"Norman Ramsey Michael Richardson Renaud Rioboo"
-"Jean Rivlin Nicolas Robidoux Simon Robinson"
-"Michael Rothstein Martin Rubey"
-"Philip Santas Alfred Scheerhorn William Schelter"
-"Gerhard Schneider Martin Schoenert Marshall Schor"
-"Frithjof Schulze Fritz Schwarz Nick Simicich"
-"William Sit Elena Smirnova Jonathan Steinbach"
-"Christine Sundaresan Robert Sutor Moss E. Sweedler"
-"Eugene Surowitz"
-"James Thatcher Balbir Thomas Mike Thomas"
-"Dylan Thurston Barry Trager Themos T. Tsikas"
-"Gregory Vanuxem"
-"Bernhard Wall Stephen Watt Jaap Weel"
-"Juergen Weiss M. Weller Mark Wegman"
-"James Wen Thorsten Werther Michael Wester"
-"John M. Wiley Berhard Will Clifton J. Williamson"
-"Stephen Wilson Shmuel Winograd Robert Wisbauer"
-"Sandra Wityak Waldemar Wiwianka Knut Wolf"
-"Clifford Yapp David Yun"
-"Richard Zippel Evelyn Zoernack Bruno Zuercher"
-"Dan Zwillinger"
-))
diff --git a/src/interp/spad.lisp b/src/interp/spad.lisp
index c2008754..1f8b84b0 100644
--- a/src/interp/spad.lisp
+++ b/src/interp/spad.lisp
@@ -75,7 +75,6 @@
(defvar |$kernelProtect| NIL "")
(defvar |$HiFiAccess| nil "if true maintain history file")
(defvar |$mapReturnTypes| nil)
-(defvar /TRACENAMES NIL)
(defvar INPUTSTREAM t "bogus initialization for now")
@@ -300,13 +299,6 @@
(if (zerop y) (truncate 1 Y)
(multiple-value-call #'cons (TRUNCATE X Y))))
-(defmacro APPEND2 (x y) `(append ,x ,y))
-
-(defmacro |float| (x &optional (y 0.0d0)) `(float ,x ,y))
-
-(defun |makeSF| (mantissa exponent)
- (|float| (/ mantissa (expt 2 (- exponent)))))
-
(define-function 'list1 #'list)
(define-function '|not| #'NOT)
diff --git a/src/interp/sys-globals.boot b/src/interp/sys-globals.boot
index 77644a6b..4fcc113c 100644
--- a/src/interp/sys-globals.boot
+++ b/src/interp/sys-globals.boot
@@ -407,6 +407,7 @@ _/WSNAME := "NOBOOT"
_/EDITFILE := nil
++
+LINE := nil
CHR := nil
TOK := nil
@@ -418,3 +419,6 @@ _*ANCESTORS_-HASH_* := nil
++
_*BUILD_-VERSION_* := nil
_*YEARWEEK_* := nil
+
+++
+_/TRACENAMES := nil
diff --git a/src/interp/sys-macros.lisp b/src/interp/sys-macros.lisp
index 85f5434f..3f4ac262 100644
--- a/src/interp/sys-macros.lisp
+++ b/src/interp/sys-macros.lisp
@@ -61,6 +61,12 @@
;; -*- BigFloat Constructors -*-
;;
+(defmacro |float| (x &optional (y 0.0d0))
+ `(float ,x ,y))
+
+(defun |makeSF| (mantissa exponent)
+ (|float| (/ mantissa (expt 2 (- exponent)))))
+
(defmacro MAKE-BF (MT EP)
`(CONS |$BFtag| (CONS ,MT ,EP)))
@@ -152,6 +158,10 @@
(defmacro KADDR (ARG)
`(IFCAR (IFCDR (IFCDR ,arg))))
+
+(defmacro APPEND2 (x y)
+ `(append ,x ,y))
+
(eval-when
#+:common-lisp (:compile-toplevel :load-toplevel :execute)
#-:common-lisp (compile load eval)
diff --git a/src/interp/wi2.boot b/src/interp/wi2.boot
index fddd93ca..b0142f43 100644
--- a/src/interp/wi2.boot
+++ b/src/interp/wi2.boot
@@ -565,7 +565,7 @@ compFormWithModemap1(form,m,e,modemap,Rep2Dollar?) ==
-- try to deal with new-style Unions where we know the conditions
op = "elt" and f is ['XLAM,:.] and IDENTP(z:=CAR argl) and
(c:=get(z,'condition,e)) and
- c is [['case,=z,c1]] and
+ c is [["case",=z,c1]] and
(c1 is ['_:,=(CADR argl),=m] or EQ(c1,CADR argl) ) =>
-- first is a full tag, as placed by getInverseEnvironment
-- second is what getSuccessEnvironment will place there