1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. 2-- All rights reserved. 3-- 4-- Redistribution and use in source and binary forms, with or without 5-- modification, are permitted provided that the following conditions are 6-- met: 7-- 8-- - Redistributions of source code must retain the above copyright 9-- notice, this list of conditions and the following disclaimer. 10-- 11-- - Redistributions in binary form must reproduce the above copyright 12-- notice, this list of conditions and the following disclaimer in 13-- the documentation and/or other materials provided with the 14-- distribution. 15-- 16-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the 17-- names of its contributors may be used to endorse or promote products 18-- derived from this software without specific prior written permission. 19-- 20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER 24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 32)package "BOOT" 33 34DEFVAR($has_category_hash, nil) 35DEFVAR($ancestor_hash, nil) 36 37compressHashTable(ht) == ht 38 39hasCat(domainOrCatName,catName) == 40 catName='Type -- every domain is a Type 41 or GETDATABASE([domainOrCatName,:catName],'HASCATEGORY) 42 43showCategoryTable con == 44 [[b,:val] for (key :=[a,:b]) in HKEYS $has_category_hash 45 | a = con and (val := HGET($has_category_hash, key))] 46 47displayCategoryTable(:options) == 48 conList := IFCAR options 49 ct := MAKE_HASHTABLE('ID) 50 for (key := [a, :b]) in HKEYS $has_category_hash repeat 51 HPUT(ct, a, [[b, :HGET($has_category_hash, key)], :HGET(ct, a)]) 52 for id in HKEYS ct | null conList or MEMQ(id,conList) repeat 53 sayMSG [:bright id, '"extends:"] 54 PRINT HGET(ct, id) 55 56genCategoryTable() == 57 $ancestors_hash := MAKE_HASHTABLE('ID) 58 $has_category_hash := MAKE_HASHTABLE('UEQUAL) 59 genTempCategoryTable() 60 domainList:= 61 [con for con in allConstructors() 62 | GETDATABASE(con,'CONSTRUCTORKIND) = 'domain] 63 domainTable:= [addDomainToTable(con,getConstrCat catl) for con 64 in domainList | catl := GETDATABASE(con,'CONSTRUCTORCATEGORY)] 65 -- $nonLisplibDomains, $noCategoryDomains are set in BUILDOM BOOT 66 specialDs := SETDIFFERENCE($nonLisplibDomains,$noCategoryDomains) 67 domainTable:= [:[addDomainToTable(id, getConstrCat (eval [id]).3) 68 for id in specialDs], :domainTable] 69 for [id,:entry] in domainTable repeat 70 for [a,:b] in encodeCategoryAlist(id,entry) repeat 71 HPUT($has_category_hash, [id, :a], b) 72 simpTempCategoryTable() 73 compressHashTable $ancestors_hash 74 simpCategoryTable() 75 compressHashTable $has_category_hash 76 77simpTempCategoryTable() == 78 for id in HKEYS $ancestors_hash repeat 79 for (u:=[a,:b]) in GETDATABASE(id,'ANCESTORS) repeat 80 RPLACD(u,simpHasPred b) 81 82simpCategoryTable() == main where 83 main == 84 for key in HKEYS $has_category_hash repeat 85 entry := HGET($has_category_hash, key) 86 null entry => HREM($has_category_hash, key) 87 change := 88 atom opOf entry => simpHasPred entry 89 [[x,:npred] for [x,:pred] in entry | npred := simpHasPred pred] 90 HPUT($has_category_hash, key, change) 91 92simpHasPred(pred) == simpHasPred2(pred, []) 93 94simpHasPred2(pred, options) == main where 95 main == 96 $hasArgs: local := IFCDR IFCAR options 97 simp pred 98 simp pred == 99 pred is [op,:r] => 100 op = 'has => simpHas(pred,first r,first rest r) 101 op = 'HasCategory => simp ['has, first r, simpDevaluate CADR r] 102 op = 'HasSignature => 103 [op,sig] := simpDevaluate CADR r 104 ['has, first r, ['SIGNATURE, op, sig]] 105 op = 'HasAttribute => BREAK() 106 MEMQ(op,'(AND OR NOT)) => 107 null (u := MKPF([simp p for p in r],op)) => nil 108 u is '(QUOTE T) => true 109 simpBool u 110 op = 'hasArgs => ($hasArgs => $hasArgs = r; pred) 111 null r and opOf op = 'has => simp first pred 112 pred is '(QUOTE T) => true 113 op1 := LASSOC(op,'((and . AND)(or . OR)(not . NOT))) => simp [op1,:r] 114 pred in '(T etc) => pred 115 null pred => nil 116 pred 117 simpDevaluate a == EVAL SUBST('QUOTE,'devaluate,a) 118 simpHas(pred,a,b) == 119 b is ['ATTRIBUTE,attr] => BREAK() 120 b is ['SIGNATURE,op,sig] => simpHasSignature(pred,a,op,sig) 121 STRINGP(a) => pred 122 IDENTP a or hasIdent b => pred 123 npred := eval pred 124 IDENTP npred or null hasIdent npred => npred 125 pred 126 eval (pred := ['has,d,cat]) == 127 x := hasCat(first d, first cat) 128 y := rest cat => 129 npred := or/[p for [args,:p] in x | y = args] => simp npred 130 false --if not there, it is false 131 x 132 133simpHasSignature(pred,conform,op,sig) == --eval w/o loading 134 IDENTP conform => pred 135 [conname,:args] := conform 136 n := #sig 137 u := LASSOC(op,GETDATABASE(conname,'OPERATIONALIST)) 138 candidates := [x for (x := [sig1,:.]) in u | #sig1 = #sig] or return false 139 match := or/[x for (x := [sig1,:.]) in candidates 140 | sig = sublisFormal(args,sig1)] or return false 141 simpHasPred(match is [sig,., p, :.] and sublisFormal(args,p) or true) 142 143hasIdent pred == 144 pred is [op,:r] => 145 op = 'QUOTE => false 146 or/[hasIdent x for x in r] 147 pred = '_$ => false 148 IDENTP pred => true 149 false 150 151addDomainToTable(id,catl) == 152 alist:= nil 153 for cat in catl repeat 154 cat is ['CATEGORY,:.] => nil 155 cat is ['IF,pred,cat1,:.] => 156 newAlist:= 157 [[a,:quickAnd(pred,b)] for [a,:b] in getCategoryExtensionAlist0 cat1] 158 alist:= [:alist,:newAlist] 159 alist:= [:alist,:getCategoryExtensionAlist0 cat] 160 [id,:alist] 161 162genTempCategoryTable() == 163 --generates hashtable with key=categoryName and value of the form 164 -- ((form . pred) ..) meaning that 165 -- "IF pred THEN ofCategory(key,form)" 166 -- where form can involve #1, #2, ... the parameters of key 167 for con in allConstructors() repeat 168 GETDATABASE(con,'CONSTRUCTORKIND) = 'category => 169 addToCategoryTable con 170 for id in HKEYS $ancestors_hash repeat 171 item := HGET($ancestors_hash, id) 172 for (u:=[.,:b]) in item repeat 173 RPLACD(u,simpCatPredicate simpBool b) 174 HPUT($ancestors_hash, id, listSort(function GLESSEQP, item)) 175 176addToCategoryTable con == 177 u := CAAR GETDATABASE(con,'CONSTRUCTORMODEMAP) --domain 178 alist := getCategoryExtensionAlist u 179 HPUT($ancestors_hash, first u, alist) 180 alist 181 182encodeCategoryAlist(id,alist) == 183 newAl:= nil 184 for [a,:b] in alist repeat 185 [key,:argl] := a 186 newEntry:= 187 argl => [[argl,:b]] 188 b 189 u:= assoc(key,newAl) => 190 argl => RPLACD(u,encodeUnion(id,first newEntry,rest u)) 191 if newEntry ~= rest u then 192 p:= moreGeneralCategoryPredicate(id,newEntry,rest u) => RPLACD(u,p) 193 sayMSG '"Duplicate entries:" 194 PRINT [newEntry,rest u] 195 newAl:= [[key,:newEntry],:newAl] 196 newAl 197 198encodeUnion(id,new:=[a,:b],alist) == 199 u := assoc(a,alist) => 200 RPLACD(u,moreGeneralCategoryPredicate(id,b,rest u)) 201 alist 202 [new,:alist] 203 204moreGeneralCategoryPredicate(id,new,old) == 205 old = 'T or new = 'T => 'T 206 old is ['has,a,b] and new is ['has,=a,c] => 207 tempExtendsCat(b,c) => new 208 tempExtendsCat(c,b) => old 209 ['OR,old,new] 210 mkCategoryOr(new,old) 211 212mkCategoryOr(new,old) == 213 old is ['OR,:l] => simpCategoryOr(new,l) 214 ['OR,old,new] 215 216simpCategoryOr(new,l) == 217 newExtendsAnOld:= false 218 anOldExtendsNew:= false 219 ['has,a,b] := new 220 newList:= nil 221 for pred in l repeat 222 pred is ['has,=a,c] => 223 tempExtendsCat(c,b) => anOldExtendsNew:= true 224 if tempExtendsCat(b,c) then newExtendsAnOld:= true 225 newList:= [pred,:newList] 226 newList:= [pred,:newList] 227 if not newExtendsAnOld then newList:= [new,:newList] 228 newList is [.] => first newList 229 ['OR,:newList] 230 231tempExtendsCat(b,c) == 232 or/[first c = a for [[a,:.],:.] in GETDATABASE(first b,'ANCESTORS)] 233 234getCategoryExtensionAlist0 cform == 235 [[cform,:'T],:getCategoryExtensionAlist cform] 236 237getCategoryExtensionAlist cform == 238 --avoids substitution as much as possible 239 u:= GETDATABASE(first cform,'ANCESTORS) => formalSubstitute(cform,u) 240 mkCategoryExtensionAlist cform 241 242formalSubstitute(form:=[.,:argl],u) == 243 isFormalArgumentList argl => u 244 EQSUBSTLIST(argl,$FormalMapVariableList,u) 245 246isFormalArgumentList argl == 247 and/[x=fa for x in argl for fa in $FormalMapVariableList] 248 249mkCategoryExtensionAlist cform == 250 not CONSP cform => nil 251 cop := first cform 252 MEMQ(cop, $CategoryNames) => mkCategoryExtensionAlistBasic cform 253 catlist := formalSubstitute(cform, first getConstructorExports(cform, true)) 254 extendsList:= nil 255 for [cat,:pred] in catlist repeat 256 newList := getCategoryExtensionAlist0 cat 257 finalList := 258 pred = 'T => newList 259 [[a,:quickAnd(b,pred)] for [a,:b] in newList] 260 extendsList:= catPairUnion(extendsList,finalList,cop,cat) 261 extendsList 262 263-- following code to handle Unions Records Mapping etc. 264mkCategoryExtensionAlistBasic cform == 265 cop := first cform 266--category:= eval cform 267 category := -- changed by RSS on 7/29/87 268 macrop cop => eval cform 269 APPLY(cop, rest cform) 270 extendsList:= [[x,:'T] for x in category.4.0] 271 for [cat,pred,:.] in category.4.1 repeat 272 newList := getCategoryExtensionAlist0 cat 273 finalList := 274 pred = 'T => newList 275 [[a,:quickAnd(b,pred)] for [a,:b] in newList] 276 extendsList:= catPairUnion(extendsList,finalList,cop,cat) 277 extendsList 278 279catPairUnion(oldList,newList,op,cat) == 280 for pair in newList repeat 281 u:= assoc(first pair,oldList) => 282 rest u = rest pair => nil 283 RPLACD(u,addConflict(rest pair,rest u)) where addConflict(new,old) == 284 quickOr(new,old) 285 oldList:= [pair,:oldList] 286 oldList 287 288simpCatPredicate p == 289 p is ['OR,:l] => 290 (u:= simpOrUnion l) is [p] => p 291 ['OR,:u] 292 p 293 294simpOrUnion l == 295 if l then simpOrUnion1(first l,simpOrUnion rest l) 296 else l 297 298simpOrUnion1(x,l) == 299 null l => [x] 300 p:= mergeOr(x,first l) => [p,:rest l] 301 [first l,:simpOrUnion1(x,rest l)] 302 303mergeOr(x,y) == 304 x is ['has,a,b] and y is ['has,=a,c] => 305 testExtend(b,c) => y 306 testExtend(c,b) => x 307 nil 308 nil 309 310testExtend(a:=[op,:argl],b) == 311 (u:= GETDATABASE(op,'ANCESTORS)) and (val:= LASSOC(b,u)) => 312 formalSubstitute(a,val) 313 nil 314 315getConstrCat(x) == 316-- gets a different representation of the constructorCategory from the 317-- lisplib, which is a list of named categories or conditions 318 x:= if x is ['Join,:y] then y else [x] 319 cats:= NIL 320 for y in x repeat 321 y is ['CATEGORY,.,:z] => 322 for zz in z repeat cats := makeCatPred(zz, cats, true) 323 cats:= CONS(y,cats) 324 cats:= nreverse cats 325 cats 326 327 328makeCatPred(zz, cats, thePred) == 329 if zz is ['IF,curPred := ['has,z1,z2],ats,.] then 330 ats := if ats is ['PROGN,:atl] then atl else [ats] 331 for at in ats repeat 332-- at is ['ATTRIBUTE,z3] => 333-- BREAK() 334 if at is ['ATTRIBUTE,z3] and not atom z3 and 335 constructor? first z3 then 336 cats:= CONS(['IF,quickAnd(['has,z1,z2], thePred),z3,'noBranch],cats) 337 at is ['IF, pred, :.] => 338 cats := makeCatPred(at, cats, curPred) 339 cats 340 341getConstructorExports(conform, do_constr) == categoryParts(conform, 342 GETDATABASE(opOf conform, 'CONSTRUCTORCATEGORY), do_constr) 343 344DEFVAR($oplist) 345DEFVAR($conslist) 346 347categoryParts(conform, category, do_constr) == 348 kind := GETDATABASE(opOf(conform), 'CONSTRUCTORKIND) 349 categoryParts1(kind, conform, category, do_constr) 350 351categoryParts1(kind, conform, category, do_constr) == main where 352 main == 353 $oplist : local := nil 354 $conslist: local := nil 355 for x in exportsOf(category) repeat build(x,true) 356 $oplist := listSort(function GLESSEQP,$oplist) 357 res := 358 do_constr => listSort(function GLESSEQP, $conslist) 359 [] 360 res := [res, :$oplist] 361 if kind = 'category then 362 tvl := TAKE(#rest conform,$TriangleVariableList) 363 res := SUBLISLIS($FormalMapVariableList,tvl,res) 364 res 365 build(item,pred) == 366 item is ['SIGNATURE,op,sig,:.] => $oplist := [[opOf op,sig,:pred],:$oplist] 367 --note: opOf is needed!!! Bug in compiler puts in (One) and (Zero) 368 item is ['ATTRIBUTE, attr] => 369 constructor? opOf attr => 370 $conslist := [[attr,:pred],:$conslist] 371 nil 372 BREAK() 373 item is ['TYPE,op,type] => 374 BREAK() 375 $oplist := [[op,[type],:pred],:$oplist] 376 item is ['IF,pred1,s1,s2] => 377 build(s1,quickAnd(pred,pred1)) 378 s2 => build(s2,quickAnd(pred,['NOT,pred1])) 379 item is ['PROGN,:r] => for x in r repeat build(x,pred) 380 item is ['CATEGORY, ., :l] => for x in l repeat build(x, pred) 381 item in '(noBranch) => 'ok 382 null item => 'ok 383 systemError '"build error" 384 exportsOf(target) == 385 target is ['CATEGORY,.,:r] => r 386 target is ['Join,:r,f] => 387 for x in r repeat $conslist := [[x,:true],:$conslist] 388 exportsOf f 389 $conslist := [[target,:true],:$conslist] 390 nil 391 392updateCategoryTable(cname,kind) == 393 kind = 'domain => 394 updateCategoryTableForDomain(cname,getConstrCat( 395 GETDATABASE(cname,'CONSTRUCTORCATEGORY))) 396 397updateCategoryTableForDomain(cname,category) == 398 clearCategoryTable(cname) 399 [cname,:domainEntry]:= addDomainToTable(cname,category) 400 for [a,:b] in encodeCategoryAlist(cname,domainEntry) repeat 401 HPUT($has_category_hash, [cname, :a], b) 402 $doNotCompressHashTableIfTrue = true => $has_category_hash 403 compressHashTable $has_category_hash 404 405clearCategoryTable($cname) == 406 MAPHASH('clearCategoryTable1, $has_category_hash) 407 408clearCategoryTable1(key,val) == 409 (first key = $cname) => HREM($has_category_hash, key) 410 nil 411 412clearTempCategoryTable(catNames) == 413 for key in HKEYS($ancestors_hash) repeat 414 MEMQ(key,catNames) => nil 415 extensions:= nil 416 for (extension:= [catForm,:.]) in GETDATABASE(key,'ANCESTORS) 417 repeat 418 MEMQ(first catForm, catNames) => nil 419 extensions:= [extension,:extensions] 420 HPUT($ancestors_hash, key, extensions) 421