diff options
Diffstat (limited to 'src/interp/functor.boot')
-rw-r--r-- | src/interp/functor.boot | 84 |
1 files changed, 25 insertions, 59 deletions
diff --git a/src/interp/functor.boot b/src/interp/functor.boot index 99b45a8c..95b9ccd1 100644 --- a/src/interp/functor.boot +++ b/src/interp/functor.boot @@ -661,37 +661,26 @@ SetFunctionSlots(sig,body,flag,mode) == --mode is either "original" or "adding" for u in $catvecList for v in catNames repeat null body => return nil for catImplem in LookUpSigSlots(sig,u.1) repeat - if catImplem is [q,.,index] and (q='ELT or q='CONST) - then - if q is 'CONST and body is ['CONS,a,b] then - body := ['CONS,'IDENTITY,['FUNCALL,a,b]] - body:= ["setShellEntry",v,index,body] - if REFVECP $SetFunctions and TruthP flag then u.index:= true - --used by CheckVector to determine which ops are missing - if v='$ then -- i.e. we are looking at the principal view - not REFVECP $SetFunctions => nil - --packages don't set it - $MissingFunctionInfo.index:= flag - TruthP $SetFunctions.index => (body:= nil; return nil) - -- the function was already assigned - $SetFunctions.index:= - TruthP flag => true - not $SetFunctions.index=>flag --JHD didn't set $SF on this branch - ["or",$SetFunctions.index,flag] - else - if catImplem is ['Subsumed,:truename] - --a special marker generated by SigListUnion - then - if mode='original - then if truename is [fn,:.] and fn in '(Zero One) - then nil --hack by RDJ 8/90 - else body:= SetFunctionSlots(truename,body,nil,mode) - else nil - else - keyedSystemError("S2OR0002",[catImplem]) + catImplem is [q,.,index] and (q='ELT or q='CONST) => + if q is 'CONST and body is ['CONS,a,b] then + body := ['CONS,'IDENTITY,['FUNCALL,a,b]] + body:= ["setShellEntry",v,index,body] + if REFVECP $SetFunctions and TruthP flag then + u.index := true + v='$ => -- we are looking at the principal view + not REFVECP $SetFunctions => nil --packages don't set it + -- the function was already assigned + TruthP $SetFunctions.index => return body := nil + $SetFunctions.index := + TruthP flag => true + not $SetFunctions.index => flag + ["or",$SetFunctions.index,flag] + catImplem is ['Subsumed,:truename] => + mode='original => + truename is [fn,:.] and fn in '(Zero One) => nil --hack by RDJ 8/90 + body := SetFunctionSlots(truename,body,nil,mode) + keyedSystemError("S2OR0002",[catImplem]) body is ["setShellEntry",:.] => body - body is ['SETELT,:.] => systemErrorHere ["SetFunctionSlots",body] - body is ['QSETREFV,:.] => systemErrorHere ["SetFunctionSlots",body] nil LookUpSigSlots(sig,siglist) == @@ -704,40 +693,17 @@ LookUpSigSlots(sig,siglist) == SigSlotsMatch(sig,pattern,implem) == sig=pattern => true - not (LENGTH second sig=LENGTH second pattern) => nil + #second sig ~= # second pattern => nil --second sig is the actual signature part - not (first sig=first pattern) => nil - pat' :=SUBSTQ($definition,'$,second pattern) - sig' :=SUBSTQ($definition,'$,second sig) - sig'=pat' => true - --If we don't have this next test, then we'll recurse in SetFunctionSlots + first sig ~= first pattern => nil + pat' := substitute($definition,'$,second pattern) + sig' := substitute($definition,'$,second sig) + sig' = pat' => true implem is ['Subsumed,:.] => nil sig' = pat' -CheckVector(vec,name,catvecListMaker) == - code:= nil - condAlist := - [[a,:first b] for [.,a,:b] in $getDomainCode] - -- used as substitution alist below - for i in 6..MAXINDEX vec repeat - v:= vec.i - v=true => nil - null v => nil --a domain, which setVector4part3 will fill in - atom v => systemErrorHere ["CheckVector",v] - atom first v => - --It's a secondary view of a domain, which we - --must generate code to fill in - for x in $catNames for y in catvecListMaker repeat - if y=v then - code := [["setShellEntry",name,i,x],:code] - if name='$ then - assoc(first v,$CheckVectorList) => nil - $CheckVectorList:= - [[first v,:makeMissingFunctionEntry(condAlist,i)],:$CheckVectorList] - code - makeMissingFunctionEntry(alist,i) == - tran SUBLIS(alist,$MissingFunctionInfo.i) where + tran SUBLIS(alist,$SetFunctions.i) where tran x == x is ["HasCategory",a,["QUOTE",b]] => ["has",a,b] x is [op,:l] and op in '(AND OR NOT) => [op,:[tran y for y in l]] |