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