diff --git a/changelog b/changelog index be4066a..f6b39c0 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090827 tpd src/axiom-website/patches.html 20090827.03.tpd.patch +20090827 tpd src/interp/Makefile move category.boot to category.lisp +20090827 tpd src/interp/category.lisp added, rewritten from category.boot +20090827 tpd src/interp/category.boot removed, rewritten to category.lisp 20090827 tpd src/axiom-website/patches.html 20090827.02.tpd.patch 20090827 tpd src/interp/Makefile move c-doc.boot to c-doc.lisp 20090827 tpd src/interp/c-doc.lisp added, rewritten from c-doc.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 24b1e12..ed3d76c 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1914,5 +1914,7 @@ termrw.lisp rewrite from boot to lisp
fortcall.lisp rewrite from boot to lisp
20090827.02.tpd.patch c-doc.lisp rewrite from boot to lisp
+20090827.03.tpd.patch +category.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 1f8aace..5b869a4 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -2270,53 +2270,27 @@ ${DOC}/nag-s.boot.dvi: ${IN}/nag-s.boot.pamphlet @ -\subsection{category.boot \cite{58}} -<>= -${AUTO}/category.${O}: ${OUT}/category.${O} - @ echo 210 making ${AUTO}/ category.${O} from ${OUT}/category.${O} - @ cp ${OUT}/category.${O} ${AUTO} - -@ +\subsection{category.lisp} <>= -${OUT}/category.${O}: ${MID}/category.clisp - @ echo 211 making ${OUT}/category.${O} from ${MID}/category.clisp - @ (cd ${MID} ; \ +${OUT}/category.${O}: ${MID}/category.lisp + @ echo 136 making ${OUT}/category.${O} from ${MID}/category.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/category.clisp"' \ + echo '(progn (compile-file "${MID}/category.lisp"' \ ':output-file "${OUT}/category.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/category.clisp"' \ + echo '(progn (compile-file "${MID}/category.lisp"' \ ':output-file "${OUT}/category.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/category.clisp: ${IN}/category.boot.pamphlet - @ echo 212 making ${MID}/category.clisp \ - from ${IN}/category.boot.pamphlet +<>= +${MID}/category.lisp: ${IN}/category.lisp.pamphlet + @ echo 137 making ${MID}/category.lisp from \ + ${IN}/category.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/category.boot.pamphlet >category.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "category.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "category.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm category.boot ) - -@ -<>= -${DOC}/category.boot.dvi: ${IN}/category.boot.pamphlet - @echo 213 making ${DOC}/category.boot.dvi \ - from ${IN}/category.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/category.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} category.boot ; \ - rm -f ${DOC}/category.boot.pamphlet ; \ - rm -f ${DOC}/category.boot.tex ; \ - rm -f ${DOC}/category.boot ) + ${TANGLE} ${IN}/category.lisp.pamphlet >category.lisp ) @ @@ -5460,10 +5434,8 @@ clean: <> <> -<> <> -<> -<> +<> <> <> diff --git a/src/interp/category.boot.pamphlet b/src/interp/category.boot.pamphlet deleted file mode 100644 index 097ede9..0000000 --- a/src/interp/category.boot.pamphlet +++ /dev/null @@ -1,707 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp category.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{Category} -Functions for building categories. - -Sorry to say, this hack is needed by isCategoryType -<<*>>= -Category() == nil - -@ -\subsection{CategoryPrint} -<<*>>= -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 - -@ -\subsection{sigParams} -This code is a performance improvement by Waldek Hebisch. -The essence of the speedup appears to be caused by two factors. -The original code was non-recursive and used union across lists. -The new code is recursive. It also uses a hashtable to reduce -the amount of redundant list construction. - -We compute the list of parameters that occur in signatures on the -sigList, removing duplicates, and skipping the ``known'' constructors, -Union, Mapping, List, and Record. - -\verb|$PrimitiveDomainNames| is a list of domains that we need not cache. -It is set in init.lisp.pamphlet. -<<*>>= -sigParams(sigList) == - result:=nil - myhash:=MAKE_-HASHTABLE 'EQUAL - NewLocals:=nil - for s in sigList repeat - (NewLocals:=Prepare(CADAR s,NewLocals)) where - Prepare(u,l)==for v in u repeat l:=Prepare2(v,l) - Prepare2(v,l)== - v is "$" => l - STRINGP v => l - atom v => [v,:l] - MEMQ(first v,$PrimitiveDomainNames) => l - v is ["Union",:w] => - for x in stripUnionTags w repeat l:=Prepare2(x,l) - l - v is ["Mapping",:w] => - for x in w repeat l:=Prepare2(x,l) - l - v is ["List",:w] => Prepare2(w,l) - v is ["Record",:w] => - for x in w repeat l:=Prepare2(CADDR x,l) - l - [v,:l] - for s in NewLocals repeat - if null(HGET(myhash,s)) then - HPUT(myhash,s,true) - result:=[s,:result] - result - -@ -\subsection{mkCategory} -This code defines the structure of a category. It creates a new category -vector. The arguments are: -\begin{itemize} -\item domainOrPackage -- ``domain'' or ``package'' which marks the kind -of category object. -\item sigList -- list of all signatures -\item attList -- list of all attributes -\item domList -\item PrincipalAncestor -- principal ancestor (if any) -\end{itemize} -<<*>>= -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:= sigParams(sigList) - 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 - -@ -\subsection{isCategory} -<<*>>= -isCategory a == REFVECP a and #a>5 and a.3=["Category"] - -@ -\subsection{DropImplementations} -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 - -@ -\subsection{SigListUnion} -<<*>>= -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() -- 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 - -@ -\subsection{mkOr} -<<*>>= -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] - -@ -\subsection{mkOr2} -<<*>>= -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] - -@ -\subsection{mkAnd} -<<*>>= -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] - -@ -\subsection{mkAnd2} -<<*>>= -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] - -@ -\subsection{SigListMember} -<<*>>= -SigListMember(m,list) == - list=nil => false - SigEqual(m,first list) => true - SigListMember(m,rest list) - -@ -\subsection{SigEqual} -<<*>>= -SigEqual([sig1,pred1,:.],[sig2,pred2,:.]) == - -- Notice asymmetry: checks that arg1 is a consequence of arg2 - sig1=sig2 and PredImplies(pred2,pred1) - -@ -\subsection{PredImplies} -<<*>>= -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 - -@ -\subsection{SigListOpSubsume} -<<*>>= -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 - -@ -\subsection{SigOpsubsume} -<<*>>= -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) - -@ -\subsection{SourceLevelSubsume} -<<*>>= -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]) - -@ -\subsection{SourceLevelSubset} -<<*>>= -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,GET(b,"Subsets")) => true - a is [a1] and b is [b1] and ASSOC(a1,GET(b1,"Subsets")) => true - nil - -@ -\subsection{MachineLevelSubsume} -<<*>>= -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] - ) - -@ -\subsection{MachineLevelSubset} -<<*>>= -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,GET(b,"Subsets")) => true - a is [a1] and b is [b1] and ASSOC(a1,GET(b1,"Subsets")) => true - --we assume all subsets are true at the machine level - nil - -@ -\subsection{FindFundAncs} -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 - -@ -\subsection{CatEval} -<<*>>= -CatEval x == - REFVECP x => x - $InteractiveMode => CAR compMakeCategoryObject(x,$CategoryFrame) - CAR compMakeCategoryObject(x,$e) - -@ -\subsection{AncestorP} -<<*>>= -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 - -@ -\subsection{CondAncestorP} -<<*>>= -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' - -@ -\subsection{DescendantP} -<<*>>= -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 - -@ -\subsection{JoinInner} -The implementation of Join -\subsubsection{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. -<<*>>= -JoinInner(l,$e) == - $NewCatVec: local := nil - 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) - -@ -\subsection{isCategoryForm} -<<*>>= -isCategoryForm(x,e) == - x is [name,:.] => categoryForm? name - atom x => u:= get(x,"macro",e) => isCategoryForm(u,e) - -@ -\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. - -@ -\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/category.lisp.pamphlet b/src/interp/category.lisp.pamphlet new file mode 100644 index 0000000..2a36fe6 --- /dev/null +++ b/src/interp/category.lisp.pamphlet @@ -0,0 +1,2345 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp category.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{Category} +Functions for building categories. + +Sorry to say, this hack is needed by isCategoryType +<<*>>= +(IN-PACKAGE "BOOT" ) + +;Category() == nil + +(DEFUN |Category| NIL NIL) + +@ +\subsection{CategoryPrint} +<<*>>= +;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 + +(DEFUN |CategoryPrint| (D |$e|) + (DECLARE (SPECIAL |$e|)) + (PROG (|u|) + (RETURN + (SEQ (PROGN + (SAY (MAKESTRING "--------------------------------------")) + (SAY (MAKESTRING "Name (and arguments) of category:")) + (PRETTYPRINT (ELT D 0)) + (SAY (MAKESTRING "operations:")) + (PRETTYPRINT (ELT D 1)) + (SAY (MAKESTRING "attributes:")) + (PRETTYPRINT (ELT D 2)) + (SAY (MAKESTRING "This is a sub-category of")) + (PRETTYPRINT (CAR (ELT D 4))) + (DO ((G166065 (CADR (ELT D 4)) (CDR G166065)) + (|u| NIL)) + ((OR (ATOM G166065) + (PROGN (SETQ |u| (CAR G166065)) NIL)) + NIL) + (SEQ (EXIT (SAY (MAKESTRING + "This has an alternate view: slot ") + (CDR |u|) + (MAKESTRING " corresponds to ") + (CAR |u|))))) + (DO ((G166074 (CADDR (ELT D 4)) (CDR G166074)) + (|u| NIL)) + ((OR (ATOM G166074) + (PROGN (SETQ |u| (CAR G166074)) NIL)) + NIL) + (SEQ (EXIT (SAY (MAKESTRING + "This has a local domain: slot ") + (CDR |u|) + (MAKESTRING " corresponds to ") + (CAR |u|))))) + (DO ((G166085 (MAXINDEX D)) (|j| 6 (+ |j| 1))) + ((> |j| G166085) NIL) + (SEQ (EXIT (PROGN + (SPADLET |u| (ELT D |j|)) + (COND + ((NULL |u|) + (SAY (MAKESTRING "another domain"))) + ((ATOM (CAR |u|)) + (SAY (MAKESTRING + "Alternate View corresponding to: ") + |u|)) + ('T (PRETTYPRINT |u|)))))))))))) + +@ +\subsection{sigParams} +This code is a performance improvement by Waldek Hebisch. +The essence of the speedup appears to be caused by two factors. +The original code was non-recursive and used union across lists. +The new code is recursive. It also uses a hashtable to reduce +the amount of redundant list construction. + +We compute the list of parameters that occur in signatures on the +sigList, removing duplicates, and skipping the ``known'' constructors, +Union, Mapping, List, and Record. + +\verb|$PrimitiveDomainNames| is a list of domains that we need not cache. +It is set in init.lisp.pamphlet. +<<*>>= +;sigParams(sigList) == +; result:=nil +; myhash:=MAKE_-HASHTABLE 'EQUAL +; NewLocals:=nil +; for s in sigList repeat +; (NewLocals:=Prepare(CADAR s,NewLocals)) where +; Prepare(u,l)==for v in u repeat l:=Prepare2(v,l) +; Prepare2(v,l)== +; v is "$" => l +; STRINGP v => l +; atom v => [v,:l] +; MEMQ(first v,$PrimitiveDomainNames) => l +; v is ["Union",:w] => +; for x in stripUnionTags w repeat l:=Prepare2(x,l) +; l +; v is ["Mapping",:w] => +; for x in w repeat l:=Prepare2(x,l) +; l +; v is ["List",:w] => Prepare2(w,l) +; v is ["Record",:w] => +; for x in w repeat l:=Prepare2(CADDR x,l) +; l +; [v,:l] +; for s in NewLocals repeat +; if null(HGET(myhash,s)) then +; HPUT(myhash,s,true) +; result:=[s,:result] +; result + +(DEFUN |sigParams,Prepare2| (|v| |l|) + (PROG (|w|) + (RETURN + (SEQ (IF (EQ |v| '$) (EXIT |l|)) (IF (STRINGP |v|) (EXIT |l|)) + (IF (ATOM |v|) (EXIT (CONS |v| |l|))) + (IF (MEMQ (CAR |v|) |$PrimitiveDomainNames|) (EXIT |l|)) + (IF (AND (PAIRP |v|) (EQ (QCAR |v|) '|Union|) + (PROGN (SPADLET |w| (QCDR |v|)) 'T)) + (EXIT (SEQ (DO ((G166101 (|stripUnionTags| |w|) + (CDR G166101)) + (|x| NIL)) + ((OR (ATOM G166101) + (PROGN + (SETQ |x| (CAR G166101)) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |l| + (|sigParams,Prepare2| |x| |l|))))) + (EXIT |l|)))) + (IF (AND (PAIRP |v|) (EQ (QCAR |v|) '|Mapping|) + (PROGN (SPADLET |w| (QCDR |v|)) 'T)) + (EXIT (SEQ (DO ((G166110 |w| (CDR G166110)) + (|x| NIL)) + ((OR (ATOM G166110) + (PROGN + (SETQ |x| (CAR G166110)) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |l| + (|sigParams,Prepare2| |x| |l|))))) + (EXIT |l|)))) + (IF (AND (PAIRP |v|) (EQ (QCAR |v|) '|List|) + (PROGN (SPADLET |w| (QCDR |v|)) 'T)) + (EXIT (|sigParams,Prepare2| |w| |l|))) + (IF (AND (PAIRP |v|) (EQ (QCAR |v|) '|Record|) + (PROGN (SPADLET |w| (QCDR |v|)) 'T)) + (EXIT (SEQ (DO ((G166119 |w| (CDR G166119)) + (|x| NIL)) + ((OR (ATOM G166119) + (PROGN + (SETQ |x| (CAR G166119)) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |l| + (|sigParams,Prepare2| + (CADDR |x|) |l|))))) + (EXIT |l|)))) + (EXIT (CONS |v| |l|)))))) + +(DEFUN |sigParams,Prepare| (|u| |l|) + (SEQ (DO ((G166138 |u| (CDR G166138)) (|v| NIL)) + ((OR (ATOM G166138) + (PROGN (SETQ |v| (CAR G166138)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |l| (|sigParams,Prepare2| |v| |l|))))))) + +(DEFUN |sigParams| (|sigList|) + (PROG (|myhash| |NewLocals| |result|) + (RETURN + (SEQ (PROGN + (SPADLET |result| NIL) + (SPADLET |myhash| (MAKE-HASHTABLE 'EQUAL)) + (SPADLET |NewLocals| NIL) + (DO ((G166154 |sigList| (CDR G166154)) (|s| NIL)) + ((OR (ATOM G166154) + (PROGN (SETQ |s| (CAR G166154)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |NewLocals| + (|sigParams,Prepare| (CADAR |s|) + |NewLocals|))))) + (DO ((G166163 |NewLocals| (CDR G166163)) (|s| NIL)) + ((OR (ATOM G166163) + (PROGN (SETQ |s| (CAR G166163)) NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (HGET |myhash| |s|)) + (HPUT |myhash| |s| 'T) + (SPADLET |result| (CONS |s| |result|))) + ('T NIL))))) + |result|))))) + +@ +\subsection{mkCategory} +This code defines the structure of a category. It creates a new category +vector. The arguments are: +\begin{itemize} +\item domainOrPackage -- ``domain'' or ``package'' which marks the kind +of category object. +\item sigList -- list of all signatures +\item attList -- list of all attributes +\item domList +\item PrincipalAncestor -- principal ancestor (if any) +\end{itemize} +<<*>>= +;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:= sigParams(sigList) +; 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 + +(DEFUN |mkCategory| + (|domainOrPackage| |sigList| |attList| |domList| + |PrincipalAncestor|) + (PROG (|sig| |pred| |ISTMP#1| |ISTMP#2| |impl| |num| |NSigList| + |NewLocals| |OldLocals| |count| |v| |nsig| |sequence|) + (RETURN + (SEQ (PROGN + (SPADLET |NSigList| NIL) + (COND + ((NULL |PrincipalAncestor|) (SPADLET |count| 6)) + ('T (SPADLET |count| (SIZE |PrincipalAncestor|)))) + (SPADLET |sigList| + (PROG (G166221) + (SPADLET G166221 NIL) + (RETURN + (DO ((G166239 |sigList| (CDR G166239)) + (|s| NIL)) + ((OR (ATOM G166239) + (PROGN + (SETQ |s| (CAR G166239)) + NIL)) + (NREVERSE0 G166221)) + (SEQ (EXIT (SETQ G166221 + (CONS + (COND + ((AND (PAIRP |s|) + (PROGN + (SPADLET |sig| + (QCAR |s|)) + (SPADLET |ISTMP#1| + (QCDR |s|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) + NIL) + (PROGN + (SPADLET |pred| + (QCAR |ISTMP#1|)) + 'T)))) + (COND + ((PROG (G166245) + (SPADLET G166245 + NIL) + (RETURN + (DO + ((G166259 NIL + G166245) + (G166260 + |NSigList| + (CDR G166260)) + (|x| NIL)) + ((OR G166259 + (ATOM G166260) + (PROGN + (SETQ |x| + (CAR + G166260)) + NIL)) + G166245) + (SEQ + (EXIT + (SETQ G166245 + (OR G166245 + (AND + (PAIRP |x|) + (PROGN + (SPADLET + |ISTMP#1| + (QCAR |x|)) + (AND + (PAIRP + |ISTMP#1|) + (EQUAL + (QCAR + |ISTMP#1|) + |sig|) + (PROGN + (SPADLET + |ISTMP#2| + (QCDR + |ISTMP#1|)) + (AND + (PAIRP + |ISTMP#2|) + (PROGN + (SPADLET + |impl| + (QCDR + |ISTMP#2|)) + 'T))))) + (PROGN + (SPADLET + |num| + (QCDR |x|)) + 'T))))))))) + (CONS |sig| + (CONS |pred| |impl|))) + ('T + (SPADLET |num| + (COND + ((BOOT-EQUAL + |domainOrPackage| + '|domain|) + |count|) + ('T + (SPADDIFFERENCE + |count| 5)))) + (SPADLET |nsig| + (|mkOperatorEntry| + '|domain| |sig| |pred| + |num|)) + (SPADLET |NSigList| + (CONS + (CONS |nsig| |count|) + |NSigList|)) + (SPADLET |count| + (PLUS |count| 1)) + |nsig|))) + ('T |s|)) + G166221)))))))) + (SPADLET |NewLocals| (|sigParams| |sigList|)) + (SPADLET |OldLocals| NIL) + (COND + (|PrincipalAncestor| + (DO ((G166270 + (SPADLET |OldLocals| + (CADDR + (ELT |PrincipalAncestor| 4))) + (CDR G166270)) + (|u| NIL)) + ((OR (ATOM G166270) + (PROGN (SETQ |u| (CAR G166270)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |NewLocals| + (|delete| (CAR |u|) + |NewLocals|))))))) + (DO ((G166281 |NewLocals| (CDR G166281)) (|u| NIL)) + ((OR (ATOM G166281) + (PROGN (SETQ |u| (CAR G166281)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |OldLocals| + (CONS (CONS |u| |count|) + |OldLocals|)) + (SPADLET |count| (PLUS |count| 1)))))) + (SPADLET |v| (GETREFV |count|)) + (SETELT |v| 0 NIL) + (SETELT |v| 1 |sigList|) + (SETELT |v| 2 |attList|) + (SETELT |v| 3 (CONS '|Category| NIL)) + (COND + ((NULL (NULL |PrincipalAncestor|)) + (DO ((G166290 + (SPADDIFFERENCE (SIZE |PrincipalAncestor|) 1)) + (|x| 6 (+ |x| 1))) + ((> |x| G166290) NIL) + (SEQ (EXIT (SETELT |v| |x| + (ELT |PrincipalAncestor| |x|))))) + (SETELT |v| 4 + (CONS (CAR (ELT |PrincipalAncestor| 4)) + (CONS (CADR (ELT |PrincipalAncestor| 4)) + (CONS |OldLocals| NIL))))) + ('T + (SETELT |v| 4 + (CONS NIL (CONS NIL (CONS |OldLocals| NIL)))))) + (SETELT |v| 5 |domList|) + (DO ((G166298 |NSigList| (CDR G166298)) + (G166199 NIL)) + ((OR (ATOM G166298) + (PROGN (SETQ G166199 (CAR G166298)) NIL) + (PROGN + (PROGN + (SPADLET |nsig| (CAR G166199)) + (SPADLET |sequence| (CDR G166199)) + G166199) + NIL)) + NIL) + (SEQ (EXIT (SETELT |v| |sequence| |nsig|)))) + |v|))))) + +@ +\subsection{isCategory} +<<*>>= +;isCategory a == REFVECP a and #a>5 and a.3=["Category"] + +(DEFUN |isCategory| (|a|) + (AND (REFVECP |a|) (> (|#| |a|) 5) + (BOOT-EQUAL (ELT |a| 3) (CONS '|Category| NIL)))) + +@ +\subsection{DropImplementations} +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 + +(DEFUN |DropImplementations| (|a|) + (PROG (|sig| |pred| |implem| |ISTMP#1| |q|) + (RETURN + (PROGN + (SPADLET |sig| (CAR |a|)) + (SPADLET |pred| (CADR |a|)) + (SPADLET |implem| (CDDR |a|)) + (COND + ((AND (PAIRP |implem|) (EQ (QCDR |implem|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |implem|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |q| (QCAR |ISTMP#1|)) 'T))) + (OR (BOOT-EQUAL |q| 'ELT) (BOOT-EQUAL |q| 'CONST))) + (COND + ((BOOT-EQUAL |q| 'ELT) (CONS |sig| (CONS |pred| NIL))) + ('T (CONS (APPEND |sig| '(|constant|)) (CONS |pred| NIL))))) + ('T |a|)))))) + +@ +\subsection{SigListUnion} +<<*>>= +;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() -- 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 + +(DEFUN |SigListUnion| (|extra| |original|) + (PROG (|ofn| |osig| |opred| |xfn| |xsig| |xpred| |ximplem| |epred| + |eimplem| |esig| |e| |ISTMP#1| |q| |ISTMP#2| |ISTMP#3| + |index|) + (RETURN + (SEQ (PROGN + (DO ((G166422 |original| (CDR G166422)) (|o| NIL)) + ((OR (ATOM G166422) + (PROGN (SETQ |o| (CAR G166422)) NIL) + (PROGN + (PROGN + (SPADLET |ofn| (CAAR |o|)) + (SPADLET |osig| (CADAR |o|)) + (SPADLET |opred| (CADR |o|)) + |o|) + NIL)) + NIL) + (SEQ (EXIT (DO ((G166436 + (|SigListOpSubsume| |o| |extra|) + (CDR G166436)) + (|x| NIL)) + ((OR (ATOM G166436) + (PROGN + (SETQ |x| (CAR G166436)) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |xfn| (CAAR |x|)) + (SPADLET |xsig| (CADAR |x|)) + (SPADLET |xpred| (CADR |x|)) + (COND + ((AND + (BOOT-EQUAL |xfn| |ofn|) + (BOOT-EQUAL |xsig| |osig|)) + (COND + ((BOOT-EQUAL |xpred| + |opred|) + (SPADLET |extra| + (|delete| |x| |extra|))) + ((BOOT-EQUAL |opred| 'T) + (SPADLET |extra| + (|delete| |x| |extra|))))) + ((NULL + (|MachineLevelSubsume| + (QCAR |o|) (QCAR |x|))) + (MAKESTRING + "Source level subsumption not implemented")) + ('T + (SPADLET |extra| + (|delete| |x| |extra|))))))))))) + (DO ((G166463 |extra| (CDR G166463)) (|e| NIL)) + ((OR (ATOM G166463) + (PROGN (SETQ |e| (CAR G166463)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |esig| (CAR |e|)) + (SPADLET |epred| (CADR |e|)) + (SPADLET |eimplem| NIL) + (DO ((G166485 + (|SigListOpSubsume| |e| + |original|) + (CDR G166485)) + (|x| NIL)) + ((OR (ATOM G166485) + (PROGN + (SETQ |x| (CAR G166485)) + NIL)) + NIL) + (SEQ (EXIT + (COND + ((NULL + (|MachineLevelSubsume| + (QCAR |e|) (QCAR |x|))) + (SPADLET |original| + (CONS |e| |original|)) + (RETURN)) + ('T + (SPADLET |original| + (|delete| |x| |original|)) + (SPADLET |xsig| (CAR |x|)) + (SPADLET |xpred| (CADR |x|)) + (SPADLET |ximplem| (CDDR |x|)) + (COND + ((OR + (NEQUAL (CAR |xsig|) + (CAR |esig|)) + (NEQUAL (CADR |xsig|) + (CADR |esig|))) + (COND + ((AND (PAIRP |ximplem|) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |ximplem|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) + '|Subsumed|)))) + (SPADLET |original| + (CONS |x| |original|))) + ('T + (SPADLET |original| + (CONS + (CONS |xsig| + (CONS |xpred| + (CONS + (CONS '|Subsumed| + |esig|) + NIL))) + |original|))))) + ('T + (SPADLET |epred| + (|mkOr| |epred| |xpred|)))) + (COND + ((NULL + (AND (PAIRP |ximplem|) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |ximplem|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) + '|Subsumed|))))) + (SPADLET |eimplem| |ximplem|))) + (COND + (|eimplem| + (SPADLET |esig| + (CONS (CAR |esig|) + (CONS (CADR |esig|) NIL))))) + (SPADLET |e| + (CONS |esig| + (CONS |epred| |eimplem|))) + (COND + ((AND (PAIRP |ximplem|) + (EQ (QCDR |ximplem|) NIL) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |ximplem|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |q| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ + (QCDR |ISTMP#3|) + NIL) + (PROGN + (SPADLET |index| + (QCAR |ISTMP#3|)) + 'T))))))) + (INTEGERP |index|) + (OR (BOOT-EQUAL |q| 'ELT) + (BOOT-EQUAL |q| 'CONST))) + (SETELT |$NewCatVec| |index| + |e|)) + ('T NIL))))))) + (SPADLET |original| (CONS |e| |original|)))))) + |original|))))) + +@ +\subsection{mkOr} +<<*>>= +;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] + +(DEFUN |mkOr| (|a| |b|) + (PROG (|avar| |acat| |ISTMP#1| |ISTMP#2| |bcat| |a'| |b'| |l|) + (RETURN + (COND + ((BOOT-EQUAL |a| 'T) 'T) + ((BOOT-EQUAL |b| 'T) 'T) + ((BOOT-EQUAL |b| |a|) |a|) + ('T + (SPADLET |l| + (COND + ((AND (PAIRP |a|) (EQ (QCAR |a|) 'OR) + (PROGN (SPADLET |a'| (QCDR |a|)) 'T)) + (COND + ((AND (PAIRP |b|) (EQ (QCAR |b|) 'OR) + (PROGN (SPADLET |b'| (QCDR |b|)) 'T)) + (|union| |a'| |b'|)) + ('T (|mkOr2| |b| |a'|)))) + ((AND (PAIRP |b|) (EQ (QCAR |b|) 'OR) + (PROGN (SPADLET |b'| (QCDR |b|)) 'T)) + (|mkOr2| |a| |b'|)) + ((AND (PAIRP |a|) (EQ (QCAR |a|) '|has|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |avar| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |acat| (QCAR |ISTMP#2|)) + 'T))))) + (PAIRP |b|) (EQ (QCAR |b|) '|has|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |b|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |avar|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |bcat| (QCAR |ISTMP#2|)) + 'T)))))) + (COND + ((|DescendantP| |acat| |bcat|) (LIST |b|)) + ((|DescendantP| |bcat| |acat|) (LIST |a|)) + ('T (CONS |a| (CONS |b| NIL))))) + ((AND (PAIRP |a|) (EQ (QCAR |a|) 'AND) + (PROGN (SPADLET |a'| (QCDR |a|)) 'T) + (|member| |b| |a'|)) + (LIST |b|)) + ((AND (PAIRP |b|) (EQ (QCAR |b|) 'AND) + (PROGN (SPADLET |b'| (QCDR |b|)) 'T) + (|member| |a| |b'|)) + (LIST |a|)) + ((AND (PAIRP |a|) (EQ (QCAR |a|) '|and|) + (PROGN (SPADLET |a'| (QCDR |a|)) 'T) + (|member| |b| |a'|)) + (LIST |b|)) + ((AND (PAIRP |b|) (EQ (QCAR |b|) '|and|) + (PROGN (SPADLET |b'| (QCDR |b|)) 'T) + (|member| |a| |b'|)) + (LIST |a|)) + ('T (CONS |a| (CONS |b| NIL))))) + (COND ((EQL (LENGTH |l|) 1) (CAR |l|)) ('T (CONS 'OR |l|)))))))) + +@ +\subsection{mkOr2} +<<*>>= +;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] + +(DEFUN |mkOr2| (|a| |b|) + (PROG (|avar| |acat| |ISTMP#1| |ISTMP#2| |ccat| |aRedundant|) + (RETURN + (SEQ (COND + ((|member| |a| |b|) |b|) + ((AND (PAIRP |a|) (EQ (QCAR |a|) '|has|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |avar| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |acat| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |aRedundant| NIL) + (DO ((G166606 |b| (CDR G166606)) (|c| NIL)) + ((OR (ATOM G166606) + (PROGN (SETQ |c| (CAR G166606)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |c|) (EQ (QCAR |c|) '|has|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |c|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |avar|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ccat| + (QCAR |ISTMP#2|)) + 'T)))))) + (COND + ((|DescendantP| |acat| |ccat|) + (RETURN (SPADLET |aRedundant| 'T))) + ((|DescendantP| |ccat| |acat|) + (SPADLET |b| (|delete| |c| |b|))) + ('T NIL))))))) + (COND (|aRedundant| |b|) ('T (CONS |a| |b|)))) + ('T (CONS |a| |b|))))))) + +@ +\subsection{mkAnd} +<<*>>= +;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] + +(DEFUN |mkAnd| (|a| |b|) + (PROG (|a'| |b'| |avar| |acat| |ISTMP#1| |ISTMP#2| |bcat| |l|) + (RETURN + (COND + ((BOOT-EQUAL |a| 'T) |b|) + ((BOOT-EQUAL |b| 'T) |a|) + ((BOOT-EQUAL |b| |a|) |a|) + ('T + (SPADLET |l| + (COND + ((AND (PAIRP |a|) (EQ (QCAR |a|) 'AND) + (PROGN (SPADLET |a'| (QCDR |a|)) 'T)) + (COND + ((AND (PAIRP |b|) (EQ (QCAR |b|) 'AND) + (PROGN (SPADLET |b'| (QCDR |b|)) 'T)) + (|union| |a'| |b'|)) + ('T (|mkAnd2| |b| |a'|)))) + ((AND (PAIRP |b|) (EQ (QCAR |b|) 'AND) + (PROGN (SPADLET |b'| (QCDR |b|)) 'T)) + (|mkAnd2| |a| |b'|)) + ((AND (PAIRP |a|) (EQ (QCAR |a|) '|has|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |avar| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |acat| (QCAR |ISTMP#2|)) + 'T))))) + (PAIRP |b|) (EQ (QCAR |b|) '|has|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |b|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |avar|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |bcat| (QCAR |ISTMP#2|)) + 'T)))))) + (COND + ((|DescendantP| |acat| |bcat|) (LIST |a|)) + ((|DescendantP| |bcat| |acat|) (LIST |b|)) + ('T (CONS |a| (CONS |b| NIL))))) + ('T (CONS |a| (CONS |b| NIL))))) + (COND ((EQL (LENGTH |l|) 1) (CAR |l|)) ('T (CONS 'AND |l|)))))))) + +@ +\subsection{mkAnd2} +<<*>>= +;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] + +(DEFUN |mkAnd2| (|a| |b|) + (PROG (|avar| |acat| |ISTMP#1| |ISTMP#2| |ccat| |aRedundant|) + (RETURN + (SEQ (COND + ((|member| |a| |b|) |b|) + ((AND (PAIRP |a|) (EQ (QCAR |a|) '|has|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |avar| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |acat| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |aRedundant| NIL) + (DO ((G166702 |b| (CDR G166702)) (|c| NIL)) + ((OR (ATOM G166702) + (PROGN (SETQ |c| (CAR G166702)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |c|) (EQ (QCAR |c|) '|has|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |c|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |avar|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ccat| + (QCAR |ISTMP#2|)) + 'T)))))) + (COND + ((|DescendantP| |ccat| |acat|) + (RETURN (SPADLET |aRedundant| 'T))) + ((|DescendantP| |acat| |ccat|) + (SPADLET |b| (|delete| |c| |b|))) + ('T NIL))))))) + (COND (|aRedundant| |b|) ('T (CONS |a| |b|)))) + ('T (CONS |a| |b|))))))) + +@ +\subsection{SigListMember} +<<*>>= +;SigListMember(m,list) == +; list=nil => false +; SigEqual(m,first list) => true +; SigListMember(m,rest list) + +(DEFUN |SigListMember| (|m| LIST) + (COND + ((NULL LIST) NIL) + ((|SigEqual| |m| (CAR LIST)) 'T) + ('T (|SigListMember| |m| (CDR LIST))))) + +@ +\subsection{SigEqual} +<<*>>= +;SigEqual([sig1,pred1,:.],[sig2,pred2,:.]) == +; -- Notice asymmetry: checks that arg1 is a consequence of arg2 +; sig1=sig2 and PredImplies(pred2,pred1) + +(DEFUN |SigEqual| (G166725 G166734) + (PROG (|sig2| |pred2| |sig1| |pred1|) + (RETURN + (PROGN + (SPADLET |sig2| (CAR G166734)) + (SPADLET |pred2| (CADR G166734)) + (SPADLET |sig1| (CAR G166725)) + (SPADLET |pred1| (CADR G166725)) + (AND (BOOT-EQUAL |sig1| |sig2|) + (|PredImplies| |pred2| |pred1|)))))) + +@ +\subsection{PredImplies} +<<*>>= +;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 + +(DEFUN |PredImplies| (|a| |b|) + (COND ((BOOT-EQUAL |a| 'T) 'T) ((BOOT-EQUAL |a| |b|) 'T) ('T NIL))) + +@ +\subsection{SigListOpSubsume} +<<*>>= +;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 + +(DEFUN |SigListOpSubsume| (G166762 LIST) + (PROG (|name1| |sig1| |lsig1| |name2| |sig2| |ans|) + (RETURN + (SEQ (PROGN + (SPADLET |name1| (CAAR G166762)) + (SPADLET |sig1| (CADAR G166762)) + (SPADLET |lsig1| (LENGTH |sig1|)) + (SPADLET |ans| NIL) + (SEQ (DO ((G166778 LIST (CDR G166778)) (|n| NIL)) + ((OR (ATOM G166778) + (PROGN (SETQ |n| (CAR G166778)) NIL) + (PROGN + (PROGN + (SPADLET |name2| (CAAR |n|)) + (SPADLET |sig2| (CADAR |n|)) + |n|) + NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (BOOT-EQUAL |name1| |name2|) + (EQ |lsig1| (LENGTH |sig2|)) + (|SourceLevelSubsume| |sig1| + |sig2|)) + (EXIT (SPADLET |ans| + (CONS |n| |ans|)))))))) + (RETURN |ans|))))))) + +@ +\subsection{SigOpsubsume} +<<*>>= +;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) + +(DEFUN |SigOpsubsume| (G166795 G166808) + (PROG (|name2| |sig2| |flag2| |pred2| |name1| |sig1| |flag1| |pred1|) + (RETURN + (PROGN + (SPADLET |name2| (CAAR G166808)) + (SPADLET |sig2| (CADAR G166808)) + (SPADLET |flag2| (CDDAR G166808)) + (SPADLET |pred2| (CADR G166808)) + (SPADLET |name1| (CAAR G166795)) + (SPADLET |sig1| (CADAR G166795)) + (SPADLET |flag1| (CDDAR G166795)) + (SPADLET |pred1| (CADR G166795)) + (AND (BOOT-EQUAL |name1| |name2|) + (BOOT-EQUAL (LENGTH |sig1|) (LENGTH |sig2|)) + (|SourceLevelSubsume| |sig1| |sig2|)))))) + +@ +\subsection{SourceLevelSubsume} +<<*>>= +;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]) + +(DEFUN |SourceLevelSubsume| (G166838 G166847) + (PROG (|out2| |in2| |out1| |in1|) + (RETURN + (SEQ (PROGN + (SPADLET |out2| (CAR G166847)) + (SPADLET |in2| (CDR G166847)) + (SPADLET |out1| (CAR G166838)) + (SPADLET |in1| (CDR G166838)) + (AND (|SourceLevelSubset| |out1| |out2|) + (PROG (G166860) + (SPADLET G166860 'T) + (RETURN + (DO ((G166867 NIL (NULL G166860)) + (G166868 |in1| (CDR G166868)) + (|inarg1| NIL) + (G166869 |in2| (CDR G166869)) + (|inarg2| NIL)) + ((OR G166867 (ATOM G166868) + (PROGN + (SETQ |inarg1| (CAR G166868)) + NIL) + (ATOM G166869) + (PROGN + (SETQ |inarg2| (CAR G166869)) + NIL)) + G166860) + (SEQ (EXIT (SETQ G166860 + (AND G166860 + (|SourceLevelSubset| |inarg2| + |inarg1|)))))))))))))) + +@ +\subsection{SourceLevelSubset} +<<*>>= +;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,GET(b,"Subsets")) => true +; a is [a1] and b is [b1] and ASSOC(a1,GET(b1,"Subsets")) => true +; nil + +(DEFUN |SourceLevelSubset| (|a| |b|) + (PROG (|blist| |a1| |b1|) + (RETURN + (COND + ((BOOT-EQUAL |a| |b|) 'T) + ((BOOT-EQUAL |$noSubsumption| 'T) NIL) + ((AND (PAIRP |b|) (EQ (QCAR |b|) '|Union|) + (PROGN (SPADLET |blist| (QCDR |b|)) 'T) + (|member| |a| |blist|)) + 'T) + ((AND (BOUNDP '|$noSubsets|) |$noSubsets|) NIL) + ((AND (ATOM |b|) (|assoc| |a| (GETL |b| '|Subsets|))) 'T) + ((AND (PAIRP |a|) (EQ (QCDR |a|) NIL) + (PROGN (SPADLET |a1| (QCAR |a|)) 'T) (PAIRP |b|) + (EQ (QCDR |b|) NIL) (PROGN (SPADLET |b1| (QCAR |b|)) 'T) + (|assoc| |a1| (GETL |b1| '|Subsets|))) + 'T) + ('T NIL))))) + +@ +\subsection{MachineLevelSubsume} +<<*>>= +;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] +; ) + +(DEFUN |MachineLevelSubsume| (G166894 G166907) + (PROG (|name2| |out2| |in2| |flag2| |name1| |out1| |in1| |flag1|) + (RETURN + (SEQ (PROGN + (SPADLET |name2| (CAR G166907)) + (SPADLET |out2| (CAADR G166907)) + (SPADLET |in2| (CDADR G166907)) + (SPADLET |flag2| (CDDR G166907)) + (SPADLET |name1| (CAR G166894)) + (SPADLET |out1| (CAADR G166894)) + (SPADLET |in1| (CDADR G166894)) + (SPADLET |flag1| (CDDR G166894)) + (AND (BOOT-EQUAL |name1| |name2|) + (|MachineLevelSubset| |out1| |out2|) + (PROG (G166926) + (SPADLET G166926 'T) + (RETURN + (DO ((G166933 NIL (NULL G166926)) + (G166934 |in1| (CDR G166934)) + (|inarg1| NIL) + (G166935 |in2| (CDR G166935)) + (|inarg2| NIL)) + ((OR G166933 (ATOM G166934) + (PROGN + (SETQ |inarg1| (CAR G166934)) + NIL) + (ATOM G166935) + (PROGN + (SETQ |inarg2| (CAR G166935)) + NIL)) + G166926) + (SEQ (EXIT (SETQ G166926 + (AND G166926 + (|MachineLevelSubset| |inarg2| + |inarg1|)))))))))))))) + +@ +\subsection{MachineLevelSubset} +<<*>>= +;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,GET(b,"Subsets")) => true +; a is [a1] and b is [b1] and ASSOC(a1,GET(b1,"Subsets")) => true +; --we assume all subsets are true at the machine level +; nil + +(DEFUN |MachineLevelSubset| (|a| |b|) + (PROG (|blist| |a1| |b1|) + (RETURN + (SEQ (COND + ((BOOT-EQUAL |a| |b|) 'T) + ((AND (PAIRP |b|) (EQ (QCAR |b|) '|Union|) + (PROGN (SPADLET |blist| (QCDR |b|)) 'T) + (|member| |a| |blist|) + (PROG (G166958) + (SPADLET G166958 'T) + (RETURN + (DO ((G166965 NIL (NULL G166958)) + (G166966 |blist| (CDR G166966)) + (|x| NIL)) + ((OR G166965 (ATOM G166966) + (PROGN (SETQ |x| (CAR G166966)) NIL)) + G166958) + (SEQ (EXIT (COND + ((NEQUAL |x| |a|) + (SETQ G166958 + (AND G166958 (STRINGP |x|))))))))))) + 'T) + ((AND (ATOM |b|) (|assoc| |a| (GETL |b| '|Subsets|))) 'T) + ((AND (PAIRP |a|) (EQ (QCDR |a|) NIL) + (PROGN (SPADLET |a1| (QCAR |a|)) 'T) (PAIRP |b|) + (EQ (QCDR |b|) NIL) + (PROGN (SPADLET |b1| (QCAR |b|)) 'T) + (|assoc| |a1| (GETL |b1| '|Subsets|))) + 'T) + ('T NIL)))))) + +@ +\subsection{FindFundAncs} +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 + +(DEFUN |FindFundAncs| (|l|) + (PROG (|f1| |x| |y| |ans|) + (RETURN + (SEQ (COND + ((NULL |l|) NIL) + ('T (SPADLET |f1| (|CatEval| (CAAR |l|))) + (COND + ((NULL (ELT |f1| 0)) (|FindFundAncs| (CDR |l|))) + ('T (SPADLET |ans| (|FindFundAncs| (CDR |l|))) + (DO ((G166986 (|FindFundAncs| + (PROG (G166996) + (SPADLET G166996 NIL) + (RETURN + (DO + ((G167001 + (CADR (ELT |f1| 4)) + (CDR G167001)) + (|x| NIL)) + ((OR (ATOM G167001) + (PROGN + (SETQ |x| + (CAR G167001)) + NIL)) + (NREVERSE0 G166996)) + (SEQ + (EXIT + (SETQ G166996 + (CONS + (CONS + (|CatEval| (CAR |x|)) + (CONS + (|mkAnd| (CADAR |l|) + (CADR |x|)) + NIL)) + G166996)))))))) + (CDR G166986)) + (|u| NIL)) + ((OR (ATOM G166986) + (PROGN (SETQ |u| (CAR G166986)) NIL)) + NIL) + (SEQ (EXIT (COND + ((SPADLET |x| (ASSQ (CAR |u|) |ans|)) + (SPADLET |ans| + (CONS + (CONS (CAR |u|) + (CONS + (|mkOr| (CADR |x|) + (CADR |u|)) + NIL)) + (|delete| |x| |ans|)))) + ('T (SPADLET |ans| (CONS |u| |ans|))))))) + (COND + ((SPADLET |x| (ASSQ (CAAR |l|) |ans|)) + (CONS (CONS (CAAR |l|) + (CONS (|mkOr| (CADAR |l|) (CADR |x|)) + NIL)) + (|delete| |x| |ans|))) + ((BOOT-EQUAL (CADAR |l|) 'T) + (DO ((G167010 (CAR (ELT |f1| 4)) (CDR G167010)) + (|x| NIL)) + ((OR (ATOM G167010) + (PROGN (SETQ |x| (CAR G167010)) NIL)) + NIL) + (SEQ (EXIT (COND + ((SPADLET |y| + (ASSQ (|CatEval| |x|) |ans|)) + (SPADLET |ans| + (|delete| |y| |ans|))) + ('T NIL))))) + (CONS (CAR |l|) |ans|)) + ('T + (DO ((G167019 (CAR (ELT |f1| 4)) (CDR G167019)) + (|x| NIL)) + ((OR (ATOM G167019) + (PROGN (SETQ |x| (CAR G167019)) NIL)) + NIL) + (SEQ (EXIT (COND + ((SPADLET |y| + (ASSQ (|CatEval| |x|) |ans|)) + (SPADLET |ans| + (CONS + (CONS (CAR |y|) + (CONS + (|mkOr| (CADAR |l|) (CADR |y|)) + NIL)) + (|delete| |y| |ans|)))) + ('T NIL))))) + (CONS (CAR |l|) |ans|))))))))))) + +@ +\subsection{CatEval} +<<*>>= +;CatEval x == +; REFVECP x => x +; $InteractiveMode => CAR compMakeCategoryObject(x,$CategoryFrame) +; CAR compMakeCategoryObject(x,$e) + +(DEFUN |CatEval| (|x|) + (COND + ((REFVECP |x|) |x|) + (|$InteractiveMode| + (CAR (|compMakeCategoryObject| |x| |$CategoryFrame|))) + ('T (CAR (|compMakeCategoryObject| |x| |$e|))))) + +@ +\subsection{AncestorP} +<<*>>= +;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 + +(DEFUN |AncestorP| (|xname| |leaves|) + (PROG () + (RETURN + (SEQ (COND + ((|member| |xname| |leaves|) |xname|) + ('T + (DO ((G167047 |leaves| (CDR G167047)) (|y| NIL)) + ((OR (ATOM G167047) + (PROGN (SETQ |y| (CAR G167047)) NIL)) + NIL) + (SEQ (EXIT (COND + ((|member| |xname| + (CAR (ELT (|CatEval| |y|) 4))) + (EXIT (RETURN |y|))))))))))))) + +@ +\subsection{CondAncestorP} +<<*>>= +;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' + +(DEFUN |CondAncestorP| (|xname| |leaves| |condition|) + (PROG (|u'| |ucond|) + (RETURN + (SEQ (DO ((G167064 |leaves| (CDR G167064)) (|u| NIL)) + ((OR (ATOM G167064) + (PROGN (SETQ |u| (CAR G167064)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |u'| (CAR |u|)) + (SPADLET |ucond| + (COND + ((NULL (CDR |u|)) 'T) + ('T (CAR (CDR |u|))))) + (SEQ (COND + ((OR (BOOT-EQUAL |xname| |u'|) + (|member| |xname| + (CAR (ELT (|CatEval| |u'|) 4)))) + (COND + ((|PredImplies| |ucond| + |condition|) + (EXIT (RETURN |u'|))))))))))))))) + +@ +\subsection{DescendantP} +<<*>>= +;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 + +(DEFUN |DescendantP| (|a| |b|) + (PROG (|ISTMP#1| |b'| |l|) + (RETURN + (SEQ (COND + ((BOOT-EQUAL |a| |b|) 'T) + ((AND (PAIRP |a|) (EQ (QCAR |a|) 'ATTRIBUTE)) NIL) + ((AND (PAIRP |a|) (EQ (QCAR |a|) 'SIGNATURE)) NIL) + ('T (SPADLET |a| (|CatEval| |a|)) + (SEQ (COND + ((AND (PAIRP |b|) (EQ (QCAR |b|) 'ATTRIBUTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |b|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |b'| (QCAR |ISTMP#1|)) + 'T)))) + (COND + ((SPADLET |l| (|assoc| |b'| (ELT |a| 2))) + (EXIT (|TruthP| (CADR |l|)))))) + ((|member| |b| (CAR (ELT |a| 4))) 'T) + ((|AncestorP| |b| + (PROG (G167084) + (SPADLET G167084 NIL) + (RETURN + (DO ((G167089 (CADR (ELT |a| 4)) + (CDR G167089)) + (|u| NIL)) + ((OR (ATOM G167089) + (PROGN + (SETQ |u| (CAR G167089)) + NIL)) + (NREVERSE0 G167084)) + (SEQ (EXIT + (SETQ G167084 + (CONS (CAR |u|) G167084)))))))) + 'T) + ('T NIL))))))))) + +@ +\subsection{JoinInner} +The implementation of Join +\subsubsection{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. +<<*>>= +;JoinInner(l,$e) == +; $NewCatVec: local := nil +; 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) + +(DEFUN |JoinInner,AddPredicate| (|op| |newpred|) + (PROG (|sig| |oldpred| |implem|) + (RETURN + (SEQ (PROGN + (SPADLET |sig| (CAR |op|)) + (SPADLET |oldpred| (CADR |op|)) + (SPADLET |implem| (CDDR |op|)) + |op| + (SEQ (IF (BOOT-EQUAL |newpred| 'T) (EXIT |op|)) + (IF (BOOT-EQUAL |oldpred| 'T) + (EXIT (CONS |sig| (CONS |newpred| |implem|)))) + (EXIT (CONS |sig| + (CONS (MKPF + (CONS |oldpred| + (CONS |newpred| NIL)) + '|and|) + |implem|))))))))) + +(DEFUN |JoinInner| (|l| |$e|) + (DECLARE (SPECIAL |$e|)) + (PROG (|$NewCatVec| |at2| |pred| |pred'| |l'| |originalVector| |b| + |condition| |bname| |f| |LETTMP#1| |index| |PrinAncb| + |anccond| |newentry| |ancindex| |reallynew| |bCond| + |CondList| |s| |i| |a| |n| |copied| |originalvector| + |globalDomains| |newpred| |v| |attl| |sigl| + |FundamentalAncestors| |pName| |c|) + (DECLARE (SPECIAL |$NewCatVec|)) + (RETURN + (SEQ (PROGN + (SPADLET |$NewCatVec| NIL) + (SPADLET |CondList| NIL) + (DO ((G167173 |l| (CDR G167173)) (|u| NIL)) + ((OR (ATOM G167173) + (PROGN (SETQ |u| (CAR G167173)) NIL)) + NIL) + (SEQ (EXIT (DO ((G167185 (ELT |u| 2) (CDR G167185)) + (|at| NIL)) + ((OR (ATOM G167185) + (PROGN + (SETQ |at| (CAR G167185)) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |at2| (CAR |at|)) + (COND + ((ATOM |at2|) + (SPADLET |at2| + (CONS |at2| NIL)))) + (COND + ((QMEMQ (QCAR |at2|) + |$Attributes|) + NIL) + ((NULL + (|isCategoryForm| |at2| + |$e|)) + (SPADLET |$Attributes| + (CONS (QCAR |at2|) + |$Attributes|)) + NIL) + ('T + (SPADLET |pred| + (CAR (CDR |at|))) + (COND + ((|member| |pred| + (|get| '|$Information| + '|special| |$e|)) + (SPADLET |l| + (APPEND |l| + (CONS + (|CatEval| |at2|) + NIL)))) + ((NULL + (AND (PAIRP |pred|) + (EQ (QCAR |pred|) + '|and|))) + (SPADLET |CondList| + (CONS + (CONS + (|CatEval| |at2|) + (CONS |pred| NIL)) + |CondList|))) + ('T + (SPADLET |pred'| + (PROG (G167196) + (SPADLET G167196 + NIL) + (RETURN + (DO + ((G167202 + (CDR |pred|) + (CDR G167202)) + (|u| NIL)) + ((OR + (ATOM G167202) + (PROGN + (SETQ |u| + (CAR + G167202)) + NIL)) + (NREVERSE0 + G167196)) + (SEQ + (EXIT + (COND + ((AND + (NULL + (|member| + |u| + (|get| + '|$Information| + '|special| + |$e|))) + (NULL + (BOOT-EQUAL + |u| 'T))) + (SETQ + G167196 + (CONS |u| + G167196)))))))))) + (COND + ((NULL |pred'|) + (SPADLET |l| + (APPEND |l| + (CONS + (|CatEval| |at2|) + NIL)))) + ((EQL (LENGTH |pred'|) + 1) + (SPADLET |CondList| + (CONS + (CONS + (|CatEval| |at2|) + (CONS |pred'| NIL)) + |CondList|))) + ('T + (SPADLET |CondList| + (CONS + (CONS + (|CatEval| |at2|) + (CONS + (CONS '|and| + |pred'|) + NIL)) + |CondList|))))))))))))))) + (SPADLET |LETTMP#1| |l|) + (SPADLET |$NewCatVec| (CAR |LETTMP#1|)) + (SPADLET |l| (CDR |LETTMP#1|)) + (SPADLET |l'| + (APPEND |CondList| + (PROG (G167212) + (SPADLET G167212 NIL) + (RETURN + (DO ((G167217 |l| (CDR G167217)) + (|u| NIL)) + ((OR (ATOM G167217) + (PROGN + (SETQ |u| (CAR G167217)) + NIL)) + (NREVERSE0 G167212)) + (SEQ + (EXIT + (SETQ G167212 + (CONS (CONS |u| (CONS 'T NIL)) + G167212))))))))) + (SPADLET |sigl| (ELT |$NewCatVec| 1)) + (SPADLET |attl| (ELT |$NewCatVec| 2)) + (SPADLET |globalDomains| (ELT |$NewCatVec| 5)) + (SPADLET |FundamentalAncestors| + (CADR (ELT |$NewCatVec| 4))) + (COND + ((ELT |$NewCatVec| 0) + (SPADLET |FundamentalAncestors| + (CONS (CONS (ELT |$NewCatVec| 0) NIL) + |FundamentalAncestors|)))) + (SPADLET |copied| NIL) + (SPADLET |originalVector| 'T) + (SPADLET |originalVector| NIL) + (DO ((G167229 (|FindFundAncs| |l'|) (CDR G167229)) + (G167138 NIL)) + ((OR (ATOM G167229) + (PROGN (SETQ G167138 (CAR G167229)) NIL) + (PROGN + (PROGN + (SPADLET |b| (CAR G167138)) + (SPADLET |condition| (CADR G167138)) + G167138) + NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (NULL (ELT |b| 0))) + (SPADLET |bname| (ELT |b| 0)) + (COND + ((|CondAncestorP| |bname| + |FundamentalAncestors| |condition|) + NIL) + ((SPADLET |f| + (|AncestorP| |bname| + (PROG (G167240) + (SPADLET G167240 NIL) + (RETURN + (DO + ((G167245 + |FundamentalAncestors| + (CDR G167245)) + (|u| NIL)) + ((OR (ATOM G167245) + (PROGN + (SETQ |u| + (CAR G167245)) + NIL)) + (NREVERSE0 G167240)) + (SEQ + (EXIT + (SETQ G167240 + (CONS (CAR |u|) + G167240))))))))) + (SPADLET |LETTMP#1| + (|assoc| |f| + |FundamentalAncestors|)) + (SPADLET |index| (CADDR |LETTMP#1|)) + (SPADLET |FundamentalAncestors| + (CONS + (CONS |bname| + (CONS |condition| + (CONS |index| NIL))) + |FundamentalAncestors|))) + ('T + (SPADLET |PrinAncb| + (CAR + (ELT (|CatEval| |bname|) 4))) + (SPADLET |reallynew| 'T) + (DO ((G167256 |FundamentalAncestors| + (CDR G167256)) + (|anc| NIL)) + ((OR (ATOM G167256) + (PROGN + (SETQ |anc| (CAR G167256)) + NIL)) + NIL) + (SEQ (EXIT + (COND + ((|member| (CAR |anc|) + |PrinAncb|) + (COND + ((CDR |anc|) + (SPADLET |anccond| + (CADR |anc|)) + (SPADLET |ancindex| + (CADDR |anc|))) + ('T (SPADLET |anccond| 'T) + (SPADLET |ancindex| NIL))) + (COND + ((|PredImplies| + |condition| |anccond|) + (SPADLET + |FundamentalAncestors| + (CONS + (CONS |bname| + (CONS |condition| + (CONS |ancindex| NIL))) + (|delete| |anc| + |FundamentalAncestors|)))) + ((AND |ancindex| + (PROGN + (|PredImplies| + |anccond| + |condition|) + 'T)) + (SPADLET |newentry| + (CONS |bname| + (CONS |condition| + (CONS |ancindex| NIL)))) + (COND + ((NULL + (|member| |newentry| + |FundamentalAncestors|)) + (SPADLET + |FundamentalAncestors| + (CONS |newentry| + |FundamentalAncestors|))) + ('T NIL))) + ('T + (SPADLET |ancindex| NIL))) + (COND + ((NULL |copied|) + (SPADLET |$NewCatVec| + (COPY-SEQ |$NewCatVec|)) + (SPADLET |copied| 'T))) + (COND + (|ancindex| + (SETELT |$NewCatVec| + |ancindex| |bname|) + (SPADLET |reallynew| NIL)) + ((AND |originalVector| + (BOOT-EQUAL |condition| + 'T)) + (SPADLET |$NewCatVec| + (|CatEval| |bname|)) + (SPADLET |copied| NIL) + (SPADLET + |FundamentalAncestors| + (CONS (CONS |bname| NIL) + (CADR + (ELT |$NewCatVec| 4)))) + (SPADLET |reallynew| NIL) + (COND + ((MEMQ |b| |l|) + (SPADLET |sigl| + (ELT |$NewCatVec| 1)) + (SPADLET |attl| + (ELT |$NewCatVec| 2)) + (SPADLET |l| + (|delete| |b| |l|))) + ('T + (SPADLET |bCond| + (ASSQ |b| |CondList|)) + (SPADLET |CondList| + (|delete| |bCond| + |CondList|)) + (SPADLET + |globalDomains| + (ELT |$NewCatVec| 5)) + (DO + ((G167265 + (ELT |$NewCatVec| + 1) + (CDR G167265)) + (|u| NIL)) + ((OR (ATOM G167265) + (PROGN + (SETQ |u| + (CAR G167265)) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((NULL + (|member| |u| + |sigl|)) + (SPADLET |s| + (CAR |u|)) + (SPADLET |c| + (CADR |u|)) + (SPADLET |i| + (CADDR |u|)) + (COND + ((BOOT-EQUAL + |c| 'T) + (SPADLET + |sigl| + (CONS + (CONS |s| + (CONS + |condition| + (CONS + |i| + NIL))) + |sigl|))) + ('T + (SPADLET + |sigl| + (CONS + (CONS |s| + (CONS + (CONS + '|and| + (CONS + |condition| + (CONS + |c| + NIL))) + (CONS + |i| + NIL))) + |sigl|))))) + ('T NIL))))) + (DO + ((G167274 + (ELT |$NewCatVec| + 2) + (CDR G167274)) + (|u| NIL)) + ((OR (ATOM G167274) + (PROGN + (SETQ |u| + (CAR G167274)) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((NULL + (|member| |u| + |attl|)) + (SPADLET |a| + (CAR |u|)) + (SPADLET |c| + (CADR |u|)) + (COND + ((BOOT-EQUAL + |c| 'T) + (SPADLET + |attl| + (CONS + (CONS |a| + (CONS + |condition| + NIL)) + |attl|))) + ('T + (SPADLET + |attl| + (CONS + (CONS |a| + (CONS + (CONS + '|and| + (CONS + |condition| + (CONS + |c| + NIL))) + NIL)) + |attl|))))) + ('T NIL)))))))) + ('T NIL))) + ('T NIL))))) + (COND + (|reallynew| + (SPADLET |n| (SIZE |$NewCatVec|)) + (SPADLET |FundamentalAncestors| + (CONS + (CONS (ELT |b| 0) + (CONS |condition| + (CONS |n| NIL))) + |FundamentalAncestors|)) + (SPADLET |$NewCatVec| + (LENGTHENVEC |$NewCatVec| + (PLUS |n| 1))) + (SPADLET |copied| NIL) + (SPADLET |originalvector| NIL) + (SETELT |$NewCatVec| |n| + (ELT |b| 0))) + ('T NIL))))) + ('T NIL))))) + (COND + ((NULL |copied|) + (SPADLET |$NewCatVec| (COPY-SEQ |$NewCatVec|)))) + (DO ((G167286 |l| (CDR G167286)) (|b| NIL)) + ((OR (ATOM G167286) + (PROGN (SETQ |b| (CAR G167286)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |sigl| + (|SigListUnion| + (PROG (G167296) + (SPADLET G167296 NIL) + (RETURN + (DO + ((G167301 (ELT |b| 1) + (CDR G167301)) + (|u| NIL)) + ((OR (ATOM G167301) + (PROGN + (SETQ |u| + (CAR G167301)) + NIL)) + (NREVERSE0 G167296)) + (SEQ + (EXIT + (SETQ G167296 + (CONS + (|DropImplementations| + |u|) + G167296))))))) + |sigl|)) + (SPADLET |attl| + (COND + ((MEMQ |attl| (ELT |b| 2)) + (ELT |b| 2)) + ((MEMQ (ELT |b| 2) |attl|) + |attl|) + ('T (S+ (ELT |b| 2) |attl|)))) + (SPADLET |globalDomains| + (APPEND |globalDomains| + (S- (ELT |b| 5) |globalDomains|))))))) + (DO ((G167315 |CondList| (CDR G167315)) (|b| NIL)) + ((OR (ATOM G167315) + (PROGN (SETQ |b| (CAR G167315)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |newpred| (CAR (CDR |b|))) + (DO ((G167326 (ELT (CAR |b|) 2) + (CDR G167326)) + (|u| NIL)) + ((OR (ATOM G167326) + (PROGN + (SETQ |u| (CAR G167326)) + NIL)) + NIL) + (SEQ (EXIT + (PROGN + (SPADLET |v| + (|assoc| (CAR |u|) |attl|)) + (COND + ((NULL |v|) + (SPADLET |attl| + (COND + ((BOOT-EQUAL (CADR |u|) 'T) + (CONS + (CONS (CAR |u|) + (CONS |newpred| NIL)) + |attl|)) + ('T + (CONS + (CONS (CAR |u|) + (CONS + (CONS '|and| + (CONS |newpred| + (CONS (CADR |u|) NIL))) + NIL)) + |attl|))))) + ((BOOT-EQUAL (CADR |v|) 'T) + NIL) + ('T + (SPADLET |attl| + (|delete| |v| |attl|)) + (SPADLET |attl| + (COND + ((BOOT-EQUAL (CADR |u|) 'T) + (CONS + (CONS (CAR |u|) + (CONS + (|mkOr| (CADR |v|) + |newpred|) + NIL)) + |attl|)) + ('T + (CONS + (CONS (CAR |u|) + (CONS + (|mkOr| (CADR |v|) + (|mkAnd| |newpred| + (CADR |u|))) + NIL)) + |attl|)))))))))) + (SPADLET |sigl| + (|SigListUnion| + (PROG (G167336) + (SPADLET G167336 NIL) + (RETURN + (DO + ((G167341 + (ELT (CAR |b|) 1) + (CDR G167341)) + (|u| NIL)) + ((OR (ATOM G167341) + (PROGN + (SETQ |u| + (CAR G167341)) + NIL)) + (NREVERSE0 G167336)) + (SEQ + (EXIT + (SETQ G167336 + (CONS + (|JoinInner,AddPredicate| + (|DropImplementations| + |u|) + |newpred|) + G167336))))))) + |sigl|)))))) + (SPADLET |FundamentalAncestors| + (PROG (G167352) + (SPADLET G167352 NIL) + (RETURN + (DO ((G167358 |FundamentalAncestors| + (CDR G167358)) + (|x| NIL)) + ((OR (ATOM G167358) + (PROGN + (SETQ |x| (CAR G167358)) + NIL)) + (NREVERSE0 G167352)) + (SEQ (EXIT (COND + ((CDR |x|) + (SETQ G167352 + (CONS |x| G167352)))))))))) + (SPADLET |c| (CAR (ELT |$NewCatVec| 4))) + (SPADLET |pName| (ELT |$NewCatVec| 0)) + (COND + ((AND |pName| (NULL (|member| |pName| |c|))) + (SPADLET |c| (CONS |pName| |c|)))) + (SETELT |$NewCatVec| 4 + (CONS |c| + (CONS |FundamentalAncestors| + (CONS (CADDR (ELT |$NewCatVec| 4)) + NIL)))) + (|mkCategory| '|domain| |sigl| |attl| |globalDomains| + |$NewCatVec|)))))) + +@ +\subsection{isCategoryForm} +<<*>>= +;isCategoryForm(x,e) == +; x is [name,:.] => categoryForm? name +; atom x => u:= get(x,"macro",e) => isCategoryForm(u,e) + +(DEFUN |isCategoryForm| (|x| |e|) + (PROG (|name| |u|) + (RETURN + (SEQ (COND + ((AND (PAIRP |x|) (PROGN (SPADLET |name| (QCAR |x|)) 'T)) + (|categoryForm?| |name|)) + ((ATOM |x|) + (COND + ((SPADLET |u| (|get| |x| '|macro| |e|)) + (EXIT (|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}