From 9b71e0a1f285fc207709cf8e90721160af299127 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Thu, 20 Sep 2007 03:47:46 +0000 Subject: remove pamphlets - part 3 --- src/interp/cattable.boot.pamphlet | 527 -------------------------------------- 1 file changed, 527 deletions(-) delete mode 100644 src/interp/cattable.boot.pamphlet (limited to 'src/interp/cattable.boot.pamphlet') diff --git a/src/interp/cattable.boot.pamphlet b/src/interp/cattable.boot.pamphlet deleted file mode 100644 index d25eaf80..00000000 --- a/src/interp/cattable.boot.pamphlet +++ /dev/null @@ -1,527 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp cattable.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{License} - -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -hasCat(domainOrCatName,catName) == - catName='Object or catName='Type -- every domain is a Type (Object) - or GETDATABASE([domainOrCatName,:catName],'HASCATEGORY) - -showCategoryTable con == - [[b,:val] for (key :=[a,:b]) in HKEYS _*HASCATEGORY_-HASH_* - | a = con and (val := HGET(_*HASCATEGORY_-HASH_*,key))] - -displayCategoryTable(:options) == - conList := IFCAR options - SETQ($ct,MAKE_-HASHTABLE 'ID) - for (key:=[a,:b]) in HKEYS _*HASCATEGORY_-HASH_* repeat - HPUT($ct,a,[[b,:HGET(_*HASCATEGORY_-HASH_*,key)],:HGET($ct,a)]) - for id in HKEYS $ct | null conList or MEMQ(id,conList) repeat - sayMSG [:bright id,'"extends:"] - PRINT HGET($ct,id) - -genCategoryTable() == - SETQ(_*ANCESTORS_-HASH_*, MAKE_-HASHTABLE 'ID) - SETQ(_*HASCATEGORY_-HASH_*,MAKE_-HASHTABLE 'UEQUAL) - genTempCategoryTable() - domainList:= - [con for con in allConstructors() - | GETDATABASE(con,'CONSTRUCTORKIND) = 'domain] - domainTable:= [addDomainToTable(con,getConstrCat catl) for con - in domainList | catl := GETDATABASE(con,'CONSTRUCTORCATEGORY)] - -- $nonLisplibDomains, $noCategoryDomains are set in BUILDOM BOOT - specialDs := SETDIFFERENCE($nonLisplibDomains,$noCategoryDomains) - domainTable:= [:[addDomainToTable(id, getConstrCat (eval [id]).3) - for id in specialDs], :domainTable] - for [id,:entry] in domainTable repeat - for [a,:b] in encodeCategoryAlist(id,entry) repeat - HPUT(_*HASCATEGORY_-HASH_*,[id,:a],b) - simpTempCategoryTable() - compressHashTable _*ANCESTORS_-HASH_* - simpCategoryTable() - compressHashTable _*HASCATEGORY_-HASH_* - -simpTempCategoryTable() == - for id in HKEYS _*ANCESTORS_-HASH_* repeat - for (u:=[a,:b]) in GETDATABASE(id,'ANCESTORS) repeat - RPLACA(u,SUBST('Type,'Object,a)) - RPLACD(u,simpHasPred b) - -simpCategoryTable() == main where - main == - for key in HKEYS _*HASCATEGORY_-HASH_* repeat - entry := HGET(_*HASCATEGORY_-HASH_*,key) - null entry => HREM(_*HASCATEGORY_-HASH_*,key) - change := - atom opOf entry => simpHasPred entry - [[x,:npred] for [x,:pred] in entry | npred := simpHasPred pred] - HPUT(_*HASCATEGORY_-HASH_*,key,change) - -simpHasPred(pred,:options) == main where - main == - $hasArgs: local := IFCDR IFCAR options - simp pred - simp pred == - pred is [op,:r] => - op = 'has => simpHas(pred,first r,first rest r) - op = 'HasCategory => simp ['has,CAR r,simpDevaluate CADR r] - op = 'HasSignature => - [op,sig] := simpDevaluate CADR r - ['has,CAR r,['SIGNATURE,op,sig]] - op = 'HasAttribute => - form := ['has,a := CAR r,['ATTRIBUTE,b := simpDevaluate CADR r]] - simpHasAttribute(form,a,b) - MEMQ(op,'(AND OR NOT)) => - null (u := MKPF([simp p for p in r],op)) => nil - u is '(QUOTE T) => true - simpBool u - op = 'hasArgs => ($hasArgs => $hasArgs = r; pred) - null r and opOf op = 'has => simp first pred - pred is '(QUOTE T) => true - op1 := LASSOC(op,'((and . AND)(or . OR)(not . NOT))) => simp [op1,:r] - simp first pred --REMOVE THIS HACK !!!! - pred in '(T etc) => pred - null pred => nil - pred - simpDevaluate a == EVAL SUBST('QUOTE,'devaluate,a) - simpHas(pred,a,b) == - b is ['ATTRIBUTE,attr] => simpHasAttribute(pred,a,attr) - b is ['SIGNATURE,op,sig] => simpHasSignature(pred,a,op,sig) - IDENTP a or hasIdent b => pred - npred := eval pred - IDENTP npred or null hasIdent npred => npred - pred - eval (pred := ['has,d,cat]) == - x := hasCat(CAR d,CAR cat) - y := CDR cat => - npred := or/[p for [args,:p] in x | y = args] => simp npred - false --if not there, it is false - x - -simpHasSignature(pred,conform,op,sig) == --eval w/o loading - IDENTP conform => pred - [conname,:args] := conform - n := #sig - u := LASSOC(op,GETDATABASE(conname,'OPERATIONALIST)) - candidates := [x for (x := [sig1,:.]) in u | #sig1 = #sig] or return false - match := or/[x for (x := [sig1,:.]) in candidates - | sig = sublisFormal(args,sig1)] or return false - simpHasPred(match is [sig,.,:p] and sublisFormal(args,p) or true) - -simpHasAttribute(pred,conform,attr) == --eval w/o loading - IDENTP conform => pred - conname := opOf conform - GETDATABASE(conname,'CONSTRUCTORKIND) = 'category => - simpCatHasAttribute(conform,attr) - asharpConstructorName? conname => - p := LASSOC(attr,GETDATABASE(conname,'attributes)) => - simpHasPred sublisFormal(rest conform,p) - infovec := dbInfovec conname - k := LASSOC(attr,infovec.2) or return nil --if not listed then false - k = 0 => true - $domain => kTestPred k --from koOps - predvec := $predvec or sublisFormal(rest conform, - GETDATABASE(conname,'PREDICATES)) - simpHasPred predvec.(k - 1) - -simpCatHasAttribute(domform,attr) == - conform := getConstructorForm opOf domform - catval := EVAL mkEvalable conform - if atom KDR attr then attr := IFCAR attr - pred := - u := LASSOC(attr,catval . 2) => first u - return false --exit: not there - pred = true => true - EVAL SUBLISLIS(rest domform,rest conform,pred) - -hasIdent pred == - pred is [op,:r] => - op = 'QUOTE => false - or/[hasIdent x for x in r] - pred = '_$ => false - IDENTP pred => true - false - -addDomainToTable(id,catl) == - alist:= nil - for cat in catl repeat - cat is ['CATEGORY,:.] => nil - cat is ['IF,pred,cat1,:.] => - newAlist:= - [[a,:quickAnd(pred,b)] for [a,:b] in getCategoryExtensionAlist0 cat1] - alist:= [:alist,:newAlist] - alist:= [:alist,:getCategoryExtensionAlist0 cat] - [id,:alist] - -domainHput(table,key:=[id,:a],b) == - HPUT(table,key,b) - -genTempCategoryTable() == - --generates hashtable with key=categoryName and value of the form - -- ((form . pred) ..) meaning that - -- "IF pred THEN ofCategory(key,form)" - -- where form can involve #1, #2, ... the parameters of key - for con in allConstructors() repeat - GETDATABASE(con,'CONSTRUCTORKIND) = 'category => - addToCategoryTable con - for id in HKEYS _*ANCESTORS_-HASH_* repeat - item := HGET(_*ANCESTORS_-HASH_*, id) - for (u:=[.,:b]) in item repeat - RPLACD(u,simpCatPredicate simpBool b) - HPUT(_*ANCESTORS_-HASH_*,id,listSort(function GLESSEQP,item)) - -addToCategoryTable con == - -- adds an entry to $tempCategoryTable with key=con and alist entries - u := CAAR GETDATABASE(con,'CONSTRUCTORMODEMAP) --domain - alist := getCategoryExtensionAlist u - HPUT(_*ANCESTORS_-HASH_*,first u,alist) - alist - -encodeCategoryAlist(id,alist) == - newAl:= nil - for [a,:b] in alist repeat - [key,:argl] := a - newEntry:= - argl => [[argl,:b]] - b - u:= ASSOC(key,newAl) => - argl => RPLACD(u,encodeUnion(id,first newEntry,rest u)) - if newEntry ^= rest u then - p:= moreGeneralCategoryPredicate(id,newEntry,rest u) => RPLACD(u,p) - sayMSG '"Duplicate entries:" - PRINT [newEntry,rest u] - newAl:= [[key,:newEntry],:newAl] - newAl - -encodeUnion(id,new:=[a,:b],alist) == - u := ASSOC(a,alist) => - RPLACD(u,moreGeneralCategoryPredicate(id,b,rest u)) - alist - [new,:alist] - -moreGeneralCategoryPredicate(id,new,old) == - old = 'T or new = 'T => 'T - old is ['has,a,b] and new is ['has,=a,c] => - tempExtendsCat(b,c) => new - tempExtendsCat(c,b) => old - ['OR,old,new] - mkCategoryOr(new,old) - -mkCategoryOr(new,old) == - old is ['OR,:l] => simpCategoryOr(new,l) - ['OR,old,new] - -simpCategoryOr(new,l) == - newExtendsAnOld:= false - anOldExtendsNew:= false - ['has,a,b] := new - newList:= nil - for pred in l repeat - pred is ['has,=a,c] => - tempExtendsCat(c,b) => anOldExtendsNew:= true - if tempExtendsCat(b,c) then newExtendsAnOld:= true - newList:= [pred,:newList] - newList:= [pred,:newList] - if not newExtendsAnOld then newList:= [new,:newList] - newList is [.] => first newList - ['OR,:newList] - -tempExtendsCat(b,c) == - or/[first c = a for [[a,:.],:.] in GETDATABASE(first b,'ANCESTORS)] - -getCategoryExtensionAlist0 cform == - [[cform,:'T],:getCategoryExtensionAlist cform] - -getCategoryExtensionAlist cform == - --avoids substitution as much as possible - u:= GETDATABASE(first cform,'ANCESTORS) => formalSubstitute(cform,u) - mkCategoryExtensionAlist cform - -formalSubstitute(form:=[.,:argl],u) == - isFormalArgumentList argl => u - EQSUBSTLIST(argl,$FormalMapVariableList,u) - -isFormalArgumentList argl == - and/[x=fa for x in argl for fa in $FormalMapVariableList] - -mkCategoryExtensionAlist cform == - not CONSP cform => nil - cop := first cform - MEMQ(cop, $CategoryNames) => mkCategoryExtensionAlistBasic cform - catlist := formalSubstitute(cform, first getConstructorExports(cform, true)) - extendsList:= nil - for [cat,:pred] in catlist repeat - newList := getCategoryExtensionAlist0 cat - finalList := - pred = 'T => newList - [[a,:quickAnd(b,pred)] for [a,:b] in newList] - extendsList:= catPairUnion(extendsList,finalList,cop,cat) - extendsList - --- following code to handle Unions Records Mapping etc. -mkCategoryExtensionAlistBasic cform == - cop := first cform ---category:= eval cform - category := -- changed by RSS on 7/29/87 - macrop cop => eval cform - APPLY(cop, rest cform) - extendsList:= [[x,:'T] for x in category.4.0] - for [cat,pred,:.] in category.4.1 repeat - newList := getCategoryExtensionAlist0 cat - finalList := - pred = 'T => newList - [[a,:quickAnd(b,pred)] for [a,:b] in newList] - extendsList:= catPairUnion(extendsList,finalList,cop,cat) - extendsList - -catPairUnion(oldList,newList,op,cat) == - for pair in newList repeat - u:= ASSOC(first pair,oldList) => - rest u = rest pair => nil - RPLACD(u,addConflict(rest pair,rest u)) where addConflict(new,old) == - quickOr(new,old) - oldList:= [pair,:oldList] - oldList - -simpCatPredicate p == - p is ['OR,:l] => - (u:= simpOrUnion l) is [p] => p - ['OR,:u] - p - -simpOrUnion l == - if l then simpOrUnion1(first l,simpOrUnion rest l) - else l - -simpOrUnion1(x,l) == - null l => [x] - p:= mergeOr(x,first l) => [p,:rest l] - [first l,:simpOrUnion1(x,rest l)] - -mergeOr(x,y) == - x is ['has,a,b] and y is ['has,=a,c] => - testExtend(b,c) => y - testExtend(c,b) => x - nil - nil - -testExtend(a:=[op,:argl],b) == - (u:= GETDATABASE(op,'ANCESTORS)) and (val:= LASSOC(b,u)) => - formalSubstitute(a,val) - nil - -getConstrCat(x) == --- gets a different representation of the constructorCategory from the --- lisplib, which is a list of named categories or conditions - x:= if x is ['Join,:y] then y else [x] - cats:= NIL - for y in x repeat - y is ['CATEGORY,.,:z] => - for zz in z repeat cats := makeCatPred(zz, cats, true) - cats:= CONS(y,cats) - cats:= nreverse cats - cats - - -makeCatPred(zz, cats, thePred) == - if zz is ['IF,curPred := ['has,z1,z2],ats,.] then - ats := if ats is ['PROGN,:atl] then atl else [ats] - for at in ats repeat - if at is ['ATTRIBUTE,z3] and not atom z3 and - constructor? CAR z3 then - cats:= CONS(['IF,quickAnd(['has,z1,z2], thePred),z3,'noBranch],cats) - at is ['IF, pred, :.] => - cats := makeCatPred(at, cats, curPred) - cats - -getConstructorExports(conform,:options) == categoryParts(conform, - GETDATABASE(opOf conform,'CONSTRUCTORCATEGORY),IFCAR options) - -categoryParts(conform,category,:options) == main where - main == - cons? := IFCAR options --means to include constructors as well - $attrlist: local := nil - $oplist : local := nil - $conslist: local := nil - conname := opOf conform - for x in exportsOf(category) repeat build(x,true) - $attrlist := listSort(function GLESSEQP,$attrlist) - $oplist := listSort(function GLESSEQP,$oplist) - res := [$attrlist,:$oplist] - if cons? then res := [listSort(function GLESSEQP,$conslist),:res] - if GETDATABASE(conname,'CONSTRUCTORKIND) = 'category then - tvl := TAKE(#rest conform,$TriangleVariableList) - res := SUBLISLIS($FormalMapVariableList,tvl,res) - res - build(item,pred) == - item is ['SIGNATURE,op,sig,:.] => $oplist := [[opOf op,sig,:pred],:$oplist] - --note: opOf is needed!!! Bug in compiler puts in (One) and (Zero) - item is ['ATTRIBUTE,attr] => - constructor? opOf attr => - $conslist := [[attr,:pred],:$conslist] - nil - opOf attr = 'nothing => 'skip - $attrlist := [[opOf attr,IFCDR attr,:pred],:$attrlist] - item is ['TYPE,op,type] => - $oplist := [[op,[type],:pred],:$oplist] - item is ['IF,pred1,s1,s2] => - build(s1,quickAnd(pred,pred1)) - s2 => build(s2,quickAnd(pred,['NOT,pred1])) - item is ['PROGN,:r] => for x in r repeat build(x,pred) - item in '(noBranch) => 'ok - null item => 'ok - systemError '"build error" - exportsOf(target) == - target is ['CATEGORY,.,:r] => r - target is ['Join,:r,f] => - for x in r repeat $conslist := [[x,:true],:$conslist] - exportsOf f - $conslist := [[target,:true],:$conslist] - nil - ---------------------> NEW DEFINITION (override in patches.lisp.pamphlet) -compressHashTable ht == --- compresses hash table ht, to give maximal sharing of cells - sayBrightlyNT '"compressing hash table..." - $found: local := MAKE_-HASHTABLE 'UEQUAL - for x in HKEYS ht repeat compressSexpr(HGET(ht,x),nil,nil) - sayBrightly "done" - ht - -compressSexpr(x,left,right) == --- recursive version of compressHashTable - atom x => nil - u:= HGET($found,x) => - left => RPLACA(left,u) - right => RPLACD(right,u) - nil - compressSexpr(first x,x,nil) - compressSexpr(rest x,nil,x) - HPUT($found,x,x) - -squeezeList(l) == --- changes the list l, so that is has maximal sharing of cells - $found:local:= NIL - squeeze1 l - -squeeze1(l) == --- recursive version of squeezeList - x:= CAR l - y:= - atom x => x - z:= member(x,$found) => CAR z - $found:= CONS(x,$found) - squeeze1 x - RPLACA(l,y) - x:= CDR l - y:= - atom x => x - z:= member(x,$found) => CAR z - $found:= CONS(x,$found) - squeeze1 x - RPLACD(l,y) - -updateCategoryTable(cname,kind) == - $newcompMode = true => nil - $updateCatTableIfTrue => - kind = 'package => nil - kind = 'category => updateCategoryTableForCategory(cname) - updateCategoryTableForDomain(cname,getConstrCat( - GETDATABASE(cname,'CONSTRUCTORCATEGORY))) ---+ - kind = 'domain and $NRTflag = true => - updateCategoryTableForDomain(cname,getConstrCat( - GETDATABASE(cname,'CONSTRUCTORCATEGORY))) - -updateCategoryTableForCategory(cname) == - clearTempCategoryTable([[cname,'category]]) - addToCategoryTable(cname) - for id in HKEYS _*ANCESTORS_-HASH_* repeat - for (u:=[.,:b]) in GETDATABASE(id,'ANCESTORS) repeat - RPLACD(u,simpCatPredicate simpBool b) - -updateCategoryTableForDomain(cname,category) == - clearCategoryTable(cname) - [cname,:domainEntry]:= addDomainToTable(cname,category) - for [a,:b] in encodeCategoryAlist(cname,domainEntry) repeat - HPUT(_*HASCATEGORY_-HASH_*,[cname,:a],b) - $doNotCompressHashTableIfTrue = true => _*HASCATEGORY_-HASH_* - compressHashTable _*HASCATEGORY_-HASH_* - -clearCategoryTable($cname) == - MAPHASH('clearCategoryTable1,_*HASCATEGORY_-HASH_*) - -clearCategoryTable1(key,val) == - (CAR key=$cname)=> HREM(_*HASCATEGORY_-HASH_*,key) - nil - -clearTempCategoryTable(catNames) == - for key in HKEYS(_*ANCESTORS_-HASH_*) repeat - MEMQ(key,catNames) => nil - extensions:= nil - for (extension:= [catForm,:.]) in GETDATABASE(key,'ANCESTORS) - repeat - MEMQ(CAR catForm,catNames) => nil - extensions:= [extension,:extensions] - HPUT(_*ANCESTORS_-HASH_*,key,extensions) - - - - - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} -- cgit v1.2.3