-- Copyright (C) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2011, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are -- met: -- -- - Redistributions of source code must retain the above copyright -- notice, this list of conditions and the following disclaimer. -- -- - Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in -- the documentation and/or other materials provided with the -- distribution. -- -- - Neither the name of The Numerical Algorithms Group Ltd. nor the -- names of its contributors may be used to endorse or promote products -- derived from this software without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. import simpbool import c_-util namespace BOOT module cattable where hasCat: (%Instantiation,%Instantiation) -> %Code hasCat(dom,cat) == cat.op is "Type" -- every domain is a Type or constructorHasCategoryFromDB [dom.op,:cat.op] showCategoryTable con == [[b,:val] for [[a,:b],:val] in entries _*HASCATEGORY_-HASH_* | symbolEq?(a,con) and val ~= nil] displayCategoryTable(:options) == conList := IFCAR options SETQ($ct,hashTable 'EQ) for [[a,:b],:val] in entries _*HASCATEGORY_-HASH_* repeat tableValue($ct,a) := [[b,:val],:tableValue($ct,a)] for [id,:val] in entries $ct | null conList or symbolMember?(id,conList) repeat sayMSG [:bright id,'"extends:"] PRINT val genCategoryTable() == SETQ(_*ANCESTORS_-HASH_*, hashTable 'EQ) SETQ(_*HASCATEGORY_-HASH_*,hashTable 'EQUAL) genTempCategoryTable() domainTable := [addDomainToTable(con,getConstrCat getConstructorCategory con) for con in allConstructors() | not builtinFunctorName? con and getConstructorKindFromDB con is "domain"] -- $nonLisplibDomains, $noCategoryDomains are set in BUILDOM BOOT specialDs := setDifference($nonLisplibDomains,$noCategoryDomains) domainTable:= [:[addDomainToTable(id, getConstrCat eval([id]).3) for id in specialDs | id ~= 'Cross], :domainTable] for [id,:entry] in domainTable repeat for [a,:b] in encodeCategoryAlist(id,entry) repeat tableValue(_*HASCATEGORY_-HASH_*,[id,:a]) := b simpTempCategoryTable() -- compressHashTable _*ANCESTORS_-HASH_* simpCategoryTable() -- compressHashTable _*HASCATEGORY_-HASH_* simpTempCategoryTable() == for [id,:.] in entries _*ANCESTORS_-HASH_* repeat for (u:=[a,:b]) in getConstructorAncestorsFromDB id repeat u.rest := simpHasPred b simpCategoryTable() == main where main() == for [key,:entry] in entries _*HASCATEGORY_-HASH_* repeat null entry => tableRemove!(_*HASCATEGORY_-HASH_*,key) change := opOf entry isnt [.,:.] => simpHasPred entry [[x,:npred] for [x,:pred] in entry | npred := simpHasPred pred] tableValue(_*HASCATEGORY_-HASH_*,key) := change simpHasPred(pred,:options) == main where main() == $hasArgs: local := IFCDR IFCAR options simp pred simp pred == pred is [op,:r] => op is "has" => simpHas(pred,first r,second r) op is 'HasCategory => simp ["has",first r,simpDevaluate second r] op is 'HasSignature => [op,sig] := simpDevaluate second r ["has",first r,['SIGNATURE,op,sig]] op is 'HasAttribute => form := ["has",a := first r,['ATTRIBUTE,b := simpDevaluate second r]] simpHasAttribute(form,a,b) op in '(AND OR NOT) => null (u := MKPF([simp p for p in r],op)) => nil u is '%true or u is '(QUOTE T) => true simpBool u op is 'hasArgs => ($hasArgs => $hasArgs = r; pred) null r and opOf op = "has" => simp first pred pred is '%true or pred is '(QUOTE T) => true op1 := symbolTarget(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 substitute('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) ident? a or hasIdent b => pred npred := evalHas pred ident? npred or null hasIdent npred => npred pred evalHas (pred := ["has",d,cat]) == x := hasCat(d,cat) y := rest 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 ident? conform => pred [conname,:args] := conform n := #sig u := symbolTarget(op,getConstructorOperationsFromDB conname) 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 ident? conform => pred conname := conform.op getConstructorKindFromDB conname is "category" => simpCatHasAttribute(conform,attr) 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(conform.args, getConstructorPredicates conname) simpHasPred predvec.(k - 1) simpCatHasAttribute(domform,attr) == conform := getConstructorForm opOf domform catval := eval mkEvalable conform if KDR attr isnt [.,:.] then attr := IFCAR attr pred := u := LASSOC(attr,catval . 2) => first u return false --exit: not there pred = true => true eval applySubst(pairList(conform.args,domform.args),pred) hasIdent pred == pred is [op,:r] => op is 'QUOTE => false or/[hasIdent x for x in r] pred is '_$ => false ident? 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) == tableValue(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 getConstructorKindFromDB con is "category" => addToCategoryTable con for [id,:item] in entries _*ANCESTORS_-HASH_* repeat for (u:=[.,:b]) in item repeat u.rest := simpCatPredicate simpBool b tableValue(_*ANCESTORS_-HASH_*,id) := listSort(function GLESSEQP,item) addToCategoryTable con == -- adds an entry to $tempCategoryTable with key=con and alist entries u := getConstructorModemap(con).mmDC --domain alist := getCategoryExtensionAlist u tableValue(_*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 => u.rest := encodeUnion(id,first newEntry,rest u) if newEntry ~= rest u then p:= moreGeneralCategoryPredicate(id,newEntry,rest u) => u.rest := p sayMSG '"Duplicate entries:" PRINT [newEntry,rest u] newAl:= [[key,:newEntry],:newAl] newAl encodeUnion(id,new:=[a,:b],alist) == u := assoc(a,alist) => u.rest := moreGeneralCategoryPredicate(id,b,rest u) alist [new,:alist] moreGeneralCategoryPredicate(id,new,old) == old is 'T or new is '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 getConstructorAncestorsFromDB first b] getCategoryExtensionAlist0 cform == [[cform,:'T],:getCategoryExtensionAlist cform] getCategoryExtensionAlist cform == --avoids substitution as much as possible u:= getConstructorAncestorsFromDB first cform => formalSubstitute(cform,u) mkCategoryExtensionAlist cform formalSubstitute(form:=[.,:argl],u) == isFormalArgumentList argl => u applySubst(pairList($FormalMapVariableList,argl),u) isFormalArgumentList argl == and/[x=fa for x in argl for fa in $FormalMapVariableList] mkCategoryExtensionAlist cform == not cons? cform => nil cop := first cform builtinCategoryName? cop => mkCategoryExtensionAlistBasic cform catlist := formalSubstitute(cform, first getConstructorExports(cform, true)) extendsList:= nil for [cat,:pred] in catlist repeat newList := getCategoryExtensionAlist0 cat finalList := pred is '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 categoryPrincipals category] for [cat,pred,:.] in categoryAncestors category repeat newList := getCategoryExtensionAlist0 cat finalList := pred is '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 u.rest := 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:= getConstructorAncestorsFromDB op) 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:= [y,:cats] cats:= reverse! 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 cons? z3 and constructor? first z3 then cats:= [['IF,quickAnd(["has",z1,z2], thePred),z3,'%noBranch],:cats] at is ['IF, pred, :.] => cats := makeCatPred(at, cats, curPred) cats getConstructorExports(conform,:options) == categoryParts(conform, getConstructorCategory opOf conform,IFCAR options) categoryParts(conform,category,:options) == main where main() == addCtor? := 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 addCtor? then res := [listSort(function GLESSEQP,$conslist),:res] if getConstructorKindFromDB conname is "category" then tvl := take(#rest conform,$TriangleVariableList) res := applySubst(pairList(tvl,$FormalMapVariableList),res) res build(item,pred) == item is ['SIGNATURE,op,sig,:.] => $oplist := [[op,sig,:pred],:$oplist] item is ['ATTRIBUTE,attr] => constructor? opOf attr => $conslist := [[attr,:pred],:$conslist] nil opOf attr is '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])) null item => 'ok item is "%noBranch" => 'ok item is ['PROGN,:r] => for x in r repeat build(x,pred) 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 := hashTable 'EQUAL for [x,:y] in entries ht repeat compressSexpr(y,nil,nil) sayBrightly "done" ht compressSexpr(x,left,right) == -- recursive version of compressHashTable x isnt [.,:.] => nil u:= tableValue($found,x) => left => left.first := u right => right.rest := u nil compressSexpr(first x,x,nil) compressSexpr(rest x,nil,x) tableValue($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:= first l y:= x isnt [.,:.] => x z:= member(x,$found) => first z $found:= [x,:$found] squeeze1 x l.first := y x:= rest l y:= x isnt [.,:.] => x z:= member(x,$found) => first z $found:= [x,:$found] squeeze1 x l.rest := y updateCategoryTable(cname,kind) == $updateCatTableIfTrue => kind is 'package => nil kind is 'category => updateCategoryTableForCategory(cname) updateCategoryTableForDomain(cname,getConstrCat( getConstructorCategory cname)) kind is 'domain => updateCategoryTableForDomain(cname,getConstrCat( getConstructorCategory cname)) updateCategoryTableForCategory(cname) == clearTempCategoryTable([[cname,'category]]) addToCategoryTable(cname) for [id,:.] in entries _*ANCESTORS_-HASH_* repeat for (u:=[.,:b]) in getConstructorAncestorsFromDB id repeat u.rest := simpCatPredicate simpBool b updateCategoryTableForDomain(cname,category) == clearCategoryTable(cname) [cname,:domainEntry]:= addDomainToTable(cname,category) for [a,:b] in encodeCategoryAlist(cname,domainEntry) repeat tableValue(_*HASCATEGORY_-HASH_*,[cname,:a]) := b $doNotCompressHashTableIfTrue => _*HASCATEGORY_-HASH_* -- compressHashTable _*HASCATEGORY_-HASH_* clearCategoryTable($cname) == MAPHASH('clearCategoryTable1,_*HASCATEGORY_-HASH_*) clearCategoryTable1(key,val) == (first key=$cname)=> tableRemove!(_*HASCATEGORY_-HASH_*,key) nil clearTempCategoryTable(catNames) == for [key,:.] in entries _*ANCESTORS_-HASH_* repeat symbolMember?(key,catNames) => nil extensions:= nil for (extension:= [catForm,:.]) in getConstructorAncestorsFromDB key repeat symbolMember?(first catForm,catNames) => nil extensions:= [extension,:extensions] tableValue(_*ANCESTORS_-HASH_*,key) := extensions