From b8edf207247b2f174eefd6d9edd18b4a73876303 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Wed, 31 Oct 2007 01:45:10 +0000 Subject: remove more pamphlet --- src/interp/category.boot | 555 +++++++++++++++++++++++++++++++++ src/interp/category.boot.pamphlet | 633 -------------------------------------- src/interp/cattable.boot | 505 ++++++++++++++++++++++++++++++ src/interp/cattable.boot.pamphlet | 531 -------------------------------- 4 files changed, 1060 insertions(+), 1164 deletions(-) create mode 100644 src/interp/category.boot delete mode 100644 src/interp/category.boot.pamphlet create mode 100644 src/interp/cattable.boot delete mode 100644 src/interp/cattable.boot.pamphlet (limited to 'src') diff --git a/src/interp/category.boot b/src/interp/category.boot new file mode 100644 index 00000000..c6a411bb --- /dev/null +++ b/src/interp/category.boot @@ -0,0 +1,555 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- 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 + +Category() == nil --sorry to say, this hack is needed by isCategoryType + +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:= GETREFV 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 + -- check for $NRTflag until massive algebra recompilation + 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) + diff --git a/src/interp/category.boot.pamphlet b/src/interp/category.boot.pamphlet deleted file mode 100644 index 5da2cc25..00000000 --- a/src/interp/category.boot.pamphlet +++ /dev/null @@ -1,633 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp category.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{mkCategory} - -This code defines the structure of a category. -<>= -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:= GETREFV 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 - -@ -\section{hasCategoryBug} -The hasCategoryBug (bug000001)\cite{2} manifests itself by causing a -value stack overflow when compiling algebra code that uses conditions -that read ``if R has ...'' when using GCL (but not CCL). Essentially -the [[|Ring|]] category keeps getting added to the list each time -[[|Ring|]] is processed. Camm Maguire's mail explains it thus: - -The bottom line is that [[(|Ring|)]] is totally correct until -[[|Algebra|]] is executed, at which point the fourth element returned -by [[(|Ring|)]] is overwritten by the result returned in the fourth -element of the vector returned by [[|Algebra|]]. The point of this -overwrite is at the following form of [[|JoinInner|]] from -[[(int/interp/category.clisp)]] - -\begin{verbatim} - (SETELT |$NewCatVec| 4 (CONS |c| (CONS |FundamentalAncestors| (CONS - (CADDR (ELT |$NewCatVec| 4)) NIL)))) -\end{verbatim} - -called from [[|Algebra;|]] [[(int/algebra/ALGEBRA.NRLIB/code.lsp)]] through - -\begin{verbatim} -(|Join| (|Ring|) (|Module| (QUOTE |t#1|)) (|mkCategory| (QUOTE -|domain|) (QUOTE (((|coerce| ($ |t#1|)) T))) NIL (QUOTE NIL) NIL)) -\end{verbatim} - -I haven't parsed [[|JoinInner|]] yet, but my guess is that there is a -copy-seq in there which is not getting executed in the assignment of -[[|$NewCatVec|]] before the setelt. - -The original code failed to copy the NewCatVec before updating -it. This code from macros.lisp\cite{1} checks whether the array is -adjustable. - -\begin{verbatim} -(defun lengthenvec (v n) - (if (adjustable-array-p v) (adjust-array v n) - (replace (make-array n) v))) -\end{verbatim} -At least in GCL, the code for lengthenvec need not copy the vec to a -new location. In this case the FundamentalAncesters array is adjustable -and in GCL the adjust-array need not, and in this case, does not do a -copy. -<>= - 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 -@ -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- 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 - -Category() == nil --sorry to say, this hack is needed by isCategoryType - -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 - -<> -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 - -- check for $NRTflag until massive algebra recompilation - 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] -<> - 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) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} [[pamphlet:src/interp/macros.lisp.pamphlet]] -\bibitem{2} [[pamphlet:KNOWN.BUGS.pamphlet]] -\end{thebibliography} -\end{document} diff --git a/src/interp/cattable.boot b/src/interp/cattable.boot new file mode 100644 index 00000000..c5bb711c --- /dev/null +++ b/src/interp/cattable.boot @@ -0,0 +1,505 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- 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 '"simpbool" +import '"g-util" +)package "BOOT" + +hasCat(domainOrCatName,catName) == + catName='Object or catName='Type -- every domain is a Type (Object) + or GETDATABASE([domainOrCatName,:catName],'HASCATEGORY) + +showCategoryTable con == + [[b,:val] for (key :=[a,:b]) in HKEYS _*HASCATEGORY_-HASH_* + | a = con and (val := HGET(_*HASCATEGORY_-HASH_*,key))] + +displayCategoryTable(:options) == + conList := IFCAR options + SETQ($ct,MAKE_-HASHTABLE 'ID) + for (key:=[a,:b]) in HKEYS _*HASCATEGORY_-HASH_* repeat + HPUT($ct,a,[[b,:HGET(_*HASCATEGORY_-HASH_*,key)],:HGET($ct,a)]) + for id in HKEYS $ct | null conList or MEMQ(id,conList) repeat + sayMSG [:bright id,'"extends:"] + PRINT HGET($ct,id) + +genCategoryTable() == + SETQ(_*ANCESTORS_-HASH_*, MAKE_-HASHTABLE 'ID) + SETQ(_*HASCATEGORY_-HASH_*,MAKE_-HASHTABLE 'UEQUAL) + genTempCategoryTable() + domainList:= + [con for con in allConstructors() + | GETDATABASE(con,'CONSTRUCTORKIND) = 'domain] + domainTable:= [addDomainToTable(con,getConstrCat catl) for con + in domainList | catl := GETDATABASE(con,'CONSTRUCTORCATEGORY)] + -- $nonLisplibDomains, $noCategoryDomains are set in BUILDOM BOOT + specialDs := SETDIFFERENCE($nonLisplibDomains,$noCategoryDomains) + domainTable:= [:[addDomainToTable(id, getConstrCat (eval [id]).3) + for id in specialDs], :domainTable] + for [id,:entry] in domainTable repeat + for [a,:b] in encodeCategoryAlist(id,entry) repeat + HPUT(_*HASCATEGORY_-HASH_*,[id,:a],b) + simpTempCategoryTable() + compressHashTable _*ANCESTORS_-HASH_* + simpCategoryTable() + compressHashTable _*HASCATEGORY_-HASH_* + +simpTempCategoryTable() == + for id in HKEYS _*ANCESTORS_-HASH_* repeat + for (u:=[a,:b]) in GETDATABASE(id,'ANCESTORS) repeat + RPLACA(u,SUBST('Type,'Object,a)) + RPLACD(u,simpHasPred b) + +simpCategoryTable() == main where + main() == + for key in HKEYS _*HASCATEGORY_-HASH_* repeat + entry := HGET(_*HASCATEGORY_-HASH_*,key) + null entry => HREM(_*HASCATEGORY_-HASH_*,key) + change := + atom opOf entry => simpHasPred entry + [[x,:npred] for [x,:pred] in entry | npred := simpHasPred pred] + HPUT(_*HASCATEGORY_-HASH_*,key,change) + +simpHasPred(pred,:options) == main where + main() == + $hasArgs: local := IFCDR IFCAR options + simp pred + simp pred == + pred is [op,:r] => + op = "has" => simpHas(pred,first r,first rest r) + op = 'HasCategory => simp ['has,CAR r,simpDevaluate CADR r] + op = 'HasSignature => + [op,sig] := simpDevaluate CADR r + ["has",CAR r,['SIGNATURE,op,sig]] + op = 'HasAttribute => + form := ['has,a := CAR r,['ATTRIBUTE,b := simpDevaluate CADR r]] + simpHasAttribute(form,a,b) + MEMQ(op,'(AND OR NOT)) => + null (u := MKPF([simp p for p in r],op)) => nil + u is '(QUOTE T) => true + simpBool u + op = 'hasArgs => ($hasArgs => $hasArgs = r; pred) + null r and opOf op = 'has => simp first pred + pred is '(QUOTE T) => true + op1 := LASSOC(op,'((and . AND)(or . OR)(not . NOT))) => simp [op1,:r] + simp first pred --REMOVE THIS HACK !!!! + pred in '(T etc) => pred + null pred => nil + pred + simpDevaluate a == EVAL SUBST('QUOTE,'devaluate,a) + simpHas(pred,a,b) == + b is ['ATTRIBUTE,attr] => simpHasAttribute(pred,a,attr) + b is ['SIGNATURE,op,sig] => simpHasSignature(pred,a,op,sig) + IDENTP a or hasIdent b => pred + npred := eval pred + IDENTP npred or null hasIdent npred => npred + pred + eval (pred := ['has,d,cat]) == + x := hasCat(CAR d,CAR cat) + y := CDR cat => + npred := or/[p for [args,:p] in x | y = args] => simp npred + false --if not there, it is false + x + +simpHasSignature(pred,conform,op,sig) == --eval w/o loading + IDENTP conform => pred + [conname,:args] := conform + n := #sig + u := LASSOC(op,GETDATABASE(conname,'OPERATIONALIST)) + candidates := [x for (x := [sig1,:.]) in u | #sig1 = #sig] or return false + match := or/[x for (x := [sig1,:.]) in candidates + | sig = sublisFormal(args,sig1)] or return false + simpHasPred(match is [sig,.,:p] and sublisFormal(args,p) or true) + +simpHasAttribute(pred,conform,attr) == --eval w/o loading + IDENTP conform => pred + conname := opOf conform + GETDATABASE(conname,'CONSTRUCTORKIND) = 'category => + simpCatHasAttribute(conform,attr) + asharpConstructorName? conname => + p := LASSOC(attr,GETDATABASE(conname,'attributes)) => + simpHasPred sublisFormal(rest conform,p) + infovec := dbInfovec conname + k := LASSOC(attr,infovec.2) or return nil --if not listed then false + k = 0 => true + $domain => kTestPred k --from koOps + predvec := $predvec or sublisFormal(rest conform, + GETDATABASE(conname,'PREDICATES)) + simpHasPred predvec.(k - 1) + +simpCatHasAttribute(domform,attr) == + conform := getConstructorForm opOf domform + catval := EVAL mkEvalable conform + if atom KDR attr then attr := IFCAR attr + pred := + u := LASSOC(attr,catval . 2) => first u + return false --exit: not there + pred = true => true + EVAL SUBLISLIS(rest domform,rest conform,pred) + +hasIdent pred == + pred is [op,:r] => + op = 'QUOTE => false + or/[hasIdent x for x in r] + pred = '_$ => false + IDENTP pred => true + false + +addDomainToTable(id,catl) == + alist:= nil + for cat in catl repeat + cat is ['CATEGORY,:.] => nil + cat is ['IF,pred,cat1,:.] => + newAlist:= + [[a,:quickAnd(pred,b)] for [a,:b] in getCategoryExtensionAlist0 cat1] + alist:= [:alist,:newAlist] + alist:= [:alist,:getCategoryExtensionAlist0 cat] + [id,:alist] + +domainHput(table,key:=[id,:a],b) == + HPUT(table,key,b) + +genTempCategoryTable() == + --generates hashtable with key=categoryName and value of the form + -- ((form . pred) ..) meaning that + -- "IF pred THEN ofCategory(key,form)" + -- where form can involve #1, #2, ... the parameters of key + for con in allConstructors() repeat + GETDATABASE(con,'CONSTRUCTORKIND) = 'category => + addToCategoryTable con + for id in HKEYS _*ANCESTORS_-HASH_* repeat + item := HGET(_*ANCESTORS_-HASH_*, id) + for (u:=[.,:b]) in item repeat + RPLACD(u,simpCatPredicate simpBool b) + HPUT(_*ANCESTORS_-HASH_*,id,listSort(function GLESSEQP,item)) + +addToCategoryTable con == + -- adds an entry to $tempCategoryTable with key=con and alist entries + u := CAAR GETDATABASE(con,'CONSTRUCTORMODEMAP) --domain + alist := getCategoryExtensionAlist u + HPUT(_*ANCESTORS_-HASH_*,first u,alist) + alist + +encodeCategoryAlist(id,alist) == + newAl:= nil + for [a,:b] in alist repeat + [key,:argl] := a + newEntry:= + argl => [[argl,:b]] + b + u:= assoc(key,newAl) => + argl => RPLACD(u,encodeUnion(id,first newEntry,rest u)) + if newEntry ^= rest u then + p:= moreGeneralCategoryPredicate(id,newEntry,rest u) => RPLACD(u,p) + sayMSG '"Duplicate entries:" + PRINT [newEntry,rest u] + newAl:= [[key,:newEntry],:newAl] + newAl + +encodeUnion(id,new:=[a,:b],alist) == + u := assoc(a,alist) => + RPLACD(u,moreGeneralCategoryPredicate(id,b,rest u)) + alist + [new,:alist] + +moreGeneralCategoryPredicate(id,new,old) == + old = 'T or new = 'T => 'T + old is ['has,a,b] and new is ['has,=a,c] => + tempExtendsCat(b,c) => new + tempExtendsCat(c,b) => old + ['OR,old,new] + mkCategoryOr(new,old) + +mkCategoryOr(new,old) == + old is ['OR,:l] => simpCategoryOr(new,l) + ['OR,old,new] + +simpCategoryOr(new,l) == + newExtendsAnOld:= false + anOldExtendsNew:= false + ['has,a,b] := new + newList:= nil + for pred in l repeat + pred is ['has,=a,c] => + tempExtendsCat(c,b) => anOldExtendsNew:= true + if tempExtendsCat(b,c) then newExtendsAnOld:= true + newList:= [pred,:newList] + newList:= [pred,:newList] + if not newExtendsAnOld then newList:= [new,:newList] + newList is [.] => first newList + ['OR,:newList] + +tempExtendsCat(b,c) == + or/[first c = a for [[a,:.],:.] in GETDATABASE(first b,'ANCESTORS)] + +getCategoryExtensionAlist0 cform == + [[cform,:'T],:getCategoryExtensionAlist cform] + +getCategoryExtensionAlist cform == + --avoids substitution as much as possible + u:= GETDATABASE(first cform,'ANCESTORS) => formalSubstitute(cform,u) + mkCategoryExtensionAlist cform + +formalSubstitute(form:=[.,:argl],u) == + isFormalArgumentList argl => u + EQSUBSTLIST(argl,$FormalMapVariableList,u) + +isFormalArgumentList argl == + and/[x=fa for x in argl for fa in $FormalMapVariableList] + +mkCategoryExtensionAlist cform == + not CONSP cform => nil + cop := first cform + MEMQ(cop, $CategoryNames) => mkCategoryExtensionAlistBasic cform + catlist := formalSubstitute(cform, first getConstructorExports(cform, true)) + extendsList:= nil + for [cat,:pred] in catlist repeat + newList := getCategoryExtensionAlist0 cat + finalList := + pred = 'T => newList + [[a,:quickAnd(b,pred)] for [a,:b] in newList] + extendsList:= catPairUnion(extendsList,finalList,cop,cat) + extendsList + +-- following code to handle Unions Records Mapping etc. +mkCategoryExtensionAlistBasic cform == + cop := first cform +--category:= eval cform + category := -- changed by RSS on 7/29/87 + macrop cop => eval cform + APPLY(cop, rest cform) + extendsList:= [[x,:'T] for x in category.4.0] + for [cat,pred,:.] in category.4.1 repeat + newList := getCategoryExtensionAlist0 cat + finalList := + pred = 'T => newList + [[a,:quickAnd(b,pred)] for [a,:b] in newList] + extendsList:= catPairUnion(extendsList,finalList,cop,cat) + extendsList + +catPairUnion(oldList,newList,op,cat) == + for pair in newList repeat + u:= assoc(first pair,oldList) => + rest u = rest pair => nil + RPLACD(u,addConflict(rest pair,rest u)) where addConflict(new,old) == + quickOr(new,old) + oldList:= [pair,:oldList] + oldList + +simpCatPredicate p == + p is ['OR,:l] => + (u:= simpOrUnion l) is [p] => p + ['OR,:u] + p + +simpOrUnion l == + if l then simpOrUnion1(first l,simpOrUnion rest l) + else l + +simpOrUnion1(x,l) == + null l => [x] + p:= mergeOr(x,first l) => [p,:rest l] + [first l,:simpOrUnion1(x,rest l)] + +mergeOr(x,y) == + x is ["has",a,b] and y is ['has,=a,c] => + testExtend(b,c) => y + testExtend(c,b) => x + nil + nil + +testExtend(a:=[op,:argl],b) == + (u:= GETDATABASE(op,'ANCESTORS)) and (val:= LASSOC(b,u)) => + formalSubstitute(a,val) + nil + +getConstrCat(x) == +-- gets a different representation of the constructorCategory from the +-- lisplib, which is a list of named categories or conditions + x:= if x is ['Join,:y] then y else [x] + cats:= NIL + for y in x repeat + y is ['CATEGORY,.,:z] => + for zz in z repeat cats := makeCatPred(zz, cats, true) + cats:= CONS(y,cats) + cats:= nreverse cats + cats + + +makeCatPred(zz, cats, thePred) == + if zz is ['IF,curPred := ['has,z1,z2],ats,.] then + ats := if ats is ['PROGN,:atl] then atl else [ats] + for at in ats repeat + if at is ['ATTRIBUTE,z3] and not atom z3 and + constructor? CAR z3 then + cats:= CONS(['IF,quickAnd(['has,z1,z2], thePred),z3,'noBranch],cats) + at is ['IF, pred, :.] => + cats := makeCatPred(at, cats, curPred) + cats + +getConstructorExports(conform,:options) == categoryParts(conform, + GETDATABASE(opOf conform,'CONSTRUCTORCATEGORY),IFCAR options) + +categoryParts(conform,category,:options) == main where + main() == + cons? := IFCAR options --means to include constructors as well + $attrlist: local := nil + $oplist : local := nil + $conslist: local := nil + conname := opOf conform + for x in exportsOf(category) repeat build(x,true) + $attrlist := listSort(function GLESSEQP,$attrlist) + $oplist := listSort(function GLESSEQP,$oplist) + res := [$attrlist,:$oplist] + if cons? then res := [listSort(function GLESSEQP,$conslist),:res] + if GETDATABASE(conname,'CONSTRUCTORKIND) = 'category then + tvl := TAKE(#rest conform,$TriangleVariableList) + res := SUBLISLIS($FormalMapVariableList,tvl,res) + res + build(item,pred) == + item is ['SIGNATURE,op,sig,:.] => $oplist := [[opOf op,sig,:pred],:$oplist] + --note: opOf is needed!!! Bug in compiler puts in (One) and (Zero) + item is ['ATTRIBUTE,attr] => + constructor? opOf attr => + $conslist := [[attr,:pred],:$conslist] + nil + opOf attr = 'nothing => 'skip + $attrlist := [[opOf attr,IFCDR attr,:pred],:$attrlist] + item is ['TYPE,op,type] => + $oplist := [[op,[type],:pred],:$oplist] + item is ['IF,pred1,s1,s2] => + build(s1,quickAnd(pred,pred1)) + s2 => build(s2,quickAnd(pred,['NOT,pred1])) + item is ['PROGN,:r] => for x in r repeat build(x,pred) + item in '(noBranch) => 'ok + null item => 'ok + systemError '"build error" + exportsOf(target) == + target is ['CATEGORY,.,:r] => r + target is ['Join,:r,f] => + for x in r repeat $conslist := [[x,:true],:$conslist] + exportsOf f + $conslist := [[target,:true],:$conslist] + nil + +--------------------> NEW DEFINITION (override in patches.lisp.pamphlet) +compressHashTable ht == +-- compresses hash table ht, to give maximal sharing of cells + sayBrightlyNT '"compressing hash table..." + $found: local := MAKE_-HASHTABLE 'UEQUAL + for x in HKEYS ht repeat compressSexpr(HGET(ht,x),nil,nil) + sayBrightly "done" + ht + +compressSexpr(x,left,right) == +-- recursive version of compressHashTable + atom x => nil + u:= HGET($found,x) => + left => RPLACA(left,u) + right => RPLACD(right,u) + nil + compressSexpr(first x,x,nil) + compressSexpr(rest x,nil,x) + HPUT($found,x,x) + +squeezeList(l) == +-- changes the list l, so that is has maximal sharing of cells + $found:local:= NIL + squeeze1 l + +squeeze1(l) == +-- recursive version of squeezeList + x:= CAR l + y:= + atom x => x + z:= member(x,$found) => CAR z + $found:= CONS(x,$found) + squeeze1 x + RPLACA(l,y) + x:= CDR l + y:= + atom x => x + z:= member(x,$found) => CAR z + $found:= CONS(x,$found) + squeeze1 x + RPLACD(l,y) + +updateCategoryTable(cname,kind) == + $newcompMode = true => nil + $updateCatTableIfTrue => + kind = 'package => nil + kind = 'category => updateCategoryTableForCategory(cname) + updateCategoryTableForDomain(cname,getConstrCat( + GETDATABASE(cname,'CONSTRUCTORCATEGORY))) +--+ + kind = 'domain and $NRTflag = true => + updateCategoryTableForDomain(cname,getConstrCat( + GETDATABASE(cname,'CONSTRUCTORCATEGORY))) + +updateCategoryTableForCategory(cname) == + clearTempCategoryTable([[cname,'category]]) + addToCategoryTable(cname) + for id in HKEYS _*ANCESTORS_-HASH_* repeat + for (u:=[.,:b]) in GETDATABASE(id,'ANCESTORS) repeat + RPLACD(u,simpCatPredicate simpBool b) + +updateCategoryTableForDomain(cname,category) == + clearCategoryTable(cname) + [cname,:domainEntry]:= addDomainToTable(cname,category) + for [a,:b] in encodeCategoryAlist(cname,domainEntry) repeat + HPUT(_*HASCATEGORY_-HASH_*,[cname,:a],b) + $doNotCompressHashTableIfTrue = true => _*HASCATEGORY_-HASH_* + compressHashTable _*HASCATEGORY_-HASH_* + +clearCategoryTable($cname) == + MAPHASH('clearCategoryTable1,_*HASCATEGORY_-HASH_*) + +clearCategoryTable1(key,val) == + (CAR key=$cname)=> HREM(_*HASCATEGORY_-HASH_*,key) + nil + +clearTempCategoryTable(catNames) == + for key in HKEYS(_*ANCESTORS_-HASH_*) repeat + MEMQ(key,catNames) => nil + extensions:= nil + for (extension:= [catForm,:.]) in GETDATABASE(key,'ANCESTORS) + repeat + MEMQ(CAR catForm,catNames) => nil + extensions:= [extension,:extensions] + HPUT(_*ANCESTORS_-HASH_*,key,extensions) + + + + + + + + diff --git a/src/interp/cattable.boot.pamphlet b/src/interp/cattable.boot.pamphlet deleted file mode 100644 index 61b406c3..00000000 --- a/src/interp/cattable.boot.pamphlet +++ /dev/null @@ -1,531 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp cattable.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{License} - -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- 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 '"simpbool" -import '"g-util" -)package "BOOT" - -hasCat(domainOrCatName,catName) == - catName='Object or catName='Type -- every domain is a Type (Object) - or GETDATABASE([domainOrCatName,:catName],'HASCATEGORY) - -showCategoryTable con == - [[b,:val] for (key :=[a,:b]) in HKEYS _*HASCATEGORY_-HASH_* - | a = con and (val := HGET(_*HASCATEGORY_-HASH_*,key))] - -displayCategoryTable(:options) == - conList := IFCAR options - SETQ($ct,MAKE_-HASHTABLE 'ID) - for (key:=[a,:b]) in HKEYS _*HASCATEGORY_-HASH_* repeat - HPUT($ct,a,[[b,:HGET(_*HASCATEGORY_-HASH_*,key)],:HGET($ct,a)]) - for id in HKEYS $ct | null conList or MEMQ(id,conList) repeat - sayMSG [:bright id,'"extends:"] - PRINT HGET($ct,id) - -genCategoryTable() == - SETQ(_*ANCESTORS_-HASH_*, MAKE_-HASHTABLE 'ID) - SETQ(_*HASCATEGORY_-HASH_*,MAKE_-HASHTABLE 'UEQUAL) - genTempCategoryTable() - domainList:= - [con for con in allConstructors() - | GETDATABASE(con,'CONSTRUCTORKIND) = 'domain] - domainTable:= [addDomainToTable(con,getConstrCat catl) for con - in domainList | catl := GETDATABASE(con,'CONSTRUCTORCATEGORY)] - -- $nonLisplibDomains, $noCategoryDomains are set in BUILDOM BOOT - specialDs := SETDIFFERENCE($nonLisplibDomains,$noCategoryDomains) - domainTable:= [:[addDomainToTable(id, getConstrCat (eval [id]).3) - for id in specialDs], :domainTable] - for [id,:entry] in domainTable repeat - for [a,:b] in encodeCategoryAlist(id,entry) repeat - HPUT(_*HASCATEGORY_-HASH_*,[id,:a],b) - simpTempCategoryTable() - compressHashTable _*ANCESTORS_-HASH_* - simpCategoryTable() - compressHashTable _*HASCATEGORY_-HASH_* - -simpTempCategoryTable() == - for id in HKEYS _*ANCESTORS_-HASH_* repeat - for (u:=[a,:b]) in GETDATABASE(id,'ANCESTORS) repeat - RPLACA(u,SUBST('Type,'Object,a)) - RPLACD(u,simpHasPred b) - -simpCategoryTable() == main where - main() == - for key in HKEYS _*HASCATEGORY_-HASH_* repeat - entry := HGET(_*HASCATEGORY_-HASH_*,key) - null entry => HREM(_*HASCATEGORY_-HASH_*,key) - change := - atom opOf entry => simpHasPred entry - [[x,:npred] for [x,:pred] in entry | npred := simpHasPred pred] - HPUT(_*HASCATEGORY_-HASH_*,key,change) - -simpHasPred(pred,:options) == main where - main() == - $hasArgs: local := IFCDR IFCAR options - simp pred - simp pred == - pred is [op,:r] => - op = "has" => simpHas(pred,first r,first rest r) - op = 'HasCategory => simp ['has,CAR r,simpDevaluate CADR r] - op = 'HasSignature => - [op,sig] := simpDevaluate CADR r - ["has",CAR r,['SIGNATURE,op,sig]] - op = 'HasAttribute => - form := ['has,a := CAR r,['ATTRIBUTE,b := simpDevaluate CADR r]] - simpHasAttribute(form,a,b) - MEMQ(op,'(AND OR NOT)) => - null (u := MKPF([simp p for p in r],op)) => nil - u is '(QUOTE T) => true - simpBool u - op = 'hasArgs => ($hasArgs => $hasArgs = r; pred) - null r and opOf op = 'has => simp first pred - pred is '(QUOTE T) => true - op1 := LASSOC(op,'((and . AND)(or . OR)(not . NOT))) => simp [op1,:r] - simp first pred --REMOVE THIS HACK !!!! - pred in '(T etc) => pred - null pred => nil - pred - simpDevaluate a == EVAL SUBST('QUOTE,'devaluate,a) - simpHas(pred,a,b) == - b is ['ATTRIBUTE,attr] => simpHasAttribute(pred,a,attr) - b is ['SIGNATURE,op,sig] => simpHasSignature(pred,a,op,sig) - IDENTP a or hasIdent b => pred - npred := eval pred - IDENTP npred or null hasIdent npred => npred - pred - eval (pred := ['has,d,cat]) == - x := hasCat(CAR d,CAR cat) - y := CDR cat => - npred := or/[p for [args,:p] in x | y = args] => simp npred - false --if not there, it is false - x - -simpHasSignature(pred,conform,op,sig) == --eval w/o loading - IDENTP conform => pred - [conname,:args] := conform - n := #sig - u := LASSOC(op,GETDATABASE(conname,'OPERATIONALIST)) - candidates := [x for (x := [sig1,:.]) in u | #sig1 = #sig] or return false - match := or/[x for (x := [sig1,:.]) in candidates - | sig = sublisFormal(args,sig1)] or return false - simpHasPred(match is [sig,.,:p] and sublisFormal(args,p) or true) - -simpHasAttribute(pred,conform,attr) == --eval w/o loading - IDENTP conform => pred - conname := opOf conform - GETDATABASE(conname,'CONSTRUCTORKIND) = 'category => - simpCatHasAttribute(conform,attr) - asharpConstructorName? conname => - p := LASSOC(attr,GETDATABASE(conname,'attributes)) => - simpHasPred sublisFormal(rest conform,p) - infovec := dbInfovec conname - k := LASSOC(attr,infovec.2) or return nil --if not listed then false - k = 0 => true - $domain => kTestPred k --from koOps - predvec := $predvec or sublisFormal(rest conform, - GETDATABASE(conname,'PREDICATES)) - simpHasPred predvec.(k - 1) - -simpCatHasAttribute(domform,attr) == - conform := getConstructorForm opOf domform - catval := EVAL mkEvalable conform - if atom KDR attr then attr := IFCAR attr - pred := - u := LASSOC(attr,catval . 2) => first u - return false --exit: not there - pred = true => true - EVAL SUBLISLIS(rest domform,rest conform,pred) - -hasIdent pred == - pred is [op,:r] => - op = 'QUOTE => false - or/[hasIdent x for x in r] - pred = '_$ => false - IDENTP pred => true - false - -addDomainToTable(id,catl) == - alist:= nil - for cat in catl repeat - cat is ['CATEGORY,:.] => nil - cat is ['IF,pred,cat1,:.] => - newAlist:= - [[a,:quickAnd(pred,b)] for [a,:b] in getCategoryExtensionAlist0 cat1] - alist:= [:alist,:newAlist] - alist:= [:alist,:getCategoryExtensionAlist0 cat] - [id,:alist] - -domainHput(table,key:=[id,:a],b) == - HPUT(table,key,b) - -genTempCategoryTable() == - --generates hashtable with key=categoryName and value of the form - -- ((form . pred) ..) meaning that - -- "IF pred THEN ofCategory(key,form)" - -- where form can involve #1, #2, ... the parameters of key - for con in allConstructors() repeat - GETDATABASE(con,'CONSTRUCTORKIND) = 'category => - addToCategoryTable con - for id in HKEYS _*ANCESTORS_-HASH_* repeat - item := HGET(_*ANCESTORS_-HASH_*, id) - for (u:=[.,:b]) in item repeat - RPLACD(u,simpCatPredicate simpBool b) - HPUT(_*ANCESTORS_-HASH_*,id,listSort(function GLESSEQP,item)) - -addToCategoryTable con == - -- adds an entry to $tempCategoryTable with key=con and alist entries - u := CAAR GETDATABASE(con,'CONSTRUCTORMODEMAP) --domain - alist := getCategoryExtensionAlist u - HPUT(_*ANCESTORS_-HASH_*,first u,alist) - alist - -encodeCategoryAlist(id,alist) == - newAl:= nil - for [a,:b] in alist repeat - [key,:argl] := a - newEntry:= - argl => [[argl,:b]] - b - u:= assoc(key,newAl) => - argl => RPLACD(u,encodeUnion(id,first newEntry,rest u)) - if newEntry ^= rest u then - p:= moreGeneralCategoryPredicate(id,newEntry,rest u) => RPLACD(u,p) - sayMSG '"Duplicate entries:" - PRINT [newEntry,rest u] - newAl:= [[key,:newEntry],:newAl] - newAl - -encodeUnion(id,new:=[a,:b],alist) == - u := assoc(a,alist) => - RPLACD(u,moreGeneralCategoryPredicate(id,b,rest u)) - alist - [new,:alist] - -moreGeneralCategoryPredicate(id,new,old) == - old = 'T or new = 'T => 'T - old is ['has,a,b] and new is ['has,=a,c] => - tempExtendsCat(b,c) => new - tempExtendsCat(c,b) => old - ['OR,old,new] - mkCategoryOr(new,old) - -mkCategoryOr(new,old) == - old is ['OR,:l] => simpCategoryOr(new,l) - ['OR,old,new] - -simpCategoryOr(new,l) == - newExtendsAnOld:= false - anOldExtendsNew:= false - ['has,a,b] := new - newList:= nil - for pred in l repeat - pred is ['has,=a,c] => - tempExtendsCat(c,b) => anOldExtendsNew:= true - if tempExtendsCat(b,c) then newExtendsAnOld:= true - newList:= [pred,:newList] - newList:= [pred,:newList] - if not newExtendsAnOld then newList:= [new,:newList] - newList is [.] => first newList - ['OR,:newList] - -tempExtendsCat(b,c) == - or/[first c = a for [[a,:.],:.] in GETDATABASE(first b,'ANCESTORS)] - -getCategoryExtensionAlist0 cform == - [[cform,:'T],:getCategoryExtensionAlist cform] - -getCategoryExtensionAlist cform == - --avoids substitution as much as possible - u:= GETDATABASE(first cform,'ANCESTORS) => formalSubstitute(cform,u) - mkCategoryExtensionAlist cform - -formalSubstitute(form:=[.,:argl],u) == - isFormalArgumentList argl => u - EQSUBSTLIST(argl,$FormalMapVariableList,u) - -isFormalArgumentList argl == - and/[x=fa for x in argl for fa in $FormalMapVariableList] - -mkCategoryExtensionAlist cform == - not CONSP cform => nil - cop := first cform - MEMQ(cop, $CategoryNames) => mkCategoryExtensionAlistBasic cform - catlist := formalSubstitute(cform, first getConstructorExports(cform, true)) - extendsList:= nil - for [cat,:pred] in catlist repeat - newList := getCategoryExtensionAlist0 cat - finalList := - pred = 'T => newList - [[a,:quickAnd(b,pred)] for [a,:b] in newList] - extendsList:= catPairUnion(extendsList,finalList,cop,cat) - extendsList - --- following code to handle Unions Records Mapping etc. -mkCategoryExtensionAlistBasic cform == - cop := first cform ---category:= eval cform - category := -- changed by RSS on 7/29/87 - macrop cop => eval cform - APPLY(cop, rest cform) - extendsList:= [[x,:'T] for x in category.4.0] - for [cat,pred,:.] in category.4.1 repeat - newList := getCategoryExtensionAlist0 cat - finalList := - pred = 'T => newList - [[a,:quickAnd(b,pred)] for [a,:b] in newList] - extendsList:= catPairUnion(extendsList,finalList,cop,cat) - extendsList - -catPairUnion(oldList,newList,op,cat) == - for pair in newList repeat - u:= assoc(first pair,oldList) => - rest u = rest pair => nil - RPLACD(u,addConflict(rest pair,rest u)) where addConflict(new,old) == - quickOr(new,old) - oldList:= [pair,:oldList] - oldList - -simpCatPredicate p == - p is ['OR,:l] => - (u:= simpOrUnion l) is [p] => p - ['OR,:u] - p - -simpOrUnion l == - if l then simpOrUnion1(first l,simpOrUnion rest l) - else l - -simpOrUnion1(x,l) == - null l => [x] - p:= mergeOr(x,first l) => [p,:rest l] - [first l,:simpOrUnion1(x,rest l)] - -mergeOr(x,y) == - x is ["has",a,b] and y is ['has,=a,c] => - testExtend(b,c) => y - testExtend(c,b) => x - nil - nil - -testExtend(a:=[op,:argl],b) == - (u:= GETDATABASE(op,'ANCESTORS)) and (val:= LASSOC(b,u)) => - formalSubstitute(a,val) - nil - -getConstrCat(x) == --- gets a different representation of the constructorCategory from the --- lisplib, which is a list of named categories or conditions - x:= if x is ['Join,:y] then y else [x] - cats:= NIL - for y in x repeat - y is ['CATEGORY,.,:z] => - for zz in z repeat cats := makeCatPred(zz, cats, true) - cats:= CONS(y,cats) - cats:= nreverse cats - cats - - -makeCatPred(zz, cats, thePred) == - if zz is ['IF,curPred := ['has,z1,z2],ats,.] then - ats := if ats is ['PROGN,:atl] then atl else [ats] - for at in ats repeat - if at is ['ATTRIBUTE,z3] and not atom z3 and - constructor? CAR z3 then - cats:= CONS(['IF,quickAnd(['has,z1,z2], thePred),z3,'noBranch],cats) - at is ['IF, pred, :.] => - cats := makeCatPred(at, cats, curPred) - cats - -getConstructorExports(conform,:options) == categoryParts(conform, - GETDATABASE(opOf conform,'CONSTRUCTORCATEGORY),IFCAR options) - -categoryParts(conform,category,:options) == main where - main() == - cons? := IFCAR options --means to include constructors as well - $attrlist: local := nil - $oplist : local := nil - $conslist: local := nil - conname := opOf conform - for x in exportsOf(category) repeat build(x,true) - $attrlist := listSort(function GLESSEQP,$attrlist) - $oplist := listSort(function GLESSEQP,$oplist) - res := [$attrlist,:$oplist] - if cons? then res := [listSort(function GLESSEQP,$conslist),:res] - if GETDATABASE(conname,'CONSTRUCTORKIND) = 'category then - tvl := TAKE(#rest conform,$TriangleVariableList) - res := SUBLISLIS($FormalMapVariableList,tvl,res) - res - build(item,pred) == - item is ['SIGNATURE,op,sig,:.] => $oplist := [[opOf op,sig,:pred],:$oplist] - --note: opOf is needed!!! Bug in compiler puts in (One) and (Zero) - item is ['ATTRIBUTE,attr] => - constructor? opOf attr => - $conslist := [[attr,:pred],:$conslist] - nil - opOf attr = 'nothing => 'skip - $attrlist := [[opOf attr,IFCDR attr,:pred],:$attrlist] - item is ['TYPE,op,type] => - $oplist := [[op,[type],:pred],:$oplist] - item is ['IF,pred1,s1,s2] => - build(s1,quickAnd(pred,pred1)) - s2 => build(s2,quickAnd(pred,['NOT,pred1])) - item is ['PROGN,:r] => for x in r repeat build(x,pred) - item in '(noBranch) => 'ok - null item => 'ok - systemError '"build error" - exportsOf(target) == - target is ['CATEGORY,.,:r] => r - target is ['Join,:r,f] => - for x in r repeat $conslist := [[x,:true],:$conslist] - exportsOf f - $conslist := [[target,:true],:$conslist] - nil - ---------------------> NEW DEFINITION (override in patches.lisp.pamphlet) -compressHashTable ht == --- compresses hash table ht, to give maximal sharing of cells - sayBrightlyNT '"compressing hash table..." - $found: local := MAKE_-HASHTABLE 'UEQUAL - for x in HKEYS ht repeat compressSexpr(HGET(ht,x),nil,nil) - sayBrightly "done" - ht - -compressSexpr(x,left,right) == --- recursive version of compressHashTable - atom x => nil - u:= HGET($found,x) => - left => RPLACA(left,u) - right => RPLACD(right,u) - nil - compressSexpr(first x,x,nil) - compressSexpr(rest x,nil,x) - HPUT($found,x,x) - -squeezeList(l) == --- changes the list l, so that is has maximal sharing of cells - $found:local:= NIL - squeeze1 l - -squeeze1(l) == --- recursive version of squeezeList - x:= CAR l - y:= - atom x => x - z:= member(x,$found) => CAR z - $found:= CONS(x,$found) - squeeze1 x - RPLACA(l,y) - x:= CDR l - y:= - atom x => x - z:= member(x,$found) => CAR z - $found:= CONS(x,$found) - squeeze1 x - RPLACD(l,y) - -updateCategoryTable(cname,kind) == - $newcompMode = true => nil - $updateCatTableIfTrue => - kind = 'package => nil - kind = 'category => updateCategoryTableForCategory(cname) - updateCategoryTableForDomain(cname,getConstrCat( - GETDATABASE(cname,'CONSTRUCTORCATEGORY))) ---+ - kind = 'domain and $NRTflag = true => - updateCategoryTableForDomain(cname,getConstrCat( - GETDATABASE(cname,'CONSTRUCTORCATEGORY))) - -updateCategoryTableForCategory(cname) == - clearTempCategoryTable([[cname,'category]]) - addToCategoryTable(cname) - for id in HKEYS _*ANCESTORS_-HASH_* repeat - for (u:=[.,:b]) in GETDATABASE(id,'ANCESTORS) repeat - RPLACD(u,simpCatPredicate simpBool b) - -updateCategoryTableForDomain(cname,category) == - clearCategoryTable(cname) - [cname,:domainEntry]:= addDomainToTable(cname,category) - for [a,:b] in encodeCategoryAlist(cname,domainEntry) repeat - HPUT(_*HASCATEGORY_-HASH_*,[cname,:a],b) - $doNotCompressHashTableIfTrue = true => _*HASCATEGORY_-HASH_* - compressHashTable _*HASCATEGORY_-HASH_* - -clearCategoryTable($cname) == - MAPHASH('clearCategoryTable1,_*HASCATEGORY_-HASH_*) - -clearCategoryTable1(key,val) == - (CAR key=$cname)=> HREM(_*HASCATEGORY_-HASH_*,key) - nil - -clearTempCategoryTable(catNames) == - for key in HKEYS(_*ANCESTORS_-HASH_*) repeat - MEMQ(key,catNames) => nil - extensions:= nil - for (extension:= [catForm,:.]) in GETDATABASE(key,'ANCESTORS) - repeat - MEMQ(CAR catForm,catNames) => nil - extensions:= [extension,:extensions] - HPUT(_*ANCESTORS_-HASH_*,key,extensions) - - - - - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} -- cgit v1.2.3