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 34--======================================================================= 35-- Generate Code to Create Infovec 36--======================================================================= 37getInfovecCode(NRTslot1Info, et) == 38--Function called by compDefineFunctor1 to create infovec at compile time 39 ['LIST, 40 MKQ makeDomainTemplate $template, 41 MKQ makeCompactDirect(NRTslot1Info, et), 42 MKQ [], 43 NRTmakeCategoryAlist(et), 44 MKQ $lookupFunction] 45 46--======================================================================= 47-- Generation of Domain Vector Template (Compile Time) 48--======================================================================= 49makeDomainTemplate vec == 50--NOTES: This function is called at compile time to create the template 51-- (slot 0 of the infovec); called by getInfovecCode from compDefineFunctor1 52 newVec := GETREFV SIZE vec 53 for index in 0..MAXINDEX vec repeat 54 item := vec.index 55 null item => nil 56 newVec.index := 57 atom item => item 58 null atom first item => makeGoGetSlot(item,index) 59 item 60 $byteVec := "append"/NREVERSE $byteVec 61 newVec 62 63makeGoGetSlot(item,index) == 64--NOTES: creates byte vec strings for LATCH slots 65--these parts of the $byteVec are created first; see also makeCompactDirect 66 [sig,whereToGo,op,:flag] := item 67 n := #sig - 1 68 newcode := [n,whereToGo,:makeCompactSigCode(sig),index] 69 $byteVec := [newcode,:$byteVec] 70 curAddress := $byteAddress 71 $byteAddress := $byteAddress + n + 4 72 [curAddress,:op] 73 74--======================================================================= 75-- Generate OpTable at Compile Time 76--======================================================================= 77--> called by getInfovecCode (see top of this file) from compDefineFunctor1 78makeCompactDirect(u, et) == 79 $predListLength :local := LENGTH $NRTslot1PredicateList 80 $byteVecAcc: local := nil 81 [nam,[addForm,:opList]] := u 82 --pp opList 83 d := [[op, y] for [op, :items] in opList 84 | y := makeCompactDirect1(op, items, et)] 85 $byteVec := [:$byteVec,:"append"/NREVERSE $byteVecAcc] 86 LIST2VEC ("append"/d) 87 88makeCompactDirect1(op, items, et) == 89--NOTES: creates byte codes for ops implemented by the domain 90 curAddress := $byteAddress 91 newcodes := 92 "append"/[u for y in orderBySubsumption items 93 | u := fn(y, et)] or return nil 94 $byteVecAcc := [newcodes,:$byteVecAcc] 95 curAddress 96 where fn(y, et) == 97 [sig,:r] := y 98 if r is [n,:s] then 99 slot := 100 n is [p, :.] => p --the rest is linenumber of function definition 101 n 102 predCode := 103 s is [pred, :.] => predicateBitIndex(pred, et) 104 0 105 --> drop items which are not present (predCode = -1) 106 predCode = -1 => return nil 107 --> drop items with NIL slots if lookup function is incomplete 108 if null slot then 109 $lookupFunction = 'lookupIncomplete => return nil 110 slot := 1 --signals that operation is not present 111 n := #sig - 1 112 $byteAddress := $byteAddress + n + 4 113 res := [n,predCode,:makeCompactSigCode(sig),slot] 114 res 115 116orderBySubsumption items == reverse(items) 117 118makeCompactSigCode(sig) == [fn for x in sig] where 119 fn == 120 x = '_$_$ => 2 121 x = '$ => 0 122 NULL INTEGERP x => systemError ['"code vector slot is ",x,"; must be number"] 123 x 124 125--======================================================================= 126-- Instantiation Code (Stuffslots) 127--======================================================================= 128stuffDomainSlots dollar == 129 domname := devaluate dollar 130 infovec := GET(opOf domname, 'infovec) 131 lookupFunction := getLookupFun infovec 132 lookupFunction := 133 lookupFunction = 'lookupIncomplete => function lookupIncomplete 134 function lookupComplete 135 template := infovec.0 136 if template.5 then stuffSlot(dollar,5,template.5) 137 for i in (6 + # rest domname)..MAXINDEX template | item := template.i repeat 138 stuffSlot(dollar,i,item) 139 dollar.1 := LIST(lookupFunction,dollar,infovec.1) 140 dollar.2 := infovec.2 141 proto4 := infovec.3 142 dollar.4 := 143 VECP CDDR proto4 => BREAK() 144 bitVector := dollar.3 145 predvec := first proto4 146 packagevec := CADR proto4 147 auxvec := LIST2VEC [fn for i in 0..MAXINDEX predvec] where fn == 148 null testBitVector(bitVector,predvec.i) => nil 149 packagevec.i or 'T 150 [auxvec,:CDDR proto4] 151 152getLookupFun infovec == 153 MAXINDEX infovec = 4 => infovec.4 154 'lookupIncomplete 155 156stuffSlot(dollar,i,item) == 157 dollar.i := 158 atom item => [SYMBOL_-FUNCTION item,:dollar] 159 item is [n,:op] and INTEGERP n => [FUNCTION newGoGet,dollar,:item] 160 item is ['CONS,.,['FUNCALL,a,b]] => 161 b = '$ => [FUNCTION makeSpadConstant,eval a,dollar,i] 162 sayBrightlyNT '"Unexpected constant environment!!" 163 pp devaluate b 164 nil 165 item --new form 166 167--======================================================================= 168-- Predicate utilities 169--======================================================================= 170 171predicateBitIndex(x, et) == 172 u := simpBool(transHasCode(x, et)) 173 u = 'T => 0 174 u = nil => -1 175 p := POSN1(u,$NRTslot1PredicateList) => p + 1 176 systemError nil 177 178predicateBitRef(x, et) == 179 x = 'T => 'T 180 ['testBitVector, 'pv_$, predicateBitIndex(x, et)] 181 182makePrefixForm(u,op) == 183 u := MKPF(u,op) 184 u = ''T => 'T 185 u 186--======================================================================= 187-- Generate Slot 3 Predicate Vector 188--======================================================================= 189makePredicateBitVector(pl, et) == --called by buildFunctor 190 if $insideCategoryPackageIfTrue = true then 191 pl := union(pl,$categoryPredicateList) 192 $predGensymAlist := nil 193 for p in removeAttributePredicates pl repeat 194 pred := simpBool(transHasCode(p, et)) 195 atom pred => 'skip --skip over T and NIL 196 if isHasDollarPred pred then 197 lasts := insert(pred,lasts) 198 for q in stripOutNonDollarPreds pred repeat firsts := insert(q,firsts) 199 else 200 firsts := insert(pred,firsts) 201 firstPl := SUBLIS($pairlis,NREVERSE orderByContainment firsts) 202 lastPl := SUBLIS($pairlis,NREVERSE orderByContainment lasts) 203 firstCode:= 204 ['buildPredVector,0,0,mungeAddGensyms(firstPl,$predGensymAlist)] 205 lastCode := augmentPredCode(# firstPl,lastPl) 206 $lisplibPredicates := [:firstPl,:lastPl] --what is stored under 'predicates 207 [$lisplibPredicates,firstCode,:lastCode] --$pairlis set by compDefineFunctor1 208 209augmentPredCode(n,lastPl) == 210 ['LIST,:pl] := mungeAddGensyms(lastPl,$predGensymAlist) 211 delta := 2^n 212 l := [(u := MKPF([x, ['augmentPredVector, '$, delta]], 'AND); 213 delta:=2 * delta; u) for x in pl] 214 215augmentPredVector(dollar,value) == 216 QSETREFV(dollar,3,value + QVELT(dollar,3)) 217 218isHasDollarPred pred == 219 pred is [op,:r] => 220 MEMQ(op,'(AND and OR or NOT not)) => or/[isHasDollarPred x for x in r] 221 op is "HasCategory" => first r = '$ 222 false 223 false 224 225stripOutNonDollarPreds pred == 226 pred is [op,:r] and MEMQ(op,'(AND and OR or NOT not)) => 227 "append"/[stripOutNonDollarPreds x for x in r] 228 not isHasDollarPred pred => [pred] 229 nil 230 231removeAttributePredicates pl == 232 [fn p for p in pl] where 233 fn p == 234 p is [op,:argl] and op in '(AND and OR or NOT not) => 235 makePrefixForm(fnl argl,op) 236 p is ['has,'$,['ATTRIBUTE,a]] => BREAK() 237 p 238 fnl p == [fn x for x in p] 239 240transHasCode(x, et) == 241 atom x => x 242 op := QCAR x 243 op is "HasCategory" => x 244 EQ(op, 'has) => compHasFormat(x, et) 245 [transHasCode(y, et) for y in x] 246 247mungeAddGensyms(u,gal) == 248 ['LIST,:[fn(x,gal,0) for x in u]] where fn(x,gal,n) == 249 atom x => x 250 g := LASSOC(x,gal) => 251 n = 0 => ['LET,g,x] 252 g 253 [first x,:[fn(y,gal,n + 1) for y in rest x]] 254 255orderByContainment pl == 256 null pl or null rest pl => pl 257 max := first pl 258 for x in rest pl repeat 259 if (y := CONTAINED(max,x)) then 260 if null assoc(max,$predGensymAlist) 261 then $predGensymAlist := [[max,:GENSYM()],:$predGensymAlist] 262 else if CONTAINED(x,max) 263 then if null assoc(x,$predGensymAlist) then $predGensymAlist := [[x,:GENSYM()],:$predGensymAlist] 264 if y then max := x 265 [max,:orderByContainment delete(max,pl)] 266 267buildBitTable(:l) == fn(REVERSE l,0) where fn(l,n) == 268 null l => n 269 n := n + n 270 if QCAR l then n := n + 1 271 fn(rest l,n) 272 273buildPredVector(init, n, l) == fn(init, 2^n, l) where fn(acc, n, l) == 274 null l => acc 275 if first l then acc := acc + n 276 fn(acc,n + n,rest l) 277 278testBitVector(vec,i) == 279--bit vector indices are always 1 larger than position in vector 280 EQ(i,0) => true 281 LOGBITP(i - 1,vec) 282 283bitsOf n == 284 n = 0 => 0 285 1 + bitsOf(QUOTIENT(n, 2)) 286 287--======================================================================= 288-- Generate Slot 4 Constructor Vectors 289--======================================================================= 290NRTmakeCategoryAlist(et) == 291 $depthAssocCache : local := MAKE_HASHTABLE('ID) 292 $catAncestorAlist: local := NIL 293 pcAlist := [:[[x,:'T] for x in $uncondAlist],:$condAlist] 294 $levelAlist: local := depthAssocList [CAAR x for x in pcAlist] 295 opcAlist := NREVERSE SORTBY(function NRTcatCompare,pcAlist) 296 newPairlis := [[5 + i,:b] for [.,:b] in $pairlis for i in 1..] 297 slot1 := [[a,:k] for [a,:b] in SUBLIS($pairlis,opcAlist) 298 | (k := predicateBitIndex(b, et)) ~= -1] 299 slot0 := [hasDefaultPackage opOf a for [a,:b] in slot1] 300 sixEtc := [5 + i for i in 1..#$pairlis] 301 formals := ASSOCRIGHT $pairlis 302 for x in slot1 repeat 303 RPLACA(x, EQSUBSTLIST(["$$"], ["$"], first x)) 304 -----------code to make a new style slot4 ----------------- 305 predList := ASSOCRIGHT slot1 --is list of predicate indices 306 maxPredList := "MAX"/predList 307 catformvec := [encodeCatform(x, sixEtc, formals) 308 for x in ASSOCLEFT slot1] 309 maxElement := "MAX"/$byteVec 310 ['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList], 311 ['CONS, MKQ LIST2VEC slot0, 312 ['CONS, MKQ LIST2VEC catformvec, 313 ['makeByteWordVec2,maxElement,MKQ $byteVec]]]] 314 --NOTE: this is new form: old form satisfies VECP CDDR form 315 316encodeCatform(x, inds, formals) == 317 k := NRTassocIndex x => k 318 atom x => 319 res := nil 320 for ind in inds for formal in formals while not(res) repeat 321 if EQ(x, formal) then res := ind 322 res => res 323 SYMBOLP(x) => x 324 ["QUOTE", x] 325 atom rest x => x 326 [first(x), :[encodeCatform(y, inds, formals) for y in rest x]] 327 328NRTcatCompare [catform,:pred] == LASSOC(first catform,$levelAlist) 329 330hasDefaultPackage catname == 331 defname := INTERN STRCONC(catname,'"&") 332 constructor? defname => defname 333--MEMQ(defname,allConstructors()) => defname 334 nil 335 336 337--======================================================================= 338-- Generate Category Level Alist 339--======================================================================= 340 341depthAssocList u == 342 MEMQ('DomainSubstitutionMacro,u) => BREAK() 343 REMDUP ("append"/[depthAssoc(y) for y in u]) 344 345depthAssoc x == 346 y := HGET($depthAssocCache,x) => y 347 x is ['Join,:u] or (u := getCatAncestors x) => 348 v := depthAssocList u 349 HPUT($depthAssocCache,x,[[x,:n],:v]) 350 where n == 1 + "MAX"/[rest y for y in v] 351 HPUT($depthAssocCache,x,[[x,:0]]) 352 353getCatAncestors x == [CAAR y for y in parentsOf opOf x] 354 355--======================================================================= 356-- Display Template 357--======================================================================= 358dc(:r) == 359 con := IFCAR r 360 options := IFCDR r 361 ok := MEMQ(con,allConstructors()) or (con := abbreviation? con) 362 null ok => 363 sayBrightly '"Format is: dc(<constructor name or abbreviation>,option)" 364 sayBrightly 365 '"options are: all (default), slots, preds, cats, data, ops, optable" 366 option := IFCAR options 367 option = 'all or null option => dcAll con 368 option = 'slots => dcSlots con 369 option = 'preds => dcPreds con 370 option = 'cats => dcCats con 371 option = 'data => dcData con 372 option = 'ops => dcOps con 373 option = 'size => dcSize( con,'full) 374 option = 'optable => dcOpTable con 375 376dcSlots con == 377 name := abbreviation? con or con 378 $infovec: local := getInfovec name 379 template := $infovec.0 380 for i in 5..MAXINDEX template repeat 381 sayBrightlyNT bright i 382 item := template.i 383 item is [n,:op] and INTEGERP n => dcOpLatchPrint(op,n) 384 null item and i > 5 => sayBrightly ['"arg ",STRCONC('"#",STRINGIMAGE(i - 5))] 385 atom item => sayBrightly ['"fun ",item] 386 item is ['CONS,.,['FUNCALL,[.,a],b]] => sayBrightly ['"constant ",a] 387 sayBrightly concat('"lazy ",form2String formatSlotDomain i) 388 389dcOpLatchPrint(op,index) == 390 numvec := getCodeVector() 391 numOfArgs := numvec.index 392 whereNumber := numvec.(index := index + 1) 393 signumList := dcSig(numvec,index + 1,numOfArgs) 394 index := index + numOfArgs + 1 395 namePart := concat(bright "from", 396 dollarPercentTran form2String formatSlotDomain whereNumber) 397 sayBrightly ['"latch",:formatOpSignature(op,signumList),:namePart] 398 399getInfovec name == 400 u := GET(name, 'infovec) => u 401 GET(name, 'LOADED) => nil 402 fullLibName := GETDATABASE(name,'OBJECT) or return nil 403 startTimingProcess 'load 404 loadLibNoUpdate(name, name, fullLibName) 405 GET(name, 'infovec) 406 407getOpSegment index == 408 numOfArgs := (vec := getCodeVector()).index 409 [vec.i for i in index..(index + numOfArgs + 3)] 410 411getCodeVector() == 412 proto4 := $infovec.3 413 u := CDDR proto4 414 VECP u => BREAK() 415 rest u --new style 416 417formatSlotDomain x == 418 x = 0 => ["$"] 419 x = 2 => ["$$"] 420 INTEGERP x => 421 val := $infovec.0.x 422 null val => [STRCONC('"#",STRINGIMAGE (x - 5))] 423 formatSlotDomain val 424 atom x => x 425 x is ['NRTEVAL,y] => (atom y => [y]; y) 426 x is ['QUOTE, .] => x 427 [first x,:[formatSlotDomain y for y in rest x]] 428 429--======================================================================= 430-- Display OpTable 431--======================================================================= 432dcOpTable con == 433 name := abbreviation? con or con 434 $infovec: local := getInfovec name 435 template := $infovec.0 436 $predvec: local := GETDATABASE(name, 'PREDICATES) 437 opTable := $infovec.1 438 for i in 0..MAXINDEX opTable repeat 439 op := opTable.i 440 i := i + 1 441 startIndex := opTable.i 442 stopIndex := 443 i + 1 > MAXINDEX opTable => MAXINDEX getCodeVector() 444 opTable.(i + 2) 445 curIndex := startIndex 446 while curIndex < stopIndex repeat 447 curIndex := dcOpPrint(op,curIndex) 448 449dcOpPrint(op,index) == 450 numvec := getCodeVector() 451 segment := getOpSegment index 452 numOfArgs := numvec.index 453 index := index + 1 454 predNumber := numvec.index 455 index := index + 1 456 signumList := dcSig(numvec,index,numOfArgs) 457 index := index + numOfArgs + 1 458 slotNumber := numvec.index 459 suffix := 460 predNumber = 0 => nil 461 [:bright '"if",:pred2English $predvec.(predNumber - 1)] 462 namePart := bright 463 slotNumber = 0 => '"subsumed by next entry" 464 slotNumber = 1 => '"missing" 465 name := $infovec.0.slotNumber 466 atom name => name 467 '"looked up" 468 sayBrightly [:formatOpSignature(op,signumList),:namePart, :suffix] 469 index + 1 470 471dcSig(numvec,index,numOfArgs) == 472 [formatSlotDomain numvec.(index + i) for i in 0..numOfArgs] 473 474dcPreds con == 475 name := abbreviation? con or con 476 $infovec: local := getInfovec name 477 $predvec:= GETDATABASE(name, 'PREDICATES) 478 for i in 0..MAXINDEX $predvec repeat 479 sayBrightlyNT bright (i + 1) 480 sayBrightly pred2English $predvec.i 481 482dcCats con == 483 name := abbreviation? con or con 484 $infovec: local := getInfovec name 485 u := $infovec.3 486 VECP CDDR u => BREAK() 487 $predvec:= GETDATABASE(name, 'PREDICATES) 488 catpredvec := first u 489 catinfo := CADR u 490 catvec := CADDR u 491 for i in 0..MAXINDEX catvec repeat 492 sayBrightlyNT bright i 493 form := catvec.i 494 predNumber := catpredvec.i 495 suffix := 496 predNumber = 0 => nil 497 [:bright '"if",:pred2English $predvec.(predNumber - 1)] 498 extra := 499 null (info := catinfo.i) => nil 500 IDENTP info => bright '"package" 501 bright '"instantiated" 502 sayBrightly concat(form2String formatSlotDomain form,suffix,extra) 503 504dcData con == 505 name := abbreviation? con or con 506 $infovec: local := getInfovec name 507 sayBrightly '"Operation data from slot 1" 508 print_full1 $infovec.1 509 vec := getCodeVector() 510 vec := (PAIRP vec => rest vec; vec) 511 sayBrightly ['"Information vector has ",SIZE vec,'" entries"] 512 dcData1 vec 513 514dcData1 vec == 515 n := MAXINDEX vec 516 tens := n / 10 517 for i in 0..tens repeat 518 start := 10*i 519 sayBrightlyNT rightJustifyString(STRINGIMAGE start,6) 520 sayBrightlyNT '" |" 521 for j in start..MIN(start + 9,n) repeat 522 sayBrightlyNT rightJustifyString(STRINGIMAGE vec.j,6) 523 sayNewLine() 524 vec 525 526dcSize(:options) == 527 con := IFCAR options 528 options := rest options 529 null con => dcSizeAll() 530 quiet := MEMQ('quiet,options) 531 full := MEMQ('full,options) 532 name := abbreviation? con or con 533 infovec := getInfovec name 534 template := infovec.0 535 maxindex := MAXINDEX template 536 latch := 0 --# of go get slots 537 lazy := 0 --# of lazy domain slots 538 fun := 0 --# of function slots 539 lazyNodes := 0 --# of nodes needed for lazy domain slots 540 for i in 5..maxindex repeat 541 atom (item := template.i) => fun := fun + 1 542 INTEGERP first item => latch := latch + 1 543 'T => 544 lazy := lazy + 1 545 lazyNodes := lazyNodes + numberOfNodes item 546 tSize := sum(vectorSize(1 + maxindex),nodeSize(lazyNodes + latch)) 547 -- functions are free in the template vector 548 oSize := vectorSize(SIZE infovec.1) 549 aSize := numberOfNodes infovec.2 550 slot4 := infovec.3 551 catvec := 552 VECP CDDR slot4 => BREAK() 553 CADDR slot4 554 n := MAXINDEX catvec 555 cSize := sum(nodeSize(2), vectorSize(SIZE first slot4), vectorSize(n + 1), 556 nodeSize(+/[numberOfNodes catvec.i for i in 0..n])) 557 codeVector := 558 VECP CDDR slot4 => BREAK() 559 CDDDR slot4 560 vSize := halfWordSize(SIZE codeVector) 561 itotal := sum(tSize,oSize,aSize,cSize,vSize) 562 if null quiet then sayBrightly ['"infovec total = ",itotal,'" BYTES"] 563 if null quiet then 564 lookupFun := getLookupFun infovec 565 suffix := (lookupFun = 'lookupIncomplete => '"incomplete"; '"complete") 566 sayBrightly ['"template = ",tSize] 567 sayBrightly ['"operations = ",oSize,'" (",suffix,'")"] 568 sayBrightly ['"categories = ",cSize] 569 sayBrightly ['"data vector = ",vSize] 570 if null quiet then 571 sayBrightly ['"number of function slots (one extra node) = ",fun] 572 sayBrightly ['"number of latch slots (2 extra nodes) = ",latch] 573 sayBrightly ['"number of lazy slots (no extra nodes) = ",lazy] 574 sayBrightly ['"size of domain vectors = ",1 + maxindex,'" slots"] 575 vtotal := itotal + nodeSize(fun) --fun slot is ($ . function) 576 vtotal := vtotal + nodeSize(2 * latch) --latch slot is (newGoGet $ . code) 577 --NOTE: lazy slots require no cost --lazy slot is lazyDomainForm 578 if null quiet then sayBrightly ['"domain size = ",vtotal,'" BYTES"] 579 etotal := nodeSize(fun + 2 * latch) + vectorSize(1 + maxindex) 580 if null quiet then sayBrightly ['"cost per instantiation = ",etotal,'" BYTES"] 581 vtotal 582 583dcSizeAll() == 584 count := 0 585 total := 0 586 for x in allConstructors() | null atom GET(x, 'infovec) repeat 587 count := count + 1 588 s := dcSize(x,'quiet) 589 sayBrightly [s,'" : ",x] 590 total := total + s 591 sayBrightly '"------------total-------------" 592 sayBrightly [count," constructors; ",total," BYTES"] 593 594sum(:l) == +/l 595 596nodeSize(n) == 12 * n 597 598vectorSize(n) == 4 * (1 + n) 599 600halfWordSize(n) == 601 n < 128 => n / 2 602 n < 256 => n 603 2 * n 604 605numberOfNodes(x) == 606 atom x => 0 607 1 + numberOfNodes first x + numberOfNodes rest x 608 609template con == 610 con := abbreviation? con or con 611 ppTemplate (getInfovec con).0 612 613ppTemplate vec == 614 for i in 0..MAXINDEX vec repeat 615 sayBrightlyNT bright i 616 pp vec.i 617 618infovec con == 619 con := abbreviation? con or con 620 u := getInfovec con 621 sayBrightly '"---------------slot 0 is template-------------------" 622 ppTemplate u.0 623 sayBrightly '"---------------slot 1 is op table-------------------" 624 print_full1 u.1 625 sayBrightly '"---------------slot 3.0 is catpredvec---------------" 626 print_full1 u.3.0 627 sayBrightly '"---------------slot 3.1 is catinfovec---------------" 628 print_full1 u.3.1 629 sayBrightly '"---------------slot 3.2 is catvec-------------------" 630 print_full1 u.3.2 631 sayBrightly '"---------------tail of slot 3 is datavector---------" 632 dcData1 CDDDR u.3 633 'done 634 635dcAll con == 636 con := abbreviation? con or con 637 $infovec : local := getInfovec con 638 complete? := 639 #$infovec = 4 => false 640 $infovec.4 = 'lookupComplete 641 sayBrightly '"----------------Template-----------------" 642 dcSlots con 643 sayBrightly 644 complete? => '"----------Complete Ops----------------" 645 '"----------Incomplete Ops---------------" 646 dcOpTable con 647 sayBrightly '"----------------Preds-----------------" 648 dcPreds con 649 sayBrightly '"----------------Cats-----------------" 650 dcCats con 651 sayBrightly '"----------------Data------------------" 652 dcData con 653 sayBrightly '"----------------Size------------------" 654 dcSize(con,'full) 655 'done 656 657dcOps conname == 658 for [op,:u] in REVERSE getOperationAlistFromLisplib conname repeat 659 for [sig,slot,pred,key,:.] in u repeat 660 suffix := 661 atom pred => nil 662 concat('" if ",pred2English pred) 663 sayBrightly [:formatOpSignature(op,sig),:suffix] 664 665--======================================================================= 666-- Compute the lookup function (complete or incomplete) 667--======================================================================= 668NRTgetLookupFunction(domform,exCategory,addForm) == 669 domform := SUBLIS($pairlis,domform) 670 addForm := SUBLIS($pairlis,addForm) 671 $why: local := nil 672 atom addForm => 'lookupComplete 673 extends := NRTextendsCategory1(domform,exCategory,getExportCategory addForm) 674 if null extends then 675 [u,msg,:v] := $why 676 sayBrightly '"--------------non extending category----------------------" 677 sayBrightlyNT ['"..",:bright form2String domform,"of cat "] 678 PRINT u 679 sayBrightlyNT bright msg 680 if v then PRINT first v else TERPRI() 681 extends => 'lookupIncomplete 682 'lookupComplete 683 684getExportCategory form == 685 [op,:argl] := form 686 op = 'Record => ['RecordCategory,:argl] 687 op = 'Union => ['UnionCategory,:argl] 688 functorModemap := GETDATABASE(op,'CONSTRUCTORMODEMAP) 689 [[.,target,:tl],:.] := functorModemap 690 EQSUBSTLIST(argl,$FormalMapVariableList,target) 691 692NRTextendsCategory1(domform,exCategory,addForm) == 693 addForm is ["@Tuple", :r] => 694 and/[extendsCategory(domform,exCategory,x) for x in r] 695 extendsCategory(domform,exCategory,addForm) 696 697--======================================================================= 698-- Compute if a domain constructor is forgetful functor 699--======================================================================= 700extendsCategory(dom,u,v) == 701 --does category u extend category v (yes iff u contains everything in v) 702 --is dom of category u also of category v? 703 u=v => true 704 v is ["Join",:l] => and/[extendsCategory(dom,u,x) for x in l] 705 v is ["CATEGORY",.,:l] => and/[extendsCategory(dom,u,x) for x in l] 706 v := substSlotNumbers(v,$template,$functorForm) 707 extendsCategoryBasic0(dom,u,v) => true 708 $why := 709 v is ['SIGNATURE,op,sig] => [u,['" has no ",:formatOpSignature(op,sig)]] 710 [u,'" has no",v] 711 nil 712 713extendsCategoryBasic0(dom,u,v) == 714 v is ['IF,p,['ATTRIBUTE,c],.] => 715 -- BREAK() 716 uVec := (compMakeCategoryObject(u, $EmptyEnvironment)).expr 717 null atom c and isCategoryForm(c) => 718 slot4 := uVec.4 719 LASSOC(c,CADR slot4) is [=p,:.] 720 slot2 := uVec.2 721 LASSOC(c,slot2) is [=p,:.] 722 extendsCategoryBasic(dom,u,v) 723 724extendsCategoryBasic(dom,u,v) == 725 u is ["Join",:l] => or/[extendsCategoryBasic(dom,x,v) for x in l] 726 u = v => true 727 uVec := (compMakeCategoryObject(u, $EmptyEnvironment)).expr 728 isCategoryForm(v) => catExtendsCat?(u, v, uVec) 729 v is ['SIGNATURE,op,sig] => 730 res := false 731 for csig in uVec.1 repeat 732 not(csig is [[=op, sig], pred, :.]) => "iterate" 733 pred = true => 734 res := true 735 return true 736 res 737 u is ['CATEGORY,.,:l] => 738 v is ['IF,:.] => member(v,l) 739 nil 740 nil 741 742catExtendsCat?(u,v,uvec) == 743 u = v => true 744 uvec := uvec or (compMakeCategoryObject(u, $EmptyEnvironment)).expr 745 slot4 := uvec.4 746 prinAncestorList := first slot4 747 member(v,prinAncestorList) => true 748 vOp := IFCAR v 749 if similarForm := assoc(vOp,prinAncestorList) then 750 PRINT u 751 sayBrightlyNT '" extends " 752 PRINT similarForm 753 sayBrightlyNT '" but not " 754 PRINT v 755 or/[catExtendsCat?(x,v,nil) for x in ASSOCLEFT CADR slot4] 756 757substSlotNumbers(form,template,domain) == 758 form is [op,:.] and 759 MEMQ(op,allConstructors()) => expandType(form,template,domain) 760 form is ['SIGNATURE,op,sig] => 761 ['SIGNATURE,op,[substSlotNumbers(x,template,domain) for x in sig]] 762 form is ['CATEGORY,k,:u] => 763 ['CATEGORY,k,:[substSlotNumbers(x,template,domain) for x in u]] 764 expandType(form,template,domain) 765 766expandType(lazyt,template,domform) == 767 atom lazyt => expandTypeArgs(lazyt,template,domform) 768 [functorName,:argl] := lazyt 769 MEMQ(functorName, '(Record Union)) and first argl is [":",:.] => 770 [functorName,:[['_:,tag,expandTypeArgs(dom,template,domform)] 771 for [.,tag,dom] in argl]] 772 lazyt is ['local,x] => 773 n := POSN1(x,$FormalMapVariableList) 774 ELT(domform,1 + n) 775 [functorName,:[expandTypeArgs(a,template,domform) for a in argl]] 776 777expandTypeArgs(u,template,domform) == 778 u = '$ => u --template.0 -------eliminate this as $ is rep by 0 779 INTEGERP u => expandType(templateVal(template, domform, u), template,domform) 780 u is ['NRTEVAL,y] => y --eval y 781 u is ['QUOTE,y] => y 782 atom u => u 783 expandType(u,template,domform) 784 785templateVal(template,domform,index) == 786--returns a domform or a lazy slot 787 index = 0 => harhar() --template 788 template.index 789