aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/Makefile.in6
-rw-r--r--src/interp/Makefile.pamphlet6
-rw-r--r--src/interp/c-util.boot4
-rw-r--r--src/interp/category.boot1
-rw-r--r--src/interp/g-opt.boot4
-rw-r--r--src/interp/g-util.boot131
-rw-r--r--src/interp/ggreater.lisp2
-rw-r--r--src/interp/i-intern.boot38
-rw-r--r--src/interp/i-output.boot20
-rw-r--r--src/interp/i-util.boot2
-rw-r--r--src/interp/parsing.lisp2
-rw-r--r--src/interp/spad.lisp4
12 files changed, 113 insertions, 107 deletions
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index 4c3441a0..8cff46d0 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -316,7 +316,7 @@ package.$(FASLEXT): clam.$(FASLEXT)
database.$(FASLEXT): clam.$(FASLEXT) nlib.$(FASLEXT) \
cattable.$(FASLEXT) compat.$(FASLEXT) g-cndata.$(FASLEXT)
functor.$(FASLEXT): category.$(FASLEXT) c-util.$(FASLEXT)
-category.$(FASLEXT): g-util.$(FASLEXT)
+category.$(FASLEXT): g-util.$(FASLEXT) g-cndata.$(FASLEXT)
cattable.$(FASLEXT): simpbool.$(FASLEXT) g-util.$(FASLEXT)
compat.$(FASLEXT): pathname.$(FASLEXT)
simpbool.$(FASLEXT): macros.$(FASLEXT)
@@ -409,12 +409,12 @@ g-timer.$(FASLEXT): macros.$(FASLEXT) g-util.$(FASLEXT)
msgdb.$(FASLEXT): g-util.$(FASLEXT)
g-boot.$(FASLEXT): def.$(FASLEXT) g-util.$(FASLEXT)
g-error.$(FASLEXT): diagnostics.$(FASLEXT) g-util.$(FASLEXT)
-c-util.$(FASLEXT): g-util.$(FASLEXT)
+c-util.$(FASLEXT): g-util.$(FASLEXT) g-opt.$(FASLEXT)
pathname.$(FASLEXT): nlib.$(FASLEXT)
hashcode.$(FASLEXT): g-util.$(FASLEXT)
pspad2.$(FASLEXT): pspad1.$(FASLEXT)
pspad1.$(FASLEXT): macros.$(FASLEXT)
-g-util.$(FASLEXT): macros.$(FASLEXT) sys-utility.$(FASLEXT)
+g-util.$(FASLEXT): ggreater.$(FASLEXT) macros.$(FASLEXT) sys-utility.$(FASLEXT)
g-cndata.$(FASLEXT): sys-macros.$(FASLEXT)
compress.$(FASLEXT): sys-macros.$(FASLEXT)
msg.$(FASLEXT): sys-macros.$(FASLEXT) astr.$(FASLEXT)
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet
index f46eab6c..af5850ae 100644
--- a/src/interp/Makefile.pamphlet
+++ b/src/interp/Makefile.pamphlet
@@ -565,7 +565,7 @@ package.$(FASLEXT): clam.$(FASLEXT)
database.$(FASLEXT): clam.$(FASLEXT) nlib.$(FASLEXT) \
cattable.$(FASLEXT) compat.$(FASLEXT) g-cndata.$(FASLEXT)
functor.$(FASLEXT): category.$(FASLEXT) c-util.$(FASLEXT)
-category.$(FASLEXT): g-util.$(FASLEXT)
+category.$(FASLEXT): g-util.$(FASLEXT) g-cndata.$(FASLEXT)
cattable.$(FASLEXT): simpbool.$(FASLEXT) g-util.$(FASLEXT)
compat.$(FASLEXT): pathname.$(FASLEXT)
simpbool.$(FASLEXT): macros.$(FASLEXT)
@@ -658,12 +658,12 @@ g-timer.$(FASLEXT): macros.$(FASLEXT) g-util.$(FASLEXT)
msgdb.$(FASLEXT): g-util.$(FASLEXT)
g-boot.$(FASLEXT): def.$(FASLEXT) g-util.$(FASLEXT)
g-error.$(FASLEXT): diagnostics.$(FASLEXT) g-util.$(FASLEXT)
-c-util.$(FASLEXT): g-util.$(FASLEXT)
+c-util.$(FASLEXT): g-util.$(FASLEXT) g-opt.$(FASLEXT)
pathname.$(FASLEXT): nlib.$(FASLEXT)
hashcode.$(FASLEXT): g-util.$(FASLEXT)
pspad2.$(FASLEXT): pspad1.$(FASLEXT)
pspad1.$(FASLEXT): macros.$(FASLEXT)
-g-util.$(FASLEXT): macros.$(FASLEXT) sys-utility.$(FASLEXT)
+g-util.$(FASLEXT): ggreater.$(FASLEXT) macros.$(FASLEXT) sys-utility.$(FASLEXT)
g-cndata.$(FASLEXT): sys-macros.$(FASLEXT)
compress.$(FASLEXT): sys-macros.$(FASLEXT)
msg.$(FASLEXT): sys-macros.$(FASLEXT) astr.$(FASLEXT)
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index 170f16f8..c0ccee94 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -33,6 +33,7 @@
import g_-util
+import g_-opt
namespace BOOT
module c_-util where
@@ -464,7 +465,8 @@ isFunction(x,e) ==
isLiteral: (%Symbol,%Env) -> %Boolean
isLiteral(x,e) ==
- get(x,"isLiteral",e)
+ get(x,"isLiteral",e) => true
+ false
makeLiteral: (%Symbol,%Env) -> %Thing
diff --git a/src/interp/category.boot b/src/interp/category.boot
index c9f56468..d9250a22 100644
--- a/src/interp/category.boot
+++ b/src/interp/category.boot
@@ -33,6 +33,7 @@
import g_-util
+import g_-cndata
namespace BOOT
--%
diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
index 7ef701c4..8bf239fe 100644
--- a/src/interp/g-opt.boot
+++ b/src/interp/g-opt.boot
@@ -379,6 +379,10 @@ optEQ u ==
-- That undoes some weird work in Boolean to do with the definition of true
u
u
+
+lispize x == first optimize [x]
+
+--% optimizer hash table
for x in '( (call optCall) _
(SEQ optSEQ)_
diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot
index a856ca2d..f06675df 100644
--- a/src/interp/g-util.boot
+++ b/src/interp/g-util.boot
@@ -32,6 +32,7 @@
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+import ggreater
import macros
import sys_-utility
namespace BOOT
@@ -61,7 +62,7 @@ PPtoFile(x, fname) ==
get: (%Thing,%Symbol,%List) -> %Thing
get0: (%Thing,%Symbol,%List) -> %Thing
get1: (%Thing,%Symbol,%List) -> %Thing
-get2: (%Thing,%Symbol,%List) -> %Thing
+get2: (%Thing,%Symbol) -> %Thing
get(x,prop,e) ==
$InteractiveMode => get0(x,prop,e)
@@ -79,27 +80,31 @@ get1(x,prop,e) ==
not atom x => get(QCAR x,prop,e)
prop="modemap" and $insideCapsuleFunctionIfTrue=true =>
LASSOC("modemap",getProplist(x,$CapsuleModemapFrame))
- or get2(x,prop,e)
- LASSOC(prop,getProplist(x,e)) or get2(x,prop,e)
+ or get2(x,prop)
+ LASSOC(prop,getProplist(x,e)) or get2(x,prop)
-get2(x,prop,e) ==
+get2(x,prop) ==
prop="modemap" and IDENTP x and constructor? x =>
(u := getConstructorModemapFromDB x) => [u]
nil
nil
++ Update properties of an entity in an environment.
-put: (%Thing,%Symbol,%Thing,%List) -> %List
-addBinding: (%Thing,%List,%List) -> %List
-augProplistOf: (%Thing,%Symbol,%Thing,%List) -> %List
-augProplist: (%List,%Thing,%Thing) -> %List
+put: (%Thing,%Symbol,%Thing,%Env) -> %Env
+addBinding: (%Thing,%List,%Env) -> %Env
+addBindingInteractive: (%Thing, %List, %Env) -> %Env
+augProplistOf: (%Thing,%Symbol,%Thing,%Env) -> %List
+augProplist: (%List,%Symbol,%Thing) -> %List
+augProplistInteractive: (%List,%Symbol,%Thing) -> %List
+putIntSymTab: (%Thing,%Symbol,%Form,%Env) -> %Env
+addIntSymTabBinding: (%Thing,%List,%Env) -> %Env
put(x,prop,val,e) ==
$InteractiveMode and not EQ(e,$CategoryFrame) =>
putIntSymTab(x,prop,val,e)
--e must never be $CapsuleModemapFrame
- null atom x => put(first x,prop,val,e)
- newProplist:= augProplistOf(x,prop,val,e)
+ not atom x => put(first x,prop,val,e)
+ newProplist := augProplistOf(x,prop,val,e)
prop="modemap" and $insideCapsuleFunctionIfTrue=true =>
SAY ["**** modemap PUT on CapsuleModemapFrame: ",val]
$CapsuleModemapFrame:=
@@ -108,6 +113,28 @@ put(x,prop,val,e) ==
e
addBinding(x,newProplist,e)
+putIntSymTab(x,prop,val,e) ==
+ null atom x => putIntSymTab(first x,prop,val,e)
+ pl0 := pl := search(x,e)
+ pl :=
+ null pl => [[prop,:val]]
+ u := ASSQ(prop,pl) =>
+ RPLACD(u,val)
+ pl
+ lp := LASTPAIR pl
+ u := [[prop,:val]]
+ RPLACD(lp,u)
+ pl
+ EQ(pl0,pl) => e
+ addIntSymTabBinding(x,pl,e)
+
+addIntSymTabBinding(var,proplist,e is [[curContour,:.],:.]) ==
+ -- change proplist of var in e destructively
+ u := ASSQ(var,curContour) =>
+ RPLACD(u,proplist)
+ e
+ RPLAC(CAAR e,[[var,:proplist],:curContour])
+ e
--% Syntax manipulation
@@ -315,7 +342,7 @@ dropLeadingBlanks str ==
nb := NIL
i := 0
while (i < l) and not nb repeat
- if SCHAR(str,i) ^= " " then nb := i
+ if SCHAR(str,i) ^= char " " then nb := i
else i := i + 1
nb = 0 => str
nb => SUBSTRING(str,nb,NIL)
@@ -493,10 +520,10 @@ formatUnabbreviatedTuple t ==
[:t0,'",",:formatUnabbreviatedTuple QCDR t]
formatUnabbreviated t ==
- atom t =>
- [t]
null t =>
['"()"]
+ atom t =>
+ [t]
t is [p,sel,arg] and p = ":" =>
[sel,'": ",:formatUnabbreviated arg]
t is ['Union,:args] =>
@@ -526,36 +553,16 @@ sublisNQ(al,e) ==
EQ(a,u) and EQ(rest e,v) => e
[u,:v]
--- function for turning strings in tex format
-
-str2Outform s ==
- parse := ncParseFromString s or systemError '"String for TeX will not parse"
- parse2Outform parse
-
-parse2Outform x ==
- x is [op,:argl] =>
- nargl := [parse2Outform y for y in argl]
- op = 'construct => ['BRACKET,['ARGLST,:[parse2Outform y for y in argl]]]
- op = 'brace and nargl is [[BRACKET,:r]] => ['BRACE,:r]
- [op,:nargl]
- x
-
-str2Tex s ==
- outf := str2Outform s
- val := coerceInt(objNew(wrap outf, '(OutputForm)), '(TexFormat))
- val := objValUnwrap val
- CAR val.1
-
opOf: %Thing -> %Thing
opOf x ==
atom x => x
first x
-getProplist: (%Thing,%List) -> %List
-search: (%Thing,%List) -> %List
+getProplist: (%Thing,%Env) -> %List
+search: (%Thing,%Env) -> %List
searchCurrentEnv: (%Thing,%List) -> %List
-searchTailEnv: (%Thing,%List) -> %List
+searchTailEnv: (%Thing,%Env) -> %List
getProplist(x,E) ==
not atom x => getProplist(first x,E)
@@ -610,6 +617,20 @@ addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) ==
--Previous line should save some space
[[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist]
+addBindingInteractive(var,proplist,e is [[curContour,:.],:.]) ==
+ -- change proplist of var in e destructively
+ u := ASSQ(var,curContour) =>
+ RPLACD(u,proplist)
+ e
+ RPLAC(CAAR e,[[var,:proplist],:curContour])
+ e
+
+augProplistInteractive(proplist,prop,val) ==
+ u := ASSQ(prop,proplist) =>
+ RPLACD(u,val)
+ proplist
+ [[prop,:val],:proplist]
+
position(x,l) ==
posn(x,l,0) where
posn(x,l,n) ==
@@ -627,7 +648,7 @@ after(u,v) ==
r
-$blank := char ('_ )
+$blank == char ('_ )
trimString s ==
leftTrim rightTrim s
@@ -695,24 +716,24 @@ $exposeFlag := false --if true, messages go to $outStream
$exposeFlagHeading := false --see htcheck.boot
$checkingXmptex? := false --see htcheck.boot
$exposeDocHeading:= nil --see htcheck.boot
-$charPlus := char '_+
-$charBlank:= (char '_ )
-$charLbrace:= char '_{
-$charRbrace:= char '_}
-$charBack := char '_\
-$charDash := char '_-
-
-$charTab := CODE_-CHAR(9)
-$charNewline := CODE_-CHAR(10)
-$charFauxNewline := CODE_-CHAR(25)
-$stringNewline := PNAME CODE_-CHAR(10)
-$stringFauxNewline := PNAME CODE_-CHAR(25)
-
-$charExclusions := [char 'a, char 'A]
-$charQuote := char '_'
-$charSemiColon := char '_;
-$charComma := char '_,
-$charPeriod := char '_.
+$charPlus == char '_+
+$charBlank == (char '_ )
+$charLbrace == char '_{
+$charRbrace == char '_}
+$charBack == char '_\
+$charDash == char '_-
+
+$charTab == CODE_-CHAR(9)
+$charNewline == CODE_-CHAR(10)
+$charFauxNewline == CODE_-CHAR(25)
+$stringNewline == PNAME CODE_-CHAR(10)
+$stringFauxNewline == PNAME CODE_-CHAR(25)
+
+$charExclusions == [char 'a, char 'A]
+$charQuote == char '_'
+$charSemiColon == char '_;
+$charComma == char '_,
+$charPeriod == char '_.
$checkPrenAlist := [[char '_(,:char '_)],[char '_{,:char '_}],[char '_[,:char '_]]]
$charEscapeList:= [char '_%,char '_#,$charBack]
$charIdentifierEndings := [char '__, char '_!, char '_?]
diff --git a/src/interp/ggreater.lisp b/src/interp/ggreater.lisp
index c27ff31e..81d7ca60 100644
--- a/src/interp/ggreater.lisp
+++ b/src/interp/ggreater.lisp
@@ -204,5 +204,7 @@
(defvar SORTGREATERP #'GGREATERP "default sorting predicate")
+(defun GLESSEQP (X Y) (NOT (GGREATERP X Y)))
+(defun LEXLESSEQP (X Y) (NOT (LEXGREATERP X Y)))
diff --git a/src/interp/i-intern.boot b/src/interp/i-intern.boot
index 20a066fd..9f78f6d8 100644
--- a/src/interp/i-intern.boot
+++ b/src/interp/i-intern.boot
@@ -417,20 +417,6 @@ getValueFromSpecificEnvironment(id,mode,e) ==
$failure
$failure
-addBindingInteractive(var,proplist,e is [[curContour,:.],:.]) ==
- -- change proplist of var in e destructively
- u := ASSQ(var,curContour) =>
- RPLACD(u,proplist)
- e
- RPLAC(CAAR e,[[var,:proplist],:curContour])
- e
-
-augProplistInteractive(proplist,prop,val) ==
- u := ASSQ(prop,proplist) =>
- RPLACD(u,val)
- proplist
- [[prop,:val],:proplist]
-
getFlag x == get("--flags--",x,$e)
putFlag(flag,value) ==
@@ -465,30 +451,6 @@ fastSearchCurrentEnv(x,currentEnv) ==
while (currentEnv:= QCDR currentEnv) repeat
u:= QLASSQ(x,CAR currentEnv) => u
-putIntSymTab(x,prop,val,e) ==
- null atom x => putIntSymTab(first x,prop,val,e)
- pl0 := pl := search(x,e)
- pl :=
- null pl => [[prop,:val]]
- u := ASSQ(prop,pl) =>
- RPLACD(u,val)
- pl
- lp := LASTPAIR pl
- u := [[prop,:val]]
- RPLACD(lp,u)
- pl
- EQ(pl0,pl) => e
- addIntSymTabBinding(x,pl,e)
-
-addIntSymTabBinding(var,proplist,e is [[curContour,:.],:.]) ==
- -- change proplist of var in e destructively
- u := ASSQ(var,curContour) =>
- RPLACD(u,proplist)
- e
- RPLAC(CAAR e,[[var,:proplist],:curContour])
- e
-
-
transformCollect [:itrl,body] ==
-- syntactic transformation for COLLECT form, called from mkAtree1
iterList:=[:iterTran1 for it in itrl] where iterTran1() ==
diff --git a/src/interp/i-output.boot b/src/interp/i-output.boot
index 2a625592..be25b4ac 100644
--- a/src/interp/i-output.boot
+++ b/src/interp/i-output.boot
@@ -2677,3 +2677,23 @@ inputForm2String x ==
inputForm2OutputForm x ==
INTERN inputForm2String x
+-- function for turning strings in tex format
+
+str2Outform s ==
+ parse := ncParseFromString s or systemError '"String for TeX will not parse"
+ parse2Outform parse
+
+parse2Outform x ==
+ x is [op,:argl] =>
+ nargl := [parse2Outform y for y in argl]
+ op = 'construct => ['BRACKET,['ARGLST,:[parse2Outform y for y in argl]]]
+ op = 'brace and nargl is [[BRACKET,:r]] => ['BRACE,:r]
+ [op,:nargl]
+ x
+
+str2Tex s ==
+ outf := str2Outform s
+ val := coerceInt(objNew(wrap outf, '(OutputForm)), '(TexFormat))
+ val := objValUnwrap val
+ CAR val.1
+
diff --git a/src/interp/i-util.boot b/src/interp/i-util.boot
index dac2c3d8..8107c37b 100644
--- a/src/interp/i-util.boot
+++ b/src/interp/i-util.boot
@@ -190,8 +190,6 @@ isCapitalWord x ==
--------------------> NEW DEFINITION (see interop.boot.pamphlet)
domainEqual(a,b) == VECP a and VECP b and a.0 = b.0
-lispize x == first optimize [x]
-
$newCompilerUnionFlag := true
orderUnionEntries l ==
diff --git a/src/interp/parsing.lisp b/src/interp/parsing.lisp
index 7a45c658..56ef77ea 100644
--- a/src/interp/parsing.lisp
+++ b/src/interp/parsing.lisp
@@ -381,7 +381,7 @@ the stack, then stack a NIL. Return the value of prod."
(mapcar #'(lambda (x) (internl metapfx (pname x)))
(assocleft rs))))
n unpfx-funlist)
- (set flnam pfx-funlist)
+ (|setDynamicBinding| flnam pfx-funlist)
(if (not (lessp (setq n (length metapfx)) 0))
(setq unpfx-funlist
(mapcar #'(lambda (x)
diff --git a/src/interp/spad.lisp b/src/interp/spad.lisp
index e6d174dc..e50af9c6 100644
--- a/src/interp/spad.lisp
+++ b/src/interp/spad.lisp
@@ -393,10 +393,6 @@
(|incrementTimeSum| ,oldkey)
(return ,val)))))
-(defun GLESSEQP (X Y) (NOT (GGREATERP X Y)))
-
-(defun LEXLESSEQP (X Y) (NOT (LEXGREATERP X Y)))
-
(defun SETELTFIRST (A B C) (declare (ignore b)) (RPLACA A C))
(defun SETELTREST (A B C) (declare (ignore b)) (RPLACD A C))
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-06 01:26:27 +0000