-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2008, 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 -- met: -- -- - Redistributions of source code must retain the above copyright -- notice, this list of conditions and the following disclaimer. -- -- - Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in -- the documentation and/or other materials provided with the -- distribution. -- -- - Neither the name of The Numerical Algorithms Group Ltd. nor the -- names of its contributors may be used to endorse or promote products -- derived from this software without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. import '"g-util" )package "BOOT" -- Functions for building categories CategoryPrint(D,$e) == SAY "--------------------------------------" SAY "Name (and arguments) of category:" PRETTYPRINT D.(0) SAY "operations:" PRETTYPRINT D.(1) SAY "attributes:" PRETTYPRINT D.2 SAY "This is a sub-category of" PRETTYPRINT first D.4 for u in CADR D.4 repeat SAY("This has an alternate view: slot ",rest u," corresponds to ",first u) for u in CADDR D.4 repeat SAY("This has a local domain: slot ",rest u," corresponds to ",first u) for j in 6..MAXINDEX D repeat u:= D.j null u => SAY "another domain" atom first u => SAY("Alternate View corresponding to: ",u) PRETTYPRINT u mkCategory(domainOrPackage,sigList,attList,domList,PrincipalAncestor) == NSigList:= nil if PrincipalAncestor=nil then count:= 6 else count:= SIZE PrincipalAncestor sigList:= [if s is [sig,pred] then or/[x is [[ =sig,.,:impl],:num] for x in NSigList] => [sig,pred,:impl] --only needed for multiple copies of sig num:= if domainOrPackage="domain" then count else count-5 nsig:= mkOperatorEntry("domain",sig,pred,num) NSigList:= [[nsig,:count],:NSigList] count:= count+1 nsig else s for s in sigList] NewLocals:= nil for s in sigList repeat NewLocals:= union(NewLocals,Prepare CADAR s) where Prepare u == "union"/[Prepare2 v for v in u] Prepare2 v == v is "$" => nil STRINGP v => nil atom v => [v] MEMQ(first v,$PrimitiveDomainNames) => nil --This variable is set in INIT LISP --It is a list of all the domains that we need not cache v is ["Union",:w] => "union"/[Prepare2 x for x in stripUnionTags w] v is ["Mapping",:w] => "union"/[Prepare2 x for x in w] v is ["List",w] => Prepare2 w v is ["Record",.,:w] => "union"/[Prepare2 CADDR x for x in w] [v] OldLocals:= nil if PrincipalAncestor then for u in (OldLocals:= CADDR PrincipalAncestor.4) repeat NewLocals:= delete(first u,NewLocals) for u in NewLocals repeat (OldLocals:= [[u,:count],:OldLocals]; count:= count+1) v:= newShell count v.(0):= nil v.(1):= sigList v.2:= attList v.3:= ["Category"] if not PrincipalAncestor=nil then for x in 6..SIZE PrincipalAncestor-1 repeat v.x:= PrincipalAncestor.x v.4:= [first PrincipalAncestor.4,CADR PrincipalAncestor.4,OldLocals] else v.4:= [nil,nil,OldLocals] --associated categories and domains v.5:= domList for [nsig,:sequence] in NSigList repeat v.sequence:= nsig v isCategory a == REFVECP a and #a>5 and a.3=["Category"] --% Subsumption code (for operators) DropImplementations (a is [sig,pred,:implem]) == if implem is [[q,:.]] and (q="ELT" or q="CONST") then if (q="ELT") then [sig,pred] else [[:sig,:'(constant)],pred] else a SigListUnion(extra,original) == --augments original %with everything in extra that is not in original for (o:=[[ofn,osig,:.],opred,:.]) in original repeat -- The purpose of this loop is to detect cases when the -- original list contains, e.g. ** with NonNegativeIntegers, and -- the extra list would like to add ** with PositiveIntegers. -- The PI map is therefore gives an implementation of "Subsumed" for x in SigListOpSubsume(o,extra) repeat [[xfn,xsig,:.],xpred,:.]:=x xfn=ofn and xsig=osig => --checking name and signature, but not a 'constant' marker xpred=opred => extra:= delete(x,extra) --same signature and same predicate opred = true => extra:= delete(x,extra) -- PRETTYPRINT ("we ought to subsume",x,o) not MachineLevelSubsume(QCAR o,QCAR x) => '"Source level subsumption not implemented" extra:= delete(x,extra) for e in extra repeat [esig,epred,:.]:= e eimplem:=[] for x in SigListOpSubsume(e,original) repeat --PRETTYPRINT(LIST("SigListOpSubsume",e,x)) not MachineLevelSubsume(QCAR e,QCAR x) => --systemError '"Source level subsumption not implemented" original:= [e,:original] return nil -- this exits from the innermost for loop original:= delete(x,original) [xsig,xpred,:ximplem]:= x -- if xsig ^= esig then -- not quite strong enough if CAR xsig ^= CAR esig or CADR xsig ^= CADR esig then -- the new version won't get confused by "constant"markers if ximplem is [["Subsumed",:.],:.] then original := [x,:original] else original:= [[xsig,xpred,["Subsumed",:esig]],:original] else epred:=mkOr(epred,xpred) -- this used always to be done, as noted below, but that's not safe if not(ximplem is [["Subsumed",:.],:.]) then eimplem:= ximplem if eimplem then esig:=[CAR esig,CADR esig] -- in case there's a constant marker e:= [esig,epred,:eimplem] -- e:= [esig,mkOr(xpred,epred),:ximplem] -- Original version -gets it wrong if the new operator is only -- present under certain conditions -- We must pick up the previous implementation, if any --+ if ximplem is [[q,.,index]] and INTEGERP index and (q="ELT" or q="CONST") then $NewCatVec. index:= e original:= [e,:original] original mkOr(a,b) == a=true => true b=true => true b=a => a --PRETTYPRINT ("Condition merging",a,b) l:= a is ["OR",:a'] => (b is ["OR",:b'] => union(a',b'); mkOr2(b,a') ) b is ["OR",:b'] => mkOr2(a,b') (a is ["has",avar,acat]) and (b is ["has",=avar,bcat]) => DescendantP(acat,bcat) => LIST b DescendantP(bcat,acat) => LIST a [a,b] a is ['AND,:a'] and member(b,a') => LIST b b is ['AND,:b'] and member(a,b') => LIST a a is ["and",:a'] and member(b,a') => LIST b b is ["and",:b'] and member(a,b') => LIST a [a,b] LENGTH l = 1 => CAR l ["OR",:l] mkOr2(a,b) == --a is a condition, "b" a list of them member(a,b) => b a is ["has",avar,acat] => aRedundant:=false for c in b | c is ["has",=avar,ccat] repeat DescendantP(acat,ccat) => return (aRedundant:=true) if DescendantP(ccat,acat) then b := delete(c,b) aRedundant => b [a,:b] [a,:b] mkAnd(a,b) == a=true => b b=true => a b=a => a --PRETTYPRINT ("Condition merging",a,b) l:= a is ["AND",:a'] => (b is ["AND",:b'] => union(a',b'); mkAnd2(b,a') ) b is ["AND",:b'] => mkAnd2(a,b') (a is ["has",avar,acat]) and (b is ["has",=avar,bcat]) => DescendantP(acat,bcat) => LIST a DescendantP(bcat,acat) => LIST b [a,b] [a,b] LENGTH l = 1 => CAR l ["AND",:l] mkAnd2(a,b) == --a is a condition, "b" a list of them member(a,b) => b a is ["has",avar,acat] => aRedundant:=false for c in b | c is ["has",=avar,ccat] repeat DescendantP(ccat,acat) => return (aRedundant:=true) if DescendantP(acat,ccat) then b := delete(c,b) aRedundant => b [a,:b] [a,:b] SigListMember(m,list) == list=nil => false SigEqual(m,first list) => true SigListMember(m,rest list) SigEqual([sig1,pred1,:.],[sig2,pred2,:.]) == -- Notice asymmetry: checks that arg1 is a consequence of arg2 sig1=sig2 and PredImplies(pred2,pred1) PredImplies(a,b) == --true if a => b in the sense of logical implication --a = "true" => true a=true => true a=b => true false -- added by RDJ: 12/21/82 --error() -- for the time being SigListOpSubsume([[name1,sig1,:.],:.],list) == --does m subsume another operator in the list? --see "operator subsumption" in SYSTEM SCRIPT --if it does, returns the subsumed member lsig1:=LENGTH sig1 ans:=[] for (n:=[[name2,sig2,:.],:.]) in list repeat name1=name2 and EQ(lsig1,LENGTH sig2) and SourceLevelSubsume(sig1,sig2) => ans:=[n,:ans] return ans SigOpsubsume([[name1,sig1,:flag1],pred1,:.],[[name2,sig2,:flag2],pred2,:.]) == --flag1 = flag2 and :this really should be checked name1=name2 and LENGTH sig1=LENGTH sig2 and SourceLevelSubsume(sig1,sig2) SourceLevelSubsume([out1,:in1],[out2,:in2]) == -- Checks for source-level subsumption in the sense of SYSTEM SCRIPT -- true if the first signature subsumes the second SourceLevelSubset(out1,out2) and (and/[SourceLevelSubset(inarg2,inarg1) for inarg1 in in1 for inarg2 in in2]) SourceLevelSubset(a,b) == --true if a is a source-level subset of b a=b => true $noSubsumption=true => false b is ["Union",:blist] and member(a,blist) => true BOUNDP '$noSubsets and $noSubsets => false atom b and assoc(a,GETL(b,"Subsets")) => true a is [a1] and b is [b1] and assoc(a1,GETL(b1,"Subsets")) => true nil MachineLevelSubsume([name1,[out1,:in1],:flag1],[name2,[out2,:in2],:flag2]) == -- Checks for machine-level subsumption in the sense of SYSTEM SCRIPT -- true if the first signature subsumes the second -- flag1 = flag2 and: this really should be checked, but name1=name2 and MachineLevelSubset(out1,out2) and (and/[MachineLevelSubset(inarg2,inarg1) for inarg1 in in1 for inarg2 in in2] ) MachineLevelSubset(a,b) == --true if a is a machine-level subset of b a=b => true b is ["Union",:blist] and member(a,blist) and (and/[STRINGP x for x in blist | x^=a]) => true --all other branches must be distinct objects atom b and assoc(a,GETL(b,"Subsets")) => true a is [a1] and b is [b1] and assoc(a1,GETL(b1,"Subsets")) => true --we assume all subsets are true at the machine level nil --% Ancestor chasing code FindFundAncs l == --l is a list of categories and associated conditions (a list of 2-lists --returns a list of them and all their fundamental ancestors --also as two-lists with the appropriate conditions l=nil => nil f1:= CatEval CAAR l f1.(0)=nil => FindFundAncs rest l ans:= FindFundAncs rest l for u in FindFundAncs [[CatEval first x,mkAnd(CADAR l,CADR x)] for x in CADR f1.4] repeat x:= ASSQ(first u,ans) => ans:= [[first u,mkOr(CADR x,CADR u)],:delete(x,ans)] ans:= [u,:ans] --testing to see if CAR l is already there x:= ASSQ(CAAR l,ans) => [[CAAR l,mkOr(CADAR l,CADR x)],:delete(x,ans)] CADAR l=true => for x in first f1.4 repeat if y:= ASSQ(CatEval x,ans) then ans:= delete(y,ans) [first l,:ans] for x in first f1.4 repeat if y:= ASSQ(CatEval x,ans) then ans:= [[first y,mkOr(CADAR l,CADR y)],:delete(y,ans)] [first l,:ans] -- Our new thing may have, as an alternate view, a principal -- descendant of something previously added which is therefore -- subsumed CatEval x == REFVECP x => x $InteractiveMode => CAR compMakeCategoryObject(x,$CategoryFrame) CAR compMakeCategoryObject(x,$e) --RemovePrinAncs(l,leaves) == -- l=nil => nil -- leaves:= [first y for y in leaves] -- --remove the slot pointers -- [x for x in l | not AncestorP(x.(0),leaves)] AncestorP(xname,leaves) == -- checks for being a principal ancestor of one of the leaves member(xname,leaves) => xname for y in leaves repeat member(xname,first (CatEval y).4) => return y CondAncestorP(xname,leaves,condition) == -- checks for being a principal ancestor of one of the leaves for u in leaves repeat u':=first u ucond:= null rest u => true first rest u xname = u' or member(xname,first (CatEval u').4) => PredImplies(ucond,condition) => return u' DescendantP(a,b) == -- checks to see if a is any kind of Descendant of b a=b => true a is ["ATTRIBUTE",:.] => nil a is ["SIGNATURE",:.] => nil a:= CatEval a b is ["ATTRIBUTE",b'] => (l:=assoc(b',a.2)) => TruthP CADR l member(b,first a.4) => true AncestorP(b,[first u for u in CADR a.4]) => true nil --% The implementation of Join JoinInner(l,$e) == $NewCatVec: local CondList:= nil for u in l repeat for at in u.2 repeat at2:= first at if atom at2 then at2:=[at2] -- the variable $Attributes is built globally, so that true -- attributes can be detected without calling isCategoryForm QMEMQ(QCAR at2,$Attributes) => nil null isCategoryForm(at2,$e) => $Attributes:=[QCAR at2,:$Attributes] nil pred:= first rest at -- The predicate under which this category is conditional member(pred,get("$Information","special",$e)) => l:= [:l,CatEval at2] --It's true, so we add this as unconditional not (pred is ["and",:.]) => CondList:= [[CatEval at2,pred],:CondList] pred':= [u for u in rest pred | not member(u,get("$Information","special",$e)) and not (u=true)] null pred' => l:= [:l,CatEval at2] LENGTH pred'=1 => CondList:= [[CatEval at2,pred'],:CondList] CondList:= [[CatEval at2,["and",:pred']],:CondList] [$NewCatVec,:l]:= l l':= [:CondList,:[[u,true] for u in l]] -- This is a list of all the categories that this extends -- conditionally or unconditionally sigl:= $NewCatVec.(1) attl:= $NewCatVec.2 globalDomains:= $NewCatVec.5 FundamentalAncestors:= CADR $NewCatVec.4 if $NewCatVec.(0) then FundamentalAncestors:= [[$NewCatVec.(0)],:FundamentalAncestors] --principal ancestor . all those already included copied:= nil originalVector:= true -- we can not decide to extend the vector in multiple ways -- this flag helps us detect this case originalVector := false -- this skips buggy code which discards needed categories for [b,condition] in FindFundAncs l' repeat --This loop implements Category Subsumption --as described in SYSTEM SCRIPT if not (b.(0)=nil) then --It's a named category bname:= b.(0) CondAncestorP(bname,FundamentalAncestors,condition) => nil (f:=AncestorP(bname,[first u for u in FundamentalAncestors])) => [.,.,index]:=assoc(f,FundamentalAncestors) FundamentalAncestors:=[[bname,condition,index],:FundamentalAncestors] PrinAncb:= first (CatEval bname).(4) --Principal Ancestors of b reallynew:= true for anc in FundamentalAncestors repeat if member(first anc,PrinAncb) then --This is the check for "Category Subsumption" if rest anc then (anccond:= CADR anc; ancindex:= CADDR anc) else (anccond:= true; ancindex:= nil) if PredImplies(condition,anccond) then FundamentalAncestors:= -- the new 'b' is more often true than the old one 'anc' [[bname,condition,ancindex],:delete(anc,FundamentalAncestors)] else if ancindex and (PredImplies(anccond,condition); true) -- I have no idea who effectively commented out the predImplies -- JHD 25/8/86 then --the new 'b' is less often true newentry:=[bname,condition,ancindex] if not member(newentry,FundamentalAncestors) then FundamentalAncestors:= [newentry,:FundamentalAncestors] else ancindex:= nil if not copied then $NewCatVec:= COPY_-SEQ $NewCatVec copied:= true if ancindex then ($NewCatVec.ancindex:= bname; reallynew:= nil) else if originalVector and (condition=true) then $NewCatVec:= CatEval bname copied:= nil FundamentalAncestors:= [[bname],:CADR $NewCatVec.4] --bname is Principal, so comes first reallynew:= nil MEMQ(b,l) => --MEMQ since category vectors are guaranteed unique (sigl:= $NewCatVec.(1); attl:= $NewCatVec.2; l:= delete(b,l)) -- SAY("domain ",bname," subsumes") -- SAY("adding a conditional domain ", -- bname, -- " replacing", -- CAR anc) bCond:= ASSQ(b,CondList) CondList:= delete(bCond,CondList) -- value of bCond not used and could be NIL -- bCond:= CADR bCond globalDomains:= $NewCatVec.5 for u in $NewCatVec.(1) repeat if not member(u,sigl) then [s,c,i]:= u if c=true then sigl:= [[s,condition,i],:sigl] else sigl:= [[s,["and",condition,c],i],:sigl] for u in $NewCatVec.2 repeat if not member(u,attl) then [a,c]:= u if c=true then attl:= [[a,condition],:attl] else attl:= [[a,["and",condition,c]],:attl] if reallynew then n:= SIZE $NewCatVec FundamentalAncestors:= [[b.(0),condition,n],:FundamentalAncestors] $NewCatVec:= LENGTHENVEC($NewCatVec,n+1) -- We need to copy the vector otherwise the FundamentalAncestors -- list will get stepped on while compiling "If R has ... " code -- Camm Maguire July 26, 2003 -- copied:= true copied:= false originalvector:= false $NewCatVec.n:= b.(0) if not copied then $NewCatVec:= COPY_-SEQ $NewCatVec -- It is important to copy the vector now, -- in case SigListUnion alters it while -- performing Operator Subsumption for b in l repeat sigl:= SigListUnion([DropImplementations u for u in b.(1)],sigl) attl:= -- next two lines are merely performance improvements MEMQ(attl,b.2) => b.2 MEMQ(b.2,attl) => attl S_+(b.2,attl) globalDomains:= [:globalDomains,:S_-(b.5,globalDomains)] for b in CondList repeat newpred:= first rest b for u in (first b).2 repeat v:= assoc(first u,attl) null v => attl:= CADR u=true => [[first u,newpred],:attl] [[first u,["and",newpred,CADR u]],:attl] CADR v=true => nil attl:= delete(v,attl) attl:= CADR u=true => [[first u,mkOr(CADR v,newpred)],:attl] [[first u,mkOr(CADR v,mkAnd(newpred,CADR u))],:attl] sigl:= SigListUnion( [AddPredicate(DropImplementations u,newpred) for u in (first b).(1)],sigl) where AddPredicate(op is [sig,oldpred,:implem],newpred) == newpred=true => op oldpred=true => [sig,newpred,:implem] [sig,mkpf([oldpred,newpred],"and"),:implem] FundamentalAncestors:= [x for x in FundamentalAncestors | rest x] --strip out the pointer to Principal Ancestor c:= first $NewCatVec.4 pName:= $NewCatVec.(0) if pName and not member(pName,c) then c:= [pName,:c] $NewCatVec.4:= [c,FundamentalAncestors,CADDR $NewCatVec.4] mkCategory("domain",sigl,attl,globalDomains,$NewCatVec) Join(:l) == e := (not BOUNDP '$e) or null $e or $InteractiveMode => $CategoryFrame $e JoinInner(l, e) --ProduceDomainAlist(u,e) == -- -- Gives a complete Alist for all the functions in the Domain -- not (sig:= get(u,"modemap",e)) => nil -- sig:= CADAAR sig -- --an incantation -- [c,.,.]:= compMakeCategoryObject(sig,e) -- -- We assume that the environment need not be kept -- c.(1) isCategoryForm(x,e) == x is [name,:.] => categoryForm? name atom x => u:= get(x,"macro",e) => isCategoryForm(u,e)