diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/boot/strap/tokens.clisp | 16 | ||||
-rw-r--r-- | src/boot/tokens.boot | 1 | ||||
-rw-r--r-- | src/interp/buildom.boot | 44 | ||||
-rw-r--r-- | src/interp/database.boot | 2 | ||||
-rw-r--r-- | src/interp/define.boot | 12 | ||||
-rw-r--r-- | src/interp/functor.boot | 10 | ||||
-rw-r--r-- | src/interp/i-coerfn.boot | 4 | ||||
-rw-r--r-- | src/interp/i-eval.boot | 14 | ||||
-rw-r--r-- | src/interp/i-funsel.boot | 2 | ||||
-rw-r--r-- | src/interp/i-output.boot | 4 | ||||
-rw-r--r-- | src/interp/i-syscmd.boot | 2 | ||||
-rw-r--r-- | src/interp/interop.boot | 10 | ||||
-rw-r--r-- | src/interp/nrunfast.boot | 19 | ||||
-rw-r--r-- | src/interp/topics.boot | 2 |
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 |