aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/boot/strap/tokens.clisp16
-rw-r--r--src/boot/tokens.boot1
-rw-r--r--src/interp/buildom.boot44
-rw-r--r--src/interp/database.boot2
-rw-r--r--src/interp/define.boot12
-rw-r--r--src/interp/functor.boot10
-rw-r--r--src/interp/i-coerfn.boot4
-rw-r--r--src/interp/i-eval.boot14
-rw-r--r--src/interp/i-funsel.boot2
-rw-r--r--src/interp/i-output.boot4
-rw-r--r--src/interp/i-syscmd.boot2
-rw-r--r--src/interp/interop.boot10
-rw-r--r--src/interp/nrunfast.boot19
-rw-r--r--src/interp/topics.boot2
14 files changed, 64 insertions, 78 deletions
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index e31ba528..7a5a473e 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -217,11 +217,12 @@
(LIST '|charString| 'STRING)
(LIST '|char?| 'CHARACTERP)
(LIST '|codePoint| 'CHAR-CODE) (LIST '|cons?| 'CONSP)
- (LIST '|copy| 'COPY) (LIST '|croak| 'CROAK)
- (LIST '|digit?| 'DIGIT-CHAR-P) (LIST '|drop| 'DROP)
- (LIST '|exit| 'EXIT) (LIST '|false| 'NIL)
- (LIST '|first| 'CAR) (LIST '|float?| 'FLOATP)
- (LIST '|fourth| 'CADDDR) (LIST '|function| 'FUNCTION)
+ (LIST '|copy| 'COPY) (LIST '|copyTree| 'COPY-TREE)
+ (LIST '|croak| 'CROAK) (LIST '|digit?| 'DIGIT-CHAR-P)
+ (LIST '|drop| 'DROP) (LIST '|exit| 'EXIT)
+ (LIST '|false| 'NIL) (LIST '|first| 'CAR)
+ (LIST '|float?| 'FLOATP) (LIST '|fourth| 'CADDDR)
+ (LIST '|function| 'FUNCTION)
(LIST '|function?| 'FUNCTIONP)
(LIST '|gensym| 'GENSYM) (LIST '|genvar| 'GENVAR)
(LIST '|integer?| 'INTEGERP) (LIST 'LAST '|last|)
@@ -232,8 +233,9 @@
(LIST '|newString| 'MAKE-STRING)
(LIST '|newVector| 'MAKE-ARRAY) (LIST '|nil| NIL)
(LIST '|not| 'NOT) (LIST '|null| 'NULL)
- (LIST '|or| 'OR) (LIST '|otherwise| 'T)
- (LIST '|property| 'GET) (LIST '|readByte| 'READ-BYTE)
+ (LIST '|odd?| 'ODDP) (LIST '|or| 'OR)
+ (LIST '|otherwise| 'T) (LIST '|property| 'GET)
+ (LIST '|readByte| 'READ-BYTE)
(LIST '|readInteger| 'PARSE-INTEGER)
(LIST '|readLine| 'READ-LINE)
(LIST '|readLispFromString| 'READ-FROM-STRING)
diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot
index 2c1a810d..6a73af4c 100644
--- a/src/boot/tokens.boot
+++ b/src/boot/tokens.boot
@@ -288,6 +288,7 @@ for i in [ _
["nil" ,NIL ] , _
["not", "NOT"] , _
["null", "NULL"] , _
+ ["odd?", "ODDP"] , _
["or", "OR"] , _
["otherwise", "T"] , _
["property", "GET"] , _
diff --git a/src/interp/buildom.boot b/src/interp/buildom.boot
index 2e4a535c..d16f5d73 100644
--- a/src/interp/buildom.boot
+++ b/src/interp/buildom.boot
@@ -109,11 +109,11 @@ compareSig(sig,tableSig,dollar,domain) ==
lazyCompareSigEqual(s,tslot,dollar,domain) ==
tslot is '$ => s is "$" or s = devaluate dollar
- integer? tslot and cons?(lazyt:=domain.tslot) and cons? s =>
- lazyt is [.,.,.,[.,item,.]] and
- item is [.,[functorName,:.]] and functorName = first s =>
- compareSigEqual(s,canonicalForm evalDomain lazyt,dollar,domain)
- nil
+ integer? tslot and cons?(lazyt := domainRef(domain,tslot)) and cons? s =>
+ lazyt is [.,.,.,[.,item,.]] and
+ item is [.,[functorName,:.]] and functorName = s.op =>
+ compareSigEqual(s,canonicalForm evalDomain lazyt,dollar,domain)
+ nil
compareSigEqual(s,NRTreplaceLocalTypes(tslot,domain),dollar,domain)
@@ -175,7 +175,7 @@ lookupInDomainAndDefaults(op,sig,domain,dollar,useDefaults) ==
basicLookup(op,sig,domain,dollar) ==
- item := domain.1
+ item := domainRef(domain,1)
cons? item and first item in '(lookupInDomain lookupInTable) =>
lookupInDomainVector(op,sig,domain,dollar)
----------new world code follows------------
@@ -184,12 +184,10 @@ basicLookup(op,sig,domain,dollar) ==
compiledLookupCheck(op,sig,dollar) ==
fn := compiledLookup(op,sig,dollar)
-
-- NEW COMPILER COMPATIBILITY ON
if (fn = nil) and (op = "**") then
fn := compiledLookup("^",sig,dollar)
-- NEW COMPILER COMPATIBILITY OFF
-
fn = nil =>
keyedSystemError("S2NR0001",[op,formatSignature sig,canonicalForm dollar])
fn
@@ -203,11 +201,11 @@ goGet(:l) ==
[[.,[op,initSig,:code]],thisDomain] := env
domainSlot := code quo 8192
code1 := code rem 8192
- if QSODDP code1 then isConstant := true
+ isConstant := odd? code1
code2 := code1 quo 2
- if QSODDP code2 then explicitLookupDomainIfTrue := true
+ explicitLookupDomainIfTrue := odd? code2
index := code2 quo 2
- kind := (isConstant = true => 'CONST; 'ELT)
+ kind := (isConstant => 'CONST; 'ELT)
sig := [NRTreplaceLocalTypes(s,thisDomain) for s in initSig]
sig := substDomainArgs(thisDomain,sig)
lookupDomain :=
@@ -218,25 +216,25 @@ goGet(:l) ==
explicitLookupDomainIfTrue => lookupDomain
thisDomain
if cons? dollar then dollar := evalDomain dollar
- fn:= basicLookup(op,sig,lookupDomain,dollar)
- fn = nil => keyedSystemError("S2NR0001",[op,sig,lookupDomain.0])
- val:= apply(first fn,[:arglist,rest fn])
+ fn := basicLookup(op,sig,lookupDomain,dollar)
+ fn = nil => keyedSystemError("S2NR0001",[op,sig,canonicalForm lookupDomain])
+ val := apply(first fn,[:arglist,rest fn])
domainRef(thisDomain,index) := fn
val
NRTreplaceLocalTypes(t,dom) ==
- atom t =>
- not integer? t => t
- t:= domainRef(dom,t)
- if cons? t then t := evalDomain t
- canonicalForm t
- first t in '(Mapping Union Record _:) =>
- [first t,:[NRTreplaceLocalTypes(x,dom) for x in rest t]]
- t
+ atom t =>
+ not integer? t => t
+ t := domainRef(dom,t)
+ if cons? t then t := evalDomain t
+ canonicalForm t
+ t.op is ":" or builtinConstructor? t.op =>
+ [t.op,:[NRTreplaceLocalTypes(x,dom) for x in t.args]]
+ t
substDomainArgs(domain,object) ==
form := devaluate domain
- applySubst(pairList(["$$",:$FormalMapVariableList],[form,:rest form]),object)
+ applySubst(pairList(["$$",:$FormalMapVariableList],[form,:form.args]),object)
--=======================================================
-- Category Default Lookup (from goGet or lookupInAddChain)
diff --git a/src/interp/database.boot b/src/interp/database.boot
index 787fb40d..c7c068b0 100644
--- a/src/interp/database.boot
+++ b/src/interp/database.boot
@@ -745,7 +745,7 @@ isExposedConstructor name ==
-- slot 1: list of constructors explicitly exposed
-- slot 2: list of constructors explicitly hidden
-- check if it is explicitly hidden
- name in '(Union Record Mapping) => true
+ builtinConstructor? name => true
symbolMember?(name,$localExposureData.2) => false
-- check if it is explicitly exposed
symbolMember?(name,$localExposureData.1) => true
diff --git a/src/interp/define.boot b/src/interp/define.boot
index 6bbe42e1..955d3ea8 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -291,6 +291,7 @@ getExportCategory form ==
[op,:argl] := form
op is 'Record => ['RecordCategory,:argl]
op is 'Union => ['UnionCategory,:argl]
+ op is 'Enumeration => ['EnumerationCategory,:argl]
functorModemap := getConstructorModemapFromDB op
[[.,target,:tl],:.] := functorModemap
applySubst(pairList($FormalMapVariableList,argl),target)
@@ -366,9 +367,8 @@ substSlotNumbers(form,template,domain) ==
expandType(lazyt,template,domform) ==
atom lazyt => expandTypeArgs(lazyt,template,domform)
[functorName,:argl] := lazyt
- functorName in '(Record Union) and first argl is [":",:.] =>
- [functorName,:[['_:,tag,expandTypeArgs(dom,template,domform)]
- for [.,tag,dom] in argl]]
+ functorName is ":" =>
+ [functorName,first argl,expandTypeArgs(second argl,template,domform)]
lazyt is ['local,x] =>
n := POSN1(x,$FormalMapVariableList)
domform.(1 + n)
@@ -1634,10 +1634,8 @@ registerInlinableDomain(x,e) ==
x := macroExpand(x,e)
x is [ctor,:.] =>
constructor? ctor => nominateForInlining ctor
- ctor = 'Record or ctor = 'Union =>
- x.args is [['_:,:.],:.] =>
- for [.,.,t] in x.args repeat
- registerInlinableDomain(t,e)
+ ctor is ":" => registerInlinableDomain(third x,e)
+ builtinFunctorName? ctor =>
for t in x.args repeat
registerInlinableDomain(t,e)
nil
diff --git a/src/interp/functor.boot b/src/interp/functor.boot
index 9377aa33..730de440 100644
--- a/src/interp/functor.boot
+++ b/src/interp/functor.boot
@@ -198,10 +198,10 @@ compCategories u ==
atom u => u
cons? first u =>
error ['"compCategories: need an atom in operator position", first u]
- first u = "Record" =>
+ first u is "Record" =>
-- There is no modemap property for these guys so do it by hand.
[first u, :[[":", a.1, compCategories1(a.2,$SetCategory)] for a in rest u]]
- first u = "Union" or first u = "Mapping" =>
+ first u in '(Union Mapping) =>
-- There is no modemap property for these guys so do it by hand.
[first u, :[compCategories1(a,$SetCategory) for a in rest u]]
u is ['SubDomain,D,.] => compCategories D
@@ -377,10 +377,8 @@ mkDomainFormer x ==
mkTypeForm x ==
atom x => mkDevaluate x
x.op in '(CATEGORY mkCategory) => MKQ x
- x is ['_:,selector,dom] =>
- ['%list,MKQ '_:,MKQ selector,mkTypeForm dom]
- x.op is 'Record =>
- ['%list,MKQ 'Record,:[mkTypeForm y for y in x.args]]
+ x is [":",selector,dom] =>
+ ['%list,MKQ ":",MKQ selector,mkTypeForm dom]
x.op is '%call => ['MKQ, optCall x]
--The previous line added JHD/BMT 20/3/84
--Necessary for proper compilation of DPOLY SPAD
diff --git a/src/interp/i-coerfn.boot b/src/interp/i-coerfn.boot
index ec19d8fd..9631505f 100644
--- a/src/interp/i-coerfn.boot
+++ b/src/interp/i-coerfn.boot
@@ -546,11 +546,11 @@ Complex2Expr(u, source is [.,S], target is [., T]) ==
I2EI(n,source,target) ==
n = '_$fromCoerceable_$ => nil
- if not ODDP(n) then n else coercionFailure()
+ if not odd? n then n else coercionFailure()
I2OI(n,source,target) ==
n = '_$fromCoerceable_$ => nil
- if ODDP(n) then n else coercionFailure()
+ if odd? n then n else coercionFailure()
I2PI(n,source,target) ==
n = '_$fromCoerceable_$ => nil
diff --git a/src/interp/i-eval.boot b/src/interp/i-eval.boot
index 6eb520b2..a4fc8e3b 100644
--- a/src/interp/i-eval.boot
+++ b/src/interp/i-eval.boot
@@ -94,18 +94,12 @@ evaluateType0 form ==
bottomUp form'
objVal getValue(form')
form is [op,:argl] =>
- op='CATEGORY =>
+ op in '(Enumeration EnumerationCategory) => form
+ op is 'CATEGORY =>
argl is [x,:sigs] => [op,x,:[evaluateSignature(s) for s in sigs]]
form
- op in '(Join Mapping) =>
- [op,:[evaluateType arg for arg in argl]]
- op='Union =>
- argl and first argl is [x,.,.] and member(x,'(_: Declare)) =>
- [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]]
- [op,:[evaluateType arg for arg in argl]]
- op='Record =>
- [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]]
- op='Enumeration => form
+ op is ":" => [op,first argl,evaluateType second argl]
+ builtinConstructor? op => [op,:[evaluateType arg for arg in argl]]
constructor? op => evaluateType1 form
nil
IDENTP form and niladicConstructorFromDB form => evaluateType [form]
diff --git a/src/interp/i-funsel.boot b/src/interp/i-funsel.boot
index ffdea965..0b294caa 100644
--- a/src/interp/i-funsel.boot
+++ b/src/interp/i-funsel.boot
@@ -704,7 +704,7 @@ findCommonSigInDomain(opName,dom,nargs) ==
-- number of arguments. If no matches, returns nil. Otherwise returns
-- a "signature" where a type position is non-nil only if all
-- signatures shares that type .
- first(dom) in '(Union Record Mapping) => nil
+ dom.op in '(Union Record Mapping) => nil
mmList := ASSQ(opName,getConstructorOperationsFromDB dom.op)
mmList := subCopy(mmList,constructSubst dom)
null mmList => nil
diff --git a/src/interp/i-output.boot b/src/interp/i-output.boot
index 0228b609..397f76c6 100644
--- a/src/interp/i-output.boot
+++ b/src/interp/i-output.boot
@@ -1642,9 +1642,9 @@ outputDomainConstructor form ==
getOutputAbbreviatedForm form ==
form is [op,:argl] =>
- op in '(Union Record) => outputDomainConstructor form
op is "Mapping" => formatMapping argl
- u:= getConstructorAbbreviationFromDB op or op
+ builtinConstructor? op => outputDomainConstructor form
+ u := getConstructorAbbreviationFromDB op or op
null argl => u
ml:= getPartialConstructorModemapSig(op)
argl:= [fn for x in argl for m in ml] where fn() ==
diff --git a/src/interp/i-syscmd.boot b/src/interp/i-syscmd.boot
index 5f7b0b1c..b206f23c 100644
--- a/src/interp/i-syscmd.boot
+++ b/src/interp/i-syscmd.boot
@@ -236,7 +236,7 @@ abbreviationsSpad2Cmd l ==
abbQuery(key)
type is 'remove =>
DELDATABASE(key,'ABBREVIATION)
- ODDP # al => sayKeyedMsg("S2IZ0002",[type])
+ odd? # al => sayKeyedMsg("S2IZ0002",[type])
repeat
null al => return 'fromLoop
[a,b,:al] := al
diff --git a/src/interp/interop.boot b/src/interp/interop.boot
index bae1c4d3..742d1546 100644
--- a/src/interp/interop.boot
+++ b/src/interp/interop.boot
@@ -605,9 +605,7 @@ HasAttribute(domain,attrib) ==
-- getDomainHash domain added on 4/01/94 by RSS
basicLookup("%%",hashType(attrib, hashPercent),domain,domain)
HasAttribute(CDDR domain, attrib)
--->
- isNewWorldDomain domain => newHasAttribute(domain,attrib)
---+
+ integer? domainRef(domain,3) => newHasAttribute(domain,attrib)
(u := LASSOC(attrib,domain.2)) and lookupPred(first u,domain,domain)
newHasAttribute(domain,attrib) ==
@@ -658,9 +656,9 @@ HasCategory(domain,catform') ==
basicLookup("%%",catform',domain,domain)
HasCategory(CDDR domain, catform')
catform:= devaluate catform'
- isNewWorldDomain domain => newHasCategory(domain,catform)
- domain0:=domain.0 -- handles old style domains, Record, Union etc.
- slot4 := domain.4
+ integer? domainRef(domain,3) => newHasCategory(domain,catform)
+ domain0 := canonicalForm domain -- handles old style domains, Record, Union etc.
+ slot4 := domainRef(domain,4)
catlist := slot4.1
member(catform,catlist) or
opOf(catform) in '(Object Type) or --temporary hack
diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot
index 745d8cae..9fcdd17a 100644
--- a/src/interp/nrunfast.boot
+++ b/src/interp/nrunfast.boot
@@ -60,16 +60,13 @@ initNewWorld() ==
$updateCatTableIfTrue := false
$doNotCompressHashTableIfTrue := true
-isNewWorldDomain domain ==
- integer? domainRef(domain,3) --see HasCategory/Attribute
-
getDomainByteVector dom ==
- CDDR vectorRef(dom,4)
+ CDDR domainRef(dom,4)
++ Return the sequence of categories `dom' belongs to, as a vector
++ of lazy category forms.
getDomainCategoriesVector dom ==
- second vectorRef(dom,4)
+ second domainRef(dom,4)
++ Same as getDomainCategoriesVector except that we return a list of
++ input forms for the categories.
@@ -132,7 +129,7 @@ replaceGoGetSlot env ==
goGetDomainSlotIndex := arrayRef(bytevec,index := index + 1)
goGetDomain :=
goGetDomainSlotIndex = 0 => thisDomain
- vectorRef(thisDomain,goGetDomainSlotIndex)
+ domainRef(thisDomain,goGetDomainSlotIndex)
if cons? goGetDomain then
goGetDomain := lazyDomainSet(goGetDomain,thisDomain,goGetDomainSlotIndex)
sig :=
@@ -151,7 +148,7 @@ replaceGoGetSlot env ==
keyedSystemError("S2NR0001",[op,sig,goGetDomain.0])
if $monitorNewWorld then
sayLooking1(['"goget stuffing slot",:bright thisSlot,'"of "],thisDomain)
- vectorRef(thisDomain,thisSlot) := slot
+ domainRef(thisDomain,thisSlot) := slot
if $monitorNewWorld then
sayLooking1('"<------",[first slot,:devaluate rest slot])
slot
@@ -280,7 +277,7 @@ newLookupInCategories(op,sig,dom,dollar) ==
packageVec := first slot4
--the next three lines can go away with new category world
varList := ['$,:$FormalMapVariableList]
- valueList := [dom,:[vectorRef(dom,5+i) for i in 1..(# rest dom.0)]]
+ valueList := [dom,:[domainRef(dom,5+i) for i in 1..(# rest dom.0)]]
valueList := [MKQ val for val in valueList]
nsig := MSUBST(canonicalForm dom,canonicalForm dollar,sig)
for i in 0..maxIndex packageVec |
@@ -438,7 +435,7 @@ lazyMatchArg2(s,a,dollar,domain,typeFlag) ==
-- a = 0 => return true --needed only if extra call in newGoGet to basicLookup
s := devaluate dollar -- calls from HasCategory can have $s
integer? a =>
- not typeFlag => s = vectorRef(domain,a)
+ not typeFlag => s = domainRef(domain,a)
a = 6 and $isDefaultingPackage => s = devaluate dollar
vector? (d := domainVal(dollar,domain,a)) =>
s = d.0 => true
@@ -568,7 +565,7 @@ newExpandLocalTypeArgs(u,dollar,domain,typeFlag) ==
u is '$ => u
integer? u =>
typeFlag => newExpandTypeSlot(u, dollar,domain)
- vectorRef(domain,u)
+ domainRef(domain,u)
u is ['NRTEVAL,y] => nrtEval(y,domain)
u is ['QUOTE,y] => y
u is "$$" => canonicalForm domain
@@ -583,7 +580,7 @@ domainVal(dollar,domain,index) ==
--returns a domain or a lazy slot
index = 0 => dollar
index = 2 => domain
- vectorRef(domain,index)
+ domainRef(domain,index)
-- ??? This function should be merged into the preceding one.
sigDomainVal(dollar,domain,index) ==
diff --git a/src/interp/topics.boot b/src/interp/topics.boot
index 36459714..c3910973 100644
--- a/src/interp/topics.boot
+++ b/src/interp/topics.boot
@@ -223,7 +223,7 @@ topics con ==
code2Classes cc ==
cc := 2*cc
- [x while cc ~= 0 for x in $topicClasses | ODDP (cc := cc quo 2)]
+ [x while cc ~= 0 for x in $topicClasses | odd? (cc := cc quo 2)]
myLastAtom x ==
while x is [.,:x] repeat nil
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-01 08:36:46 +0000