diff --git a/changelog b/changelog index 20620f7..e602155 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,8 @@ +20090812 tpd src/axiom-website/patches.html 20090812.01.tpd.patch +20090812 tpd src/interp/Makefile move cattable.boot to cattable.lisp +20090812 tpd src/interp/debugsys.lisp change astr.clisp to cattable.lisp +20090812 tpd src/interp/cattable.lisp added, rewritten from cattable.boot +20090812 tpd src/interp/cattable.boot removed, rewritten to cattable.lisp 20090811 tpd src/axiom-website/patches.html 20090811.01.tpd.patch 20090811 tpd src/interp/Makefile move dq.boot to dq.lisp 20090811 tpd src/interp/debugsys.lisp change astr.clisp to dq.lisp diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index bbdc3e9..a151390 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1774,6 +1774,8 @@ astr.lisp rewrite from boot to lisp
buildom.lisp rewrite from boot to lisp
20090811.01.tpd.patch dq.lisp rewrite from boot to lisp
+20090812.01.tpd.patch +cattable.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 57303ea..521c6f8 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -414,7 +414,7 @@ DOCFILES=${DOC}/as.boot.dvi \ ${DOC}/axext_l.lisp.dvi \ ${DOC}/bc-matrix.boot.dvi \ ${DOC}/br-con.boot.dvi \ - ${DOC}/category.boot.dvi ${DOC}/cattable.boot.dvi \ + ${DOC}/category.boot.dvi \ ${DOC}/c-doc.boot.dvi ${DOC}/cformat.boot.dvi \ ${DOC}/cfuns.lisp.dvi ${DOC}/clam.boot.dvi \ ${DOC}/clammed.boot.dvi ${DOC}/compat.boot.dvi \ @@ -2462,47 +2462,27 @@ ${DOC}/category.boot.dvi: ${IN}/category.boot.pamphlet @ -\subsection{cattable.boot \cite{59}} +\subsection{cattable.lisp} <>= -${OUT}/cattable.${O}: ${MID}/cattable.clisp - @ echo 214 making ${OUT}/cattable.${O} from ${MID}/cattable.clisp - @ (cd ${MID} ; \ +${OUT}/cattable.${O}: ${MID}/cattable.lisp + @ echo 136 making ${OUT}/cattable.${O} from ${MID}/cattable.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/cattable.clisp"' \ + echo '(progn (compile-file "${MID}/cattable.lisp"' \ ':output-file "${OUT}/cattable.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/cattable.clisp"' \ + echo '(progn (compile-file "${MID}/cattable.lisp"' \ ':output-file "${OUT}/cattable.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/cattable.clisp: ${IN}/cattable.boot.pamphlet - @ echo 215 making ${MID}/cattable.clisp \ - from ${IN}/cattable.boot.pamphlet +<>= +${MID}/cattable.lisp: ${IN}/cattable.lisp.pamphlet + @ echo 137 making ${MID}/cattable.lisp from \ + ${IN}/cattable.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/cattable.boot.pamphlet >cattable.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "cattable.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "cattable.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm cattable.boot ) - -@ -<>= -${DOC}/cattable.boot.dvi: ${IN}/cattable.boot.pamphlet - @echo 216 making ${DOC}/cattable.boot.dvi \ - from ${IN}/cattable.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/cattable.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} cattable.boot ; \ - rm -f ${DOC}/cattable.boot.pamphlet ; \ - rm -f ${DOC}/cattable.boot.tex ; \ - rm -f ${DOC}/cattable.boot ) + ${TANGLE} ${IN}/cattable.lisp.pamphlet >cattable.lisp ) @ @@ -6863,8 +6843,7 @@ clean: <> <> -<> -<> +<> <> <> @@ -7458,7 +7437,6 @@ pp \bibitem{56} {\bf \$SPAD/src/interp/nag-f07.boot.pamphlet} \bibitem{57} {\bf \$SPAD/src/interp/nag-s.boot.pamphlet} \bibitem{58} {\bf \$SPAD/src/interp/category.boot.pamphlet} -\bibitem{59} {\bf \$SPAD/src/interp/cattable.boot.pamphlet} \bibitem{60} {\bf \$SPAD/src/interp/c-doc.boot.pamphlet} \bibitem{61} {\bf \$SPAD/src/interp/clam.boot.pamphlet} \bibitem{62} {\bf \$SPAD/src/interp/clammed.boot.pamphlet} diff --git a/src/interp/cattable.boot.pamphlet b/src/interp/cattable.boot.pamphlet deleted file mode 100644 index 31561e0..0000000 --- a/src/interp/cattable.boot.pamphlet +++ /dev/null @@ -1,523 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp cattable.boot} -\author{The Axiom Team} -\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. - -@ -<<*>>= -<> - -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} diff --git a/src/interp/cattable.lisp.pamphlet b/src/interp/cattable.lisp.pamphlet new file mode 100644 index 0000000..a57001e --- /dev/null +++ b/src/interp/cattable.lisp.pamphlet @@ -0,0 +1,1925 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp cattable.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= + +(IN-PACKAGE "BOOT" ) + +;hasCat(domainOrCatName,catName) == + +; catName='Object or catName='Type -- every domain is a Type (Object) +; or GETDATABASE([domainOrCatName,:catName],'HASCATEGORY) + +(DEFUN |hasCat| (|domainOrCatName| |catName|) + (OR (BOOT-EQUAL |catName| (QUOTE |Object|)) + (BOOT-EQUAL |catName| (QUOTE |Type|)) + (GETDATABASE (CONS |domainOrCatName| |catName|) (QUOTE HASCATEGORY)))) + +;showCategoryTable con == +; [[b,:val] for (key :=[a,:b]) in HKEYS _*HASCATEGORY_-HASH_* +; | a = con and (val := HGET(_*HASCATEGORY_-HASH_*,key))] + +(DEFUN |showCategoryTable| (|con|) + (PROG (|a| |b| |val|) + (RETURN + (SEQ + (PROG (#0=#:G166069) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166076 (HKEYS *HASCATEGORY-HASH*) (CDR #1#)) (|key| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |key| (CAR #1#)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR |key|)) + (SPADLET |b| (CDR |key|)) |key|) + NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (COND + ((AND (BOOT-EQUAL |a| |con|) + (SPADLET |val| (HGET *HASCATEGORY-HASH* |key|))) + (SETQ #0# (CONS (CONS |b| |val|) #0#))))))))))))) + +;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) + +(DEFUN |displayCategoryTable| (&REST #0=#:G166124 &AUX |options|) + (DSETQ |options| #0#) + (PROG (|conList| |a| |b|) + (RETURN + (SEQ + (PROGN + (SPADLET |conList| (IFCAR |options|)) + (SETQ |$ct| (MAKE-HASHTABLE (QUOTE ID))) + (DO ((#1=#:G166099 (HKEYS *HASCATEGORY-HASH*) (CDR #1#)) (|key| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |key| (CAR #1#)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR |key|)) + (SPADLET |b| (CDR |key|)) + |key|) + NIL)) + NIL) + (SEQ + (EXIT + (HPUT |$ct| |a| + (CONS + (CONS |b| (HGET *HASCATEGORY-HASH* |key|)) + (HGET |$ct| |a|)))))) + (DO ((#2=#:G166112 (HKEYS |$ct|) (CDR #2#)) (|id| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |id| (CAR #2#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((OR (NULL |conList|) (MEMQ |id| |conList|)) + (PROGN + (|sayMSG| (APPEND (|bright| |id|) (CONS "extends:" NIL))) + (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_* + +(DEFUN |genCategoryTable| () + (PROG (|domainList| |catl| |specialDs| |domainTable| |id| |entry| |a| |b|) + (RETURN + (SEQ + (PROGN + (SETQ *ANCESTORS-HASH* (MAKE-HASHTABLE (QUOTE ID))) + (SETQ *HASCATEGORY-HASH* (MAKE-HASHTABLE (QUOTE UEQUAL))) + (|genTempCategoryTable|) + (SPADLET |domainList| + (PROG (#0=#:G166139) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166145 (|allConstructors|) (CDR #1#)) (|con| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |con| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL (GETDATABASE |con| (QUOTE CONSTRUCTORKIND)) + (QUOTE |domain|)) + (SETQ #0# (CONS |con| #0#)))))))))) + (SPADLET |domainTable| + (PROG (#2=#:G166156) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G166162 |domainList| (CDR #3#)) (|con| NIL)) + ((OR (ATOM #3#) + (PROGN (SETQ |con| (CAR #3#)) NIL)) + (NREVERSE0 #2#)) + (SEQ + (EXIT + (COND + ((SPADLET |catl| (GETDATABASE |con| (QUOTE CONSTRUCTORCATEGORY))) + (SETQ #2# + (CONS + (|addDomainToTable| |con| (|getConstrCat| |catl|)) + #2#)))))))))) + (SPADLET |specialDs| + (SETDIFFERENCE |$nonLisplibDomains| |$noCategoryDomains|)) + (SPADLET |domainTable| + (APPEND + (PROG (#4=#:G166172) + (SPADLET #4# NIL) + (RETURN + (DO ((#5=#:G166177 |specialDs| (CDR #5#)) (|id| NIL)) + ((OR (ATOM #5#) + (PROGN (SETQ |id| (CAR #5#)) NIL)) + (NREVERSE0 #4#)) + (SEQ + (EXIT + (SETQ #4# + (CONS + (|addDomainToTable| |id| + (|getConstrCat| (ELT (|eval| (CONS |id| NIL)) 3))) + #4#))))))) + |domainTable|)) + (DO ((#6=#:G166190 |domainTable| (CDR #6#)) (#7=#:G166129 NIL)) + ((OR (ATOM #6#) (PROGN (SETQ #7# (CAR #6#)) NIL) (PROGN (PROGN (SPADLET |id| (CAR #7#)) (SPADLET |entry| (CDR #7#)) #7#) NIL)) NIL) + (SEQ + (EXIT + (DO ((#8=#:G166201 (|encodeCategoryAlist| |id| |entry|) (CDR #8#)) + (#9=#:G166125 NIL)) + ((OR (ATOM #8#) + (PROGN (SETQ #9# (CAR #8#)) NIL) + (PROGN + (PROGN (SPADLET |a| (CAR #9#)) (SPADLET |b| (CDR #9#)) #9#) + NIL)) + NIL) + (SEQ (EXIT (HPUT *HASCATEGORY-HASH* (CONS |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) + +(DEFUN |simpTempCategoryTable| () + (PROG (|a| |b|) + (RETURN + (SEQ + (DO ((#0=#:G166235 (HKEYS *ANCESTORS-HASH*) (CDR #0#)) (|id| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |id| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (DO ((#1=#:G166247 (GETDATABASE |id| (QUOTE ANCESTORS)) (CDR #1#)) + (|u| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |u| (CAR #1#)) NIL) + (PROGN + (PROGN (SPADLET |a| (CAR |u|)) (SPADLET |b| (CDR |u|)) |u|) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (RPLACA |u| (MSUBST (QUOTE |Type|) (QUOTE |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) + +(DEFUN |simpCategoryTable| () + (PROG (|entry| |x| |pred| |npred| |change|) + (RETURN + (SEQ + (DO ((#0=#:G166277 (HKEYS *HASCATEGORY-HASH*) (CDR #0#)) (|key| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |key| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |entry| (HGET *HASCATEGORY-HASH* |key|)) + (COND + ((NULL |entry|) (HREM *HASCATEGORY-HASH* |key|)) + ((QUOTE T) + (SPADLET |change| + (COND + ((ATOM (|opOf| |entry|)) (|simpHasPred| |entry|)) + ((QUOTE T) + (PROG (#1=#:G166289) + (SPADLET #1# NIL) + (RETURN + (DO ((#2=#:G166296 |entry| (CDR #2#)) (#3=#:G166259 NIL)) + ((OR (ATOM #2#) + (PROGN (SETQ #3# (CAR #2#)) NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR #3#)) + (SPADLET |pred| (CDR #3#)) + #3#) + NIL)) + (NREVERSE0 #1#)) + (SEQ + (EXIT + (COND + ((SPADLET |npred| (|simpHasPred| |pred|)) + (SETQ #1# (CONS (CONS |x| |npred|) #1#)))))))))))) + (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 + +(DEFUN |simpHasPred,eval| (|pred|) + (PROG (|d| |cat| |x| |y| |args| |p| |npred|) + (RETURN + (SEQ + (PROGN + (SPADLET |d| (CADR |pred|)) + (SPADLET |cat| (CADDR |pred|)) + |pred| + (SEQ + (SPADLET |x| (|hasCat| (CAR |d|) (CAR |cat|))) + (IF (SPADLET |y| (CDR |cat|)) + (EXIT + (SEQ + (IF (SPADLET |npred| + (PROG (#0=#:G166367) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166375 NIL #0#) + (#2=#:G166376 |x| (CDR #2#)) + (#3=#:G166350 NIL)) + ((OR #1# + (ATOM #2#) + (PROGN (SETQ #3# (CAR #2#)) NIL) + (PROGN + (PROGN + (SPADLET |args| (CAR #3#)) + (SPADLET |p| (CDR #3#)) + #3#) + NIL)) + #0#) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |y| |args|) (SETQ #0# (OR #0# |p|)))))))))) + (EXIT (|simpHasPred,simp| |npred|))) + (EXIT NIL)))) + (EXIT |x|))))))) + +(DEFUN |simpHasPred,simpHas| (|pred| |a| |b|) + (PROG (|attr| |ISTMP#1| |op| |ISTMP#2| |sig| |npred|) + (RETURN + (SEQ + (IF (AND (PAIRP |b|) + (EQ (QCAR |b|) (QUOTE ATTRIBUTE)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |b|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |attr| (QCAR |ISTMP#1|)) (QUOTE T))))) + (EXIT (|simpHasAttribute| |pred| |a| |attr|))) + (IF (AND (PAIRP |b|) + (EQ (QCAR |b|) (QUOTE SIGNATURE)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |b|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |sig| (QCAR |ISTMP#2|)) + (QUOTE T))))))) + (EXIT (|simpHasSignature| |pred| |a| |op| |sig|))) + (IF (OR (IDENTP |a|) (|hasIdent| |b|)) + (EXIT |pred|)) + (SPADLET |npred| (|simpHasPred,eval| |pred|)) + (IF (OR (IDENTP |npred|) (NULL (|hasIdent| |npred|))) + (EXIT |npred|)) + (EXIT |pred|))))) + +(DEFUN |simpHasPred,simpDevaluate| (|a|) + (EVAL (MSUBST (QUOTE QUOTE) (QUOTE |devaluate|) |a|))) + +(DEFUN |simpHasPred,simp| (|pred|) + (PROG (|r| |LETTMP#1| |op| |sig| |a| |b| |form| |u| |op1|) + (RETURN + (SEQ + (IF (AND (PAIRP |pred|) + (PROGN + (SPADLET |op| (QCAR |pred|)) + (SPADLET |r| (QCDR |pred|)) + (QUOTE T))) + (EXIT + (SEQ + (IF (BOOT-EQUAL |op| (QUOTE |has|)) + (EXIT (|simpHasPred,simpHas| |pred| (CAR |r|) (CAR (CDR |r|))))) + (IF (BOOT-EQUAL |op| (QUOTE |HasCategory|)) + (EXIT + (|simpHasPred,simp| + (CONS + (QUOTE |has|) + (CONS + (CAR |r|) + (CONS (|simpHasPred,simpDevaluate| (CADR |r|)) NIL)))))) + (IF (BOOT-EQUAL |op| (QUOTE |HasSignature|)) + (EXIT + (SEQ + (PROGN + (SPADLET |LETTMP#1| (|simpHasPred,simpDevaluate| (CADR |r|))) + (SPADLET |op| (CAR |LETTMP#1|)) + (SPADLET |sig| (CADR |LETTMP#1|)) + |LETTMP#1|) + (EXIT + (CONS + (QUOTE |has|) + (CONS + (CAR |r|) + (CONS + (CONS (QUOTE SIGNATURE) (CONS |op| (CONS |sig| NIL))) + NIL))))))) + (IF (BOOT-EQUAL |op| (QUOTE |HasAttribute|)) + (EXIT + (SEQ + (SPADLET |form| + (CONS + (QUOTE |has|) + (CONS + (SPADLET |a| (CAR |r|)) + (CONS + (CONS + (QUOTE ATTRIBUTE) + (CONS + (SPADLET |b| (|simpHasPred,simpDevaluate| (CADR |r|))) + NIL)) + NIL)))) + (EXIT (|simpHasAttribute| |form| |a| |b|))))) + (IF (MEMQ |op| (QUOTE (AND OR NOT))) + (EXIT + (SEQ + (IF + (NULL + (SPADLET |u| + (MKPF + (PROG (#0=#:G166412) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166417 |r| (CDR #1#)) (|p| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |p| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# (CONS (|simpHasPred,simp| |p|) #0#))))))) + |op|))) + (EXIT NIL)) + (IF (EQUAL |u| (QUOTE (QUOTE T))) + (EXIT (QUOTE T))) + (EXIT (|simpBool| |u|))))) + (IF (BOOT-EQUAL |op| (QUOTE |hasArgs|)) + (EXIT + (SEQ + (IF |$hasArgs| + (EXIT (BOOT-EQUAL |$hasArgs| |r|))) + (EXIT |pred|)))) + (IF (AND (NULL |r|) (BOOT-EQUAL (|opOf| |op|) (QUOTE |has|))) + (EXIT (|simpHasPred,simp| (CAR |pred|)))) + (IF (EQUAL |pred| (QUOTE (QUOTE T))) (EXIT (QUOTE T))) + (IF (SPADLET |op1| + (LASSOC |op| (QUOTE ((|and| . AND) (|or| . OR) (|not| . NOT))))) + (EXIT (|simpHasPred,simp| (CONS |op1| |r|)))) + (EXIT (|simpHasPred,simp| (CAR |pred|)))))) + (IF (|member| |pred| (QUOTE (T |etc|))) + (EXIT |pred|)) + (IF (NULL |pred|) + (EXIT NIL)) + (EXIT |pred|))))) + +(DEFUN |simpHasPred| (&REST #0=#:G166444 &AUX |options| |pred|) + (DSETQ (|pred| . |options|) #0#) + (PROG (|$hasArgs|) + (DECLARE (SPECIAL |$hasArgs|)) + (RETURN + (PROGN + (SPADLET |$hasArgs| (IFCDR (IFCAR |options|))) + (|simpHasPred,simp| |pred|))))) + +;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) + +(DEFUN |simpHasSignature| (|pred| |conform| |op| |sig|) + (PROG (|conname| |args| |n| |u| |candidates| |sig1| |match| |ISTMP#1| |p|) + (RETURN + (SEQ + (COND + ((IDENTP |conform|) |pred|) + ((QUOTE T) + (SPADLET |conname| (CAR |conform|)) + (SPADLET |args| (CDR |conform|)) + (SPADLET |n| (|#| |sig|)) + (SPADLET |u| + (LASSOC |op| (GETDATABASE |conname| (QUOTE OPERATIONALIST)))) + (SPADLET |candidates| + (OR + (PROG (#0=#:G166468) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166475 |u| (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |x| (CAR #1#)) NIL) + (PROGN + (PROGN (SPADLET |sig1| (CAR |x|)) |x|) + NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL (|#| |sig1|) (|#| |sig|)) + (SETQ #0# (CONS |x| #0#))))))))) + (RETURN NIL))) + (SPADLET |match| + (OR + (PROG (#2=#:G166482) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G166490 NIL #2#) + (#4=#:G166491 |candidates| (CDR #4#)) + (|x| NIL)) + ((OR #3# + (ATOM #4#) + (PROGN (SETQ |x| (CAR #4#)) NIL) + (PROGN (PROGN (SPADLET |sig1| (CAR |x|)) |x|) NIL)) + #2#) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |sig| (|sublisFormal| |args| |sig1|)) + (SETQ #2# (OR #2# |x|))))))))) + (RETURN NIL))) + (|simpHasPred| + (OR (AND + (PAIRP |match|) + (PROGN + (SPADLET |sig| (QCAR |match|)) + (SPADLET |ISTMP#1| (QCDR |match|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |p| (QCDR |ISTMP#1|)) (QUOTE T)))) + (|sublisFormal| |args| |p|)) + (QUOTE T))))))))) + +;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) + +(DEFUN |simpHasAttribute| (|pred| |conform| |attr|) + (PROG (|conname| |p| |infovec| |k| |predvec|) + (RETURN + (SEQ + (COND + ((IDENTP |conform|) |pred|) + ((QUOTE T) + (SPADLET |conname| (|opOf| |conform|)) + (COND + ((BOOT-EQUAL (GETDATABASE |conname| (QUOTE CONSTRUCTORKIND)) + (QUOTE |category|)) + (|simpCatHasAttribute| |conform| |attr|)) + ((QUOTE T) + (SEQ + (COND + ((|asharpConstructorName?| |conname|) + (EXIT + (COND + ((SPADLET |p| + (LASSOC |attr| (GETDATABASE |conname| (QUOTE |attributes|)))) + (EXIT (|simpHasPred| (|sublisFormal| (CDR |conform|) |p|)))))))) + (SPADLET |infovec| (|dbInfovec| |conname|)) + (SPADLET |k| (OR (LASSOC |attr| (ELT |infovec| 2)) (RETURN NIL))) + (COND ((EQL |k| 0) (EXIT (QUOTE T)))) + (COND (|$domain| (EXIT (|kTestPred| |k|)))) + (SPADLET |predvec| + (OR |$predvec| + (|sublisFormal| + (CDR |conform|) + (GETDATABASE |conname| (QUOTE PREDICATES))))) + (|simpHasPred| (ELT |predvec| (SPADDIFFERENCE |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) + +(DEFUN |simpCatHasAttribute| (|domform| |attr|) + (PROG (|conform| |catval| |u| |pred|) + (RETURN + (PROGN + (SPADLET |conform| (|getConstructorForm| (|opOf| |domform|))) + (SPADLET |catval| (EVAL (|mkEvalable| |conform|))) + (COND ((ATOM (KDR |attr|)) (SPADLET |attr| (IFCAR |attr|)))) + (SPADLET |pred| + (COND + ((SPADLET |u| (LASSOC |attr| (ELT |catval| 2))) (CAR |u|)) + ((QUOTE T) (RETURN NIL)))) + (COND + ((BOOT-EQUAL |pred| (QUOTE T)) + (QUOTE T)) + ((QUOTE T) + (EVAL (SUBLISLIS (CDR |domform|) (CDR |conform|) |pred|)))))))) +;hasIdent pred == +; pred is [op,:r] => +; op = 'QUOTE => false +; or/[hasIdent x for x in r] +; pred = '_$ => false +; IDENTP pred => true +; false + +(DEFUN |hasIdent| (|pred|) + (PROG (|op| |r|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |pred|) + (PROGN (SPADLET |op| (QCAR |pred|)) + (SPADLET |r| (QCDR |pred|)) + (QUOTE T))) + (COND + ((BOOT-EQUAL |op| (QUOTE QUOTE)) NIL) + ((QUOTE T) + (PROG (#0=#:G166539) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166545 NIL #0#) (#2=#:G166546 |r| (CDR #2#)) (|x| NIL)) + ((OR #1# (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (OR #0# (|hasIdent| |x|))))))))))) + ((BOOT-EQUAL |pred| (QUOTE $)) NIL) + ((IDENTP |pred|) (QUOTE T)) + ((QUOTE T) NIL)))))) + +;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] + +(DEFUN |addDomainToTable| (|id| |catl|) + (PROG (|ISTMP#1| |pred| |ISTMP#2| |cat1| |a| |b| |newAlist| |alist|) + (RETURN + (SEQ + (PROGN + (SPADLET |alist| NIL) + (DO ((#0=#:G166595 |catl| (CDR #0#)) (|cat| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |cat| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((AND (PAIRP |cat|) (EQ (QCAR |cat|) (QUOTE CATEGORY))) NIL) + ((AND (PAIRP |cat|) + (EQ (QCAR |cat|) (QUOTE IF)) + (PROGN (SPADLET |ISTMP#1| (QCDR |cat|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pred| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |cat1| (QCAR |ISTMP#2|)) + (QUOTE T))))))) + (SPADLET |newAlist| + (PROG (#1=#:G166606) + (SPADLET #1# NIL) + (RETURN + (DO ((#2=#:G166612 + (|getCategoryExtensionAlist0| |cat1|) (CDR #2#)) + (#3=#:G166575 NIL)) + ((OR (ATOM #2#) + (PROGN (SETQ #3# (CAR #2#)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR #3#)) + (SPADLET |b| (CDR #3#)) + #3#) + NIL)) + (NREVERSE0 #1#)) + (SEQ + (EXIT + (SETQ #1# (CONS (CONS |a| (|quickAnd| |pred| |b|)) #1#)))))))) + (SPADLET |alist| (APPEND |alist| |newAlist|))) + ((QUOTE T) + (SPADLET |alist| + (APPEND |alist| (|getCategoryExtensionAlist0| |cat|)))))))) + (CONS |id| |alist|)))))) + +;domainHput(table,key:=[id,:a],b) == +; HPUT(table,key,b) + +(DEFUN |domainHput| (|table| |key| |b|) + (PROG (|id| |a|) + (RETURN + (PROGN + (SPADLET |id| (CAR |key|)) + (SPADLET |a| (CDR |key|)) + (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)) + +(DEFUN |genTempCategoryTable| () + (PROG (|item| |b|) + (RETURN + (SEQ + (DO ((#0=#:G166653 (|allConstructors|) (CDR #0#)) (|con| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |con| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL (GETDATABASE |con| (QUOTE CONSTRUCTORKIND)) + (QUOTE |category|)) + (EXIT (|addToCategoryTable| |con|))))))) + (DO ((#1=#:G166667 (HKEYS *ANCESTORS-HASH*) (CDR #1#)) (|id| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |id| (CAR #1#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |item| (HGET *ANCESTORS-HASH* |id|)) + (DO ((#2=#:G166677 |item| (CDR #2#)) (|u| NIL)) + ((OR (ATOM #2#) + (PROGN (SETQ |u| (CAR #2#)) NIL) + (PROGN (PROGN (SPADLET |b| (CDR |u|)) |u|) NIL)) NIL) + (SEQ + (EXIT (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 + +(DEFUN |addToCategoryTable| (|con|) + (PROG (|u| |alist|) + (RETURN + (PROGN + (SPADLET |u| (CAAR (GETDATABASE |con| (QUOTE CONSTRUCTORMODEMAP)))) + (SPADLET |alist| (|getCategoryExtensionAlist| |u|)) + (HPUT *ANCESTORS-HASH* (CAR |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 + +(DEFUN |encodeCategoryAlist| (|id| |alist|) + (PROG (|a| |b| |key| |argl| |newEntry| |u| |p| |newAl|) + (RETURN + (SEQ + (PROGN + (SPADLET |newAl| NIL) + (DO ((#0=#:G166715 |alist| (CDR #0#)) (#1=#:G166702 NIL)) + ((OR (ATOM #0#) (PROGN (SETQ #1# (CAR #0#)) NIL) (PROGN (PROGN (SPADLET |a| (CAR #1#)) (SPADLET |b| (CDR #1#)) #1#) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |key| (CAR |a|)) + (SPADLET |argl| (CDR |a|)) + (SPADLET |newEntry| (COND (|argl| (CONS (CONS |argl| |b|) NIL)) ((QUOTE T) |b|))) + (COND + ((SPADLET |u| (|assoc| |key| |newAl|)) + (COND + (|argl| + (RPLACD |u| (|encodeUnion| |id| (CAR |newEntry|) (CDR |u|)))) + ((NEQUAL |newEntry| (CDR |u|)) + (COND + ((SPADLET |p| + (|moreGeneralCategoryPredicate| |id| |newEntry| (CDR |u|))) + (RPLACD |u| |p|)) + ((QUOTE T) + (|sayMSG| "Duplicate entries:") + (PRINT (CONS |newEntry| (CONS (CDR |u|) NIL)))))) + ((QUOTE T) NIL))) + ((QUOTE T) + (SPADLET |newAl| (CONS (CONS |key| |newEntry|) |newAl|)))))))) + |newAl|))))) + +;encodeUnion(id,new:=[a,:b],alist) == +; u := ASSOC(a,alist) => +; RPLACD(u,moreGeneralCategoryPredicate(id,b,rest u)) +; alist +; [new,:alist] + +(DEFUN |encodeUnion| (|id| |new| |alist|) + (PROG (|a| |b| |u|) + (RETURN + (PROGN + (SPADLET |a| (CAR |new|)) + (SPADLET |b| (CDR |new|)) + (COND + ((SPADLET |u| (|assoc| |a| |alist|)) + (RPLACD |u| (|moreGeneralCategoryPredicate| |id| |b| (CDR |u|))) |alist|) + ((QUOTE T) + (CONS |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) + +(DEFUN |moreGeneralCategoryPredicate| (|id| |new| |old|) + (PROG (|a| |b| |ISTMP#1| |ISTMP#2| |c|) + (RETURN + (COND + ((OR (BOOT-EQUAL |old| (QUOTE T)) (BOOT-EQUAL |new| (QUOTE T))) (QUOTE T)) + ((AND + (PAIRP |old|) + (EQ (QCAR |old|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |old|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T)))))) + (PAIRP |new|) + (EQ (QCAR |new|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |new|)) + (AND + (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |a|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |c| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (COND + ((|tempExtendsCat| |b| |c|) |new|) + ((|tempExtendsCat| |c| |b|) |old|) + ((QUOTE T) (CONS (QUOTE OR) (CONS |old| (CONS |new| NIL)))))) + ((QUOTE T) (|mkCategoryOr| |new| |old|)))))) + +;mkCategoryOr(new,old) == +; old is ['OR,:l] => simpCategoryOr(new,l) +; ['OR,old,new] + +(DEFUN |mkCategoryOr| (|new| |old|) + (PROG (|l|) + (RETURN + (COND + ((AND (PAIRP |old|) + (EQ (QCAR |old|) (QUOTE OR)) + (PROGN (SPADLET |l| (QCDR |old|)) (QUOTE T))) + (|simpCategoryOr| |new| |l|)) + ((QUOTE T) (CONS (QUOTE OR) (CONS |old| (CONS |new| NIL)))))))) + +;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] + +(DEFUN |simpCategoryOr| (|new| |l|) + (PROG (|a| |b| |ISTMP#1| |ISTMP#2| |c| |anOldExtendsNew| + |newExtendsAnOld| |newList|) + (RETURN + (SEQ + (PROGN + (SPADLET |newExtendsAnOld| NIL) + (SPADLET |anOldExtendsNew| NIL) + (SPADLET |a| (CADR |new|)) + (SPADLET |b| (CADDR |new|)) + (SPADLET |newList| NIL) + (DO ((#0=#:G166818 |l| (CDR #0#)) (|pred| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |pred| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((AND (PAIRP |pred|) + (EQ (QCAR |pred|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |a|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |c| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (COND + ((|tempExtendsCat| |c| |b|) + (SPADLET |anOldExtendsNew| (QUOTE T))) + ((QUOTE T) + (COND + ((|tempExtendsCat| |b| |c|) + (SPADLET |newExtendsAnOld| (QUOTE T)))) + (SPADLET |newList| (CONS |pred| |newList|))))) + ((QUOTE T) (SPADLET |newList| (CONS |pred| |newList|))))))) + (COND + ((NULL |newExtendsAnOld|) (SPADLET |newList| (CONS |new| |newList|)))) + (COND + ((AND (PAIRP |newList|) (EQ (QCDR |newList|) NIL)) (CAR |newList|)) + ((QUOTE T) (CONS (QUOTE OR) |newList|)))))))) + +;tempExtendsCat(b,c) == +; or/[first c = a for [[a,:.],:.] in GETDATABASE(first b,'ANCESTORS)] + +(DEFUN |tempExtendsCat| (|b| |c|) + (PROG (|a|) + (RETURN + (SEQ + (PROG (#0=#:G166843) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166850 NIL #0#) + (#2=#:G166851 (GETDATABASE (CAR |b|) (QUOTE ANCESTORS)) (CDR #2#)) + (#3=#:G166840 NIL)) + ((OR #1# + (ATOM #2#) + (PROGN (SETQ #3# (CAR #2#)) NIL) + (PROGN (PROGN (SPADLET |a| (CAAR #3#)) #3#) NIL)) + #0#) + (SEQ (EXIT (SETQ #0# (OR #0# (BOOT-EQUAL (CAR |c|) |a|)))))))))))) + +;getCategoryExtensionAlist0 cform == +; [[cform,:'T],:getCategoryExtensionAlist cform] + +(DEFUN |getCategoryExtensionAlist0| (|cform|) + (CONS (CONS |cform| (QUOTE T)) (|getCategoryExtensionAlist| |cform|))) + +;getCategoryExtensionAlist cform == +; --avoids substitution as much as possible +; u:= GETDATABASE(first cform,'ANCESTORS) => formalSubstitute(cform,u) +; mkCategoryExtensionAlist cform + +(DEFUN |getCategoryExtensionAlist| (|cform|) + (PROG (|u|) + (RETURN + (COND + ((SPADLET |u| (GETDATABASE (CAR |cform|) (QUOTE ANCESTORS))) + (|formalSubstitute| |cform| |u|)) + ((QUOTE T) + (|mkCategoryExtensionAlist| |cform|)))))) + +;formalSubstitute(form:=[.,:argl],u) == +; isFormalArgumentList argl => u +; EQSUBSTLIST(argl,$FormalMapVariableList,u) + +(DEFUN |formalSubstitute| (|form| |u|) + (PROG (|argl|) + (RETURN + (PROGN + (SPADLET |argl| (CDR |form|)) + (COND + ((|isFormalArgumentList| |argl|) |u|) + ((QUOTE T) (EQSUBSTLIST |argl| |$FormalMapVariableList| |u|))))))) + +;isFormalArgumentList argl == +; and/[x=fa for x in argl for fa in $FormalMapVariableList] + +(DEFUN |isFormalArgumentList| (|argl|) + (PROG () + (RETURN + (SEQ + (PROG (#0=#:G166883) + (SPADLET #0# (QUOTE T)) + (RETURN + (DO ((#1=#:G166890 NIL (NULL #0#)) + (#2=#:G166891 |argl| (CDR #2#)) + (|x| NIL) + (#3=#:G166892 |$FormalMapVariableList| (CDR #3#)) + (|fa| NIL)) + ((OR #1# + (ATOM #2#) + (PROGN (SETQ |x| (CAR #2#)) NIL) + (ATOM #3#) + (PROGN (SETQ |fa| (CAR #3#)) NIL)) + #0#) + (SEQ (EXIT (SETQ #0# (AND #0# (BOOT-EQUAL |x| |fa|)))))))))))) + +;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 + +(DEFUN |mkCategoryExtensionAlist| (|cform|) + (PROG (|cop| |catlist| |cat| |pred| |newList| |a| |b| + |finalList| |extendsList|) + (RETURN + (SEQ + (COND + ((NULL (CONSP |cform|)) NIL) + ((QUOTE T) + (SPADLET |cop| (CAR |cform|)) + (COND + ((MEMQ |cop| |$CategoryNames|) + (|mkCategoryExtensionAlistBasic| |cform|)) + ((QUOTE T) + (SPADLET |catlist| + (|formalSubstitute| |cform| + (CAR (|getConstructorExports| |cform| (QUOTE T))))) + (SPADLET |extendsList| NIL) + (DO ((#0=#:G166927 |catlist| (CDR #0#)) (#1=#:G166912 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |cat| (CAR #1#)) + (SPADLET |pred| (CDR #1#)) + #1#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |newList| (|getCategoryExtensionAlist0| |cat|)) + (SPADLET |finalList| + (COND + ((BOOT-EQUAL |pred| (QUOTE T)) |newList|) + ((QUOTE T) + (PROG (#2=#:G166939) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G166945 |newList| (CDR #3#)) (#4=#:G166906 NIL)) + ((OR (ATOM #3#) + (PROGN (SETQ #4# (CAR #3#)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR #4#)) + (SPADLET |b| (CDR #4#)) + #4#) + NIL)) + (NREVERSE0 #2#)) + (SEQ + (EXIT + (SETQ #2# + (CONS (CONS |a| (|quickAnd| |b| |pred|)) #2#)))))))))) + (SPADLET |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 + +(DEFUN |mkCategoryExtensionAlistBasic| (|cform|) + (PROG (|cop| |category| |cat| |pred| |newList| |a| |b| + |finalList| |extendsList|) + (RETURN + (SEQ + (PROGN + (SPADLET |cop| (CAR |cform|)) + (SPADLET |category| + (COND + ((|macrop| |cop|) (|eval| |cform|)) + ((QUOTE T) (APPLY |cop| (CDR |cform|))))) + (SPADLET |extendsList| + (PROG (#0=#:G166982) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166987 (ELT (ELT |category| 4) 0) (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (CONS |x| (QUOTE T)) #0#)))))))) + (DO ((#2=#:G167003 (ELT (ELT |category| 4) 1) (CDR #2#)) + (#3=#:G166973 NIL)) + ((OR (ATOM #2#) + (PROGN (SETQ #3# (CAR #2#)) NIL) + (PROGN + (PROGN + (SPADLET |cat| (CAR #3#)) + (SPADLET |pred| (CADR #3#)) + #3#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |newList| (|getCategoryExtensionAlist0| |cat|)) + (SPADLET |finalList| + (COND + ((BOOT-EQUAL |pred| (QUOTE T)) |newList|) + ((QUOTE T) + (PROG (#4=#:G167015) + (SPADLET #4# NIL) + (RETURN + (DO ((#5=#:G167021 |newList| (CDR #5#)) (#6=#:G166967 NIL)) + ((OR (ATOM #5#) + (PROGN (SETQ #6# (CAR #5#)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR #6#)) + (SPADLET |b| (CDR #6#)) + #6#) + NIL)) + (NREVERSE0 #4#)) + (SEQ + (EXIT + (SETQ #4# + (CONS (CONS |a| (|quickAnd| |b| |pred|)) #4#)))))))))) + (SPADLET |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 + +(DEFUN |catPairUnion,addConflict| (|new| |old|) (|quickOr| |new| |old|)) + +(DEFUN |catPairUnion| (|oldList| |newList| |op| |cat|) + (PROG (|u|) + (RETURN + (SEQ + (PROGN + (DO ((#0=#:G167053 |newList| (CDR #0#)) (|pair| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |pair| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((SPADLET |u| (|assoc| (CAR |pair|) |oldList|)) + (COND + ((BOOT-EQUAL (CDR |u|) (CDR |pair|)) NIL) + ((QUOTE T) + (RPLACD |u| + (|catPairUnion,addConflict| (CDR |pair|) (CDR |u|)))))) + ((QUOTE T) (SPADLET |oldList| (CONS |pair| |oldList|))))))) + |oldList|))))) + +;simpCatPredicate p == +; p is ['OR,:l] => +; (u:= simpOrUnion l) is [p] => p +; ['OR,:u] +; p + +(DEFUN |simpCatPredicate| (|p|) + (PROG (|l| |u| |ISTMP#1|) + (RETURN + (COND + ((AND (PAIRP |p|) + (EQ (QCAR |p|) (QUOTE OR)) + (PROGN (SPADLET |l| (QCDR |p|)) (QUOTE T))) + (COND + ((PROGN + (SPADLET |ISTMP#1| (SPADLET |u| (|simpOrUnion| |l|))) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |p| (QCAR |ISTMP#1|)) (QUOTE T)))) + |p|) + ((QUOTE T) (CONS (QUOTE OR) |u|)))) + ((QUOTE T) |p|))))) + +;simpOrUnion l == +; if l then simpOrUnion1(first l,simpOrUnion rest l) +; else l + +(DEFUN |simpOrUnion| (|l|) + (COND + (|l| (|simpOrUnion1| (CAR |l|) (|simpOrUnion| (CDR |l|)))) + ((QUOTE T) |l|))) + +;simpOrUnion1(x,l) == +; null l => [x] +; p:= mergeOr(x,first l) => [p,:rest l] +; [first l,:simpOrUnion1(x,rest l)] + +(DEFUN |simpOrUnion1| (|x| |l|) + (PROG (|p|) + (RETURN + (COND + ((NULL |l|) (CONS |x| NIL)) + ((SPADLET |p| (|mergeOr| |x| (CAR |l|))) (CONS |p| (CDR |l|))) + ((QUOTE T) (CONS (CAR |l|) (|simpOrUnion1| |x| (CDR |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 + +(DEFUN |mergeOr| (|x| |y|) + (PROG (|a| |b| |ISTMP#1| |ISTMP#2| |c|) + (RETURN + (COND + ((AND + (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T)))))) + (PAIRP |y|) + (EQ (QCAR |y|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |a|) + (PROGN (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |c| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (COND + ((|testExtend| |b| |c|) |y|) + ((|testExtend| |c| |b|) |x|) + ((QUOTE T) NIL))) + ((QUOTE T) NIL))))) + +;testExtend(a:=[op,:argl],b) == +; (u:= GETDATABASE(op,'ANCESTORS)) and (val:= LASSOC(b,u)) => +; formalSubstitute(a,val) +; nil + +(DEFUN |testExtend| (|a| |b|) + (PROG (|op| |argl| |u| |val|) + (RETURN + (PROGN + (SPADLET |op| (CAR |a|)) + (SPADLET |argl| (CDR |a|)) + (COND + ((AND (SPADLET |u| (GETDATABASE |op| (QUOTE ANCESTORS))) + (SPADLET |val| (LASSOC |b| |u|))) + (|formalSubstitute| |a| |val|)) + ((QUOTE T) 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 + +(DEFUN |getConstrCat| (|x|) + (PROG (|y| |ISTMP#1| |z| |cats|) + (RETURN + (SEQ + (PROGN + (SPADLET |x| + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |Join|)) + (PROGN (SPADLET |y| (QCDR |x|)) (QUOTE T))) + |y|) + ((QUOTE T) (CONS |x| NIL)))) + (SPADLET |cats| NIL) + (DO ((#0=#:G167152 |x| (CDR #0#)) (|y| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |y| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((AND (PAIRP |y|) + (EQ (QCAR |y|) (QUOTE CATEGORY)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET |z| (QCDR |ISTMP#1|)) (QUOTE T))))) + (DO ((#1=#:G167161 |z| (CDR #1#)) (|zz| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |zz| (CAR #1#)) NIL)) NIL) + (SEQ + (EXIT (SPADLET |cats| (|makeCatPred| |zz| |cats| (QUOTE T))))))) + ((QUOTE T) (SPADLET |cats| (CONS |y| |cats|))))))) + (SPADLET |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 + +(DEFUN |makeCatPred| (|zz| |cats| |thePred|) + (PROG (|ISTMP#2| |ISTMP#3| |z1| |ISTMP#4| |z2| |curPred| |ISTMP#5| + |ISTMP#6| |atl| |ats| |z3| |ISTMP#1| |pred|) + (RETURN + (SEQ + (PROGN + (COND + ((AND + (PAIRP |zz|) + (EQ (QCAR |zz|) (QUOTE IF)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |zz|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |z1| (QCAR |ISTMP#3|)) + (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN + (SPADLET |z2| (QCAR |ISTMP#4|)) + (QUOTE T)))))))) + (PROGN (SPADLET |curPred| (QCAR |ISTMP#1|)) (QUOTE T)) + (PROGN + (SPADLET |ISTMP#5| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#5|) + (PROGN + (SPADLET |ats| (QCAR |ISTMP#5|)) + (SPADLET |ISTMP#6| (QCDR |ISTMP#5|)) + (AND (PAIRP |ISTMP#6|) (EQ (QCDR |ISTMP#6|) NIL)))))))) + (SPADLET |ats| + (COND + ((AND (PAIRP |ats|) + (EQ (QCAR |ats|) (QUOTE PROGN)) + (PROGN (SPADLET |atl| (QCDR |ats|)) (QUOTE T))) + |atl|) + ((QUOTE T) (CONS |ats| NIL)))) + (DO ((#0=#:G167257 |ats| (CDR #0#)) (|at| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |at| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (COND + ((AND + (PAIRP |at|) + (EQ (QCAR |at|) (QUOTE ATTRIBUTE)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |at|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |z3| (QCAR |ISTMP#1|)) (QUOTE T)))) + (NULL (ATOM |z3|)) (|constructor?| (CAR |z3|))) + (SPADLET |cats| + (CONS + (CONS + (QUOTE IF) + (CONS + (|quickAnd| + (CONS (QUOTE |has|) (CONS |z1| (CONS |z2| NIL))) |thePred|) + (CONS |z3| (CONS (QUOTE |noBranch|) NIL)))) + |cats|)))) + (COND + ((AND + (PAIRP |at|) + (EQ (QCAR |at|) (QUOTE IF)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |at|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET |pred| (QCAR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |cats| (|makeCatPred| |at| |cats| |curPred|)))))))))) + |cats|))))) + +;getConstructorExports(conform,:options) == categoryParts(conform, +; GETDATABASE(opOf conform,'CONSTRUCTORCATEGORY),IFCAR options) + +(DEFUN |getConstructorExports| (&REST #0=#:G167287 &AUX |options| |conform|) + (DSETQ (|conform| . |options|) #0#) + (|categoryParts| |conform| + (GETDATABASE (|opOf| |conform|) (QUOTE 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 + +(DEFUN |categoryParts,exportsOf| (|target|) + (PROG (|ISTMP#1| |ISTMP#2| |f| |r|) + (RETURN + (SEQ + (IF + (AND + (PAIRP |target|) + (EQ (QCAR |target|) (QUOTE CATEGORY)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |r| (QCDR |ISTMP#1|)) (QUOTE T))))) + (EXIT |r|)) + (IF + (AND + (PAIRP |target|) + (EQ (QCAR |target|) (QUOTE |Join|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) (QUOTE T))) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |f| (QCAR |ISTMP#2|)) + (SPADLET |r| (QCDR |ISTMP#2|)) + (QUOTE T))) + (PROGN (SPADLET |r| (NREVERSE |r|)) (QUOTE T))))) + (EXIT + (SEQ + (DO ((#0=#:G167385 |r| (CDR #0#)) (|x| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (SPADLET |$conslist| (CONS (CONS |x| (QUOTE T)) |$conslist|))))) + (EXIT (|categoryParts,exportsOf| |f|))))) + (SPADLET |$conslist| (CONS (CONS |target| (QUOTE T)) |$conslist|)) + (EXIT NIL))))) + +(DEFUN |categoryParts,build| (|item| |pred|) + (PROG (|sig| |attr| |op| |type| |ISTMP#1| |pred1| |ISTMP#2| + |s1| |ISTMP#3| |s2| |r|) + (RETURN + (SEQ + (IF + (AND + (PAIRP |item|) + (EQ (QCAR |item|) (QUOTE SIGNATURE)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN (SPADLET |sig| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (EXIT + (SPADLET |$oplist| + (CONS (CONS (|opOf| |op|) (CONS |sig| |pred|)) |$oplist|)))) + (IF + (AND + (PAIRP |item|) + (EQ (QCAR |item|) (QUOTE ATTRIBUTE)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |attr| (QCAR |ISTMP#1|)) (QUOTE T))))) + (EXIT + (SEQ + (IF + (|constructor?| (|opOf| |attr|)) + (EXIT + (SEQ + (SPADLET |$conslist| (CONS (CONS |attr| |pred|) |$conslist|)) + (EXIT NIL)))) + (IF (BOOT-EQUAL (|opOf| |attr|) (QUOTE |nothing|)) + (EXIT (QUOTE |skip|))) + (EXIT + (SPADLET |$attrlist| + (CONS + (CONS (|opOf| |attr|) (CONS (IFCDR |attr|) |pred|)) + |$attrlist|)))))) + (IF + (AND + (PAIRP |item|) + (EQ (QCAR |item|) (QUOTE TYPE)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |type| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (EXIT + (SPADLET |$oplist| + (CONS (CONS |op| (CONS (CONS |type| NIL) |pred|)) |$oplist|)))) + (IF + (AND + (PAIRP |item|) + (EQ (QCAR |item|) (QUOTE IF)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pred1| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |s1| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN (SPADLET |s2| (QCAR |ISTMP#3|)) (QUOTE T))))))))) + (EXIT + (SEQ + (|categoryParts,build| |s1| (|quickAnd| |pred| |pred1|)) + (EXIT + (IF |s2| + (EXIT + (|categoryParts,build| |s2| + (|quickAnd| |pred| (CONS (QUOTE NOT) (CONS |pred1| NIL)))))))))) + (IF + (AND + (PAIRP |item|) + (EQ (QCAR |item|) (QUOTE PROGN)) + (PROGN (SPADLET |r| (QCDR |item|)) (QUOTE T))) + (EXIT + (DO ((#0=#:G167406 |r| (CDR #0#)) (|x| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) + (SEQ (EXIT (|categoryParts,build| |x| |pred|)))))) + (IF (|member| |item| (QUOTE (|noBranch|))) (EXIT (QUOTE |ok|))) + (IF (NULL |item|) (EXIT (QUOTE |ok|))) + (EXIT (|systemError| (MAKESTRING "build error"))))))) + +(DEFUN |categoryParts| (&REST #0=#:G167466 &AUX |options| |category| |conform|) + (DSETQ (|conform| |category| . |options|) #0#) + (PROG (|$attrlist| |$oplist| |$conslist| |cons?| |conname| |tvl| |res|) + (DECLARE (SPECIAL |$attrlist| |$oplist| |$conslist|)) + (RETURN + (SEQ + (PROGN + (SPADLET |cons?| (IFCAR |options|)) + (SPADLET |$attrlist| NIL) + (SPADLET |$oplist| NIL) + (SPADLET |$conslist| NIL) + (SPADLET |conname| (|opOf| |conform|)) + (DO ((#1=#:G167440 (|categoryParts,exportsOf| |category|) (CDR #1#)) + (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) NIL) + (SEQ (EXIT (|categoryParts,build| |x| (QUOTE T))))) + (SPADLET |$attrlist| (|listSort| (|function| GLESSEQP) |$attrlist|)) + (SPADLET |$oplist| (|listSort| (|function| GLESSEQP) |$oplist|)) + (SPADLET |res| (CONS |$attrlist| |$oplist|)) + (COND + (|cons?| + (SPADLET |res| + (CONS (|listSort| (|function| GLESSEQP) |$conslist|) |res|)))) + (COND + ((BOOT-EQUAL (GETDATABASE |conname| (QUOTE CONSTRUCTORKIND)) + (QUOTE |category|)) + (SPADLET |tvl| (TAKE (|#| (CDR |conform|)) |$TriangleVariableList|)) + (SPADLET |res| (SUBLISLIS |$FormalMapVariableList| |tvl| |res|)))) + |res|))))) + +;--------------------> 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 + +(DEFUN |compressHashTable| (|ht|) + (PROG (|$found|) + (DECLARE (SPECIAL |$found|)) + (RETURN + (SEQ + (PROGN + (|sayBrightlyNT| (MAKESTRING "compressing hash table...")) + (SPADLET |$found| (MAKE-HASHTABLE (QUOTE UEQUAL))) + (DO ((#0=#:G167471 (HKEYS |ht|) (CDR #0#)) (|x| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) + (SEQ (EXIT (|compressSexpr| (HGET |ht| |x|) NIL NIL)))) + (|sayBrightly| (MAKESTRING "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) + +(DEFUN |compressSexpr| (|x| |left| |right|) + (PROG (|u|) + (RETURN + (COND + ((ATOM |x|) NIL) + ((SPADLET |u| (HGET |$found| |x|)) + (COND + (|left| (RPLACA |left| |u|)) + (|right| (RPLACD |right| |u|)) + ((QUOTE T) NIL))) + ((QUOTE T) + (|compressSexpr| (CAR |x|) |x| NIL) + (|compressSexpr| (CDR |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 + +(DEFUN |squeezeList| (|l|) + (PROG (|$found|) + (DECLARE (SPECIAL |$found|)) + (RETURN (PROGN (SPADLET |$found| 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) + +(DEFUN |squeeze1| (|l|) + (PROG (|x| |z| |y|) + (RETURN + (PROGN + (SPADLET |x| (CAR |l|)) + (SPADLET |y| + (COND + ((ATOM |x|) |x|) + ((SPADLET |z| (|member| |x| |$found|)) (CAR |z|)) + ((QUOTE T) (SPADLET |$found| (CONS |x| |$found|)) (|squeeze1| |x|)))) + (RPLACA |l| |y|) + (SPADLET |x| (CDR |l|)) + (SPADLET |y| + (COND + ((ATOM |x|) |x|) + ((SPADLET |z| (|member| |x| |$found|)) (CAR |z|)) + ((QUOTE T) (SPADLET |$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))) + +(DEFUN |updateCategoryTable| (|cname| |kind|) + (COND + ((BOOT-EQUAL |$newcompMode| (QUOTE T)) NIL) + (|$updateCatTableIfTrue| + (COND + ((BOOT-EQUAL |kind| (QUOTE |package|)) NIL) + ((BOOT-EQUAL |kind| (QUOTE |category|)) + (|updateCategoryTableForCategory| |cname|)) + ((QUOTE T) + (|updateCategoryTableForDomain| |cname| + (|getConstrCat| (GETDATABASE |cname| (QUOTE CONSTRUCTORCATEGORY))))))) + ((AND (BOOT-EQUAL |kind| (QUOTE |domain|)) + (BOOT-EQUAL |$NRTflag| (QUOTE T))) + (|updateCategoryTableForDomain| |cname| + (|getConstrCat| (GETDATABASE |cname| (QUOTE 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) + +(DEFUN |updateCategoryTableForCategory| (|cname|) + (PROG (|b|) + (RETURN + (SEQ + (PROGN + (|clearTempCategoryTable| + (CONS (CONS |cname| (CONS (QUOTE |category|) NIL)) NIL)) + (|addToCategoryTable| |cname|) + (DO ((#0=#:G167523 (HKEYS *ANCESTORS-HASH*) (CDR #0#)) (|id| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |id| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (DO ((#1=#:G167533 (GETDATABASE |id| (QUOTE ANCESTORS)) (CDR #1#)) + (|u| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |u| (CAR #1#)) NIL) + (PROGN (PROGN (SPADLET |b| (CDR |u|)) |u|) NIL)) NIL) + (SEQ + (EXIT (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_* + +(DEFUN |updateCategoryTableForDomain| (|cname| |category|) + (PROG (|LETTMP#1| |domainEntry| |a| |b|) + (RETURN + (SEQ + (PROGN + (|clearCategoryTable| |cname|) + (SPADLET |LETTMP#1| (|addDomainToTable| |cname| |category|)) + (SPADLET |cname| (CAR |LETTMP#1|)) + (SPADLET |domainEntry| (CDR |LETTMP#1|)) + (DO ((#0=#:G167560 + (|encodeCategoryAlist| |cname| |domainEntry|) (CDR #0#)) + (#1=#:G167551 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN (SPADLET |a| (CAR #1#)) (SPADLET |b| (CDR #1#)) #1#) + NIL)) + NIL) + (SEQ (EXIT (HPUT *HASCATEGORY-HASH* (CONS |cname| |a|) |b|)))) + (COND + ((BOOT-EQUAL |$doNotCompressHashTableIfTrue| (QUOTE T)) + *HASCATEGORY-HASH*) + ((QUOTE T) (|compressHashTable| *HASCATEGORY-HASH*)))))))) + +;clearCategoryTable($cname) == +; MAPHASH('clearCategoryTable1,_*HASCATEGORY_-HASH_*) + +(DEFUN |clearCategoryTable| (|$cname|) + (DECLARE (SPECIAL |$cname|)) + (MAPHASH (QUOTE |clearCategoryTable1|) *HASCATEGORY-HASH*)) + +;clearCategoryTable1(key,val) == +; (CAR key=$cname)=> HREM(_*HASCATEGORY_-HASH_*,key) +; nil + +(DEFUN |clearCategoryTable1| (|key| |val|) + (COND + ((BOOT-EQUAL (CAR |key|) |$cname|) (HREM *HASCATEGORY-HASH* |key|)) + ((QUOTE T) 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) + +(DEFUN |clearTempCategoryTable| (|catNames|) + (PROG (|catForm| |extensions|) + (RETURN + (SEQ + (DO ((#0=#:G167592 (HKEYS *ANCESTORS-HASH*) (CDR #0#)) (|key| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |key| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((MEMQ |key| |catNames|) NIL) + ((QUOTE T) + (SPADLET |extensions| NIL) + (DO ((#1=#:G167602 (GETDATABASE |key| (QUOTE ANCESTORS)) (CDR #1#)) + (|extension| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |extension| (CAR #1#)) NIL) + (PROGN + (PROGN (SPADLET |catForm| (CAR |extension|)) |extension|) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((MEMQ (CAR |catForm|) |catNames|) NIL) + ((QUOTE T) + (SPADLET |extensions| (CONS |extension| |extensions|))))))) + (HPUT *ANCESTORS-HASH* |key| |extensions|)))))))))) + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/debugsys.lisp.pamphlet b/src/interp/debugsys.lisp.pamphlet index 7eb950f..3d0226b 100644 --- a/src/interp/debugsys.lisp.pamphlet +++ b/src/interp/debugsys.lisp.pamphlet @@ -88,7 +88,7 @@ loaded by hand we need to establish a value. (thesymb "/int/interp/astr.lisp") (thesymb "/int/interp/alql.lisp") (thesymb "/int/interp/buildom.lisp") - (thesymb "/int/interp/cattable.clisp") + (thesymb "/int/interp/cattable.lisp") (thesymb "/int/interp/cformat.clisp") (thesymb (concatenate 'string "/obj/" *sys* "/interp/cfuns.o")) (thesymb "/int/interp/clam.clisp")