path: root/src/interp/nrunopt.boot

-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2008, 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 '"c-util"
)package "BOOT"

--=======================================================================
--            Generate Code to Create Infovec
--=======================================================================
getInfovecCode() == 
--Function called by compDefineFunctor1 to create infovec at compile time
  ['LIST,
    MKQ makeDomainTemplate $template,
      MKQ makeCompactDirect $NRTslot1Info,
        MKQ NRTgenFinalAttributeAlist(),
          NRTmakeCategoryAlist(),
            MKQ $lookupFunction]

--=======================================================================
--         Generation of Domain Vector Template (Compile Time)
--=======================================================================
makeDomainTemplate vec ==   
--NOTES: This function is called at compile time to create the template
--  (slot 0 of the infovec); called by getInfovecCode from compDefineFunctor1
  newVec := newShell SIZE vec
  for index in 0..MAXINDEX vec repeat
    item := vec.index
    null item => nil
    newVec.index :=
      atom item => item
      null atom first item => makeGoGetSlot(item,index)
      item   
  $byteVec := "append"/NREVERSE $byteVec
  newVec
 
makeGoGetSlot(item,index) ==
--NOTES: creates byte vec strings for LATCH slots
--these parts of the $byteVec are created first; see also makeCompactDirect
  [sig,whereToGo,op,:flag] := item
  n := #sig - 1
  newcode := [n,whereToGo,:makeCompactSigCode(sig,nil),index]
  $byteVec := [newcode,:$byteVec]
  curAddress := $byteAddress
  $byteAddress := $byteAddress + n + 4
  [curAddress,:op]
 
--=======================================================================
--                Generate OpTable at Compile Time
--=======================================================================
--> called by getInfovecCode (see top of this file) from compDefineFunctor1
makeCompactDirect u ==
  $predListLength :local := LENGTH $NRTslot1PredicateList
  $byteVecAcc: local := nil
  [nam,[addForm,:opList]] := u
  --pp opList 
  d := [[op,y] for [op,:items] in opList | y := makeCompactDirect1(op,items)]
  $byteVec := [:$byteVec,:"append"/NREVERSE $byteVecAcc]
  LIST2VEC ("append"/d)
 
makeCompactDirect1(op,items) ==
--NOTES: creates byte codes for ops implemented by the domain
    curAddress := $byteAddress
    $op: local := op  --temp hack by RDJ 8/90 (see orderBySubsumption)
    newcodes :=
      "append"/[u for y in orderBySubsumption items | u := fn y] or return nil
    $byteVecAcc := [newcodes,:$byteVecAcc]
    curAddress
 where fn y ==
  [sig,:r] := y
  r = ['Subsumed] =>
    n := #sig - 1
    $byteAddress := $byteAddress + n + 4
    [n,0,:makeCompactSigCode(sig,$isOpPackageName),0]  --always followed by subsuming signature
    --identified by a 0 in slot position
  if r is [n,:s] then
    slot :=
      n is [p,:.] => p  --the CDR is linenumber of function definition
      n
    predCode :=
      s is [pred,:.] => predicateBitIndex pred
      0
  --> drop items which are not present (predCode = -1)
  predCode = -1 => return nil
  --> drop items with NIL slots if lookup function is incomplete
  if null slot then
     $lookupFunction = 'lookupIncomplete => return nil
     slot := 1   --signals that operation is not present
  n := #sig - 1
  $byteAddress := $byteAddress + n + 4
  res := [n,predCode,:makeCompactSigCode(sig,$isOpPackageName),slot]
  res
 
orderBySubsumption items ==
  acc := subacc := nil
  for x in items repeat
    not MEMQ($op,'(Zero One)) and x is [.,.,.,'Subsumed] => subacc := [x,:subacc]
    acc := [x,:acc]
  y := z := nil
  for [a,b,:.] in subacc | b repeat   
  --NOTE: b = nil means that the signature a will appear in acc, that this
  --  entry is be ignored (e.g. init: -> $ in ULS)
    while (u := assoc(b,subacc)) repeat b := CADR u
    u := assoc(b,acc) or systemError nil
    if null CADR u then u := [CAR u,1] --mark as missing operation
    y := [[a,'Subsumed],u,:y] --makes subsuming signature follow one subsumed
    z := insert(b,z)  --mark a signature as already present
  [:y,:[w for (w := [c,:.]) in acc | not member(c,z)]] --add those not subsuming
 
makeCompactSigCode(sig,$isOpPackageName) == [fn for x in sig] where 
--$isOpPackageName = true only for an exported operation of a default package
  fn() == 
    x = '_$_$ => 2
    x = '$ => 0
    not INTEGERP x => systemError ['"code vector slot is ",x,"; must be number"]
--  x = 6 and $isOpPackageName => 0  --treat slot 6 as $ for default packages
    x
  
--=======================================================================
--              Instantiation Code (Stuffslots)
--=======================================================================
stuffDomainSlots dollar ==
  domname := devaluate dollar
  infovec := GETL(opOf domname,'infovec)
  lookupFunction := getLookupFun infovec
  lookupFunction :=
    lookupFunction = 'lookupIncomplete => function lookupIncomplete
    function lookupComplete
  template := infovec.0
  if template.5 then stuffSlot(dollar,5,template.5)
  for i in (6 + # rest domname)..MAXINDEX template | item := template.i repeat
    stuffSlot(dollar,i,item)
  dollar.1 := LIST(lookupFunction,dollar,infovec.1)
  dollar.2 := infovec.2
  proto4 := infovec.3
  dollar.4 := 
    VECP CDDR proto4 => [COPY_-SEQ CAR proto4,:CDR proto4]   --old style
    bitVector := dollar.3
    predvec := CAR proto4
    packagevec := CADR proto4
    auxvec := LIST2VEC [fn for i in 0..MAXINDEX predvec] where fn() ==
      null testBitVector(bitVector,predvec.i) => nil
      packagevec.i or true
    [auxvec,:CDDR proto4]

getLookupFun infovec ==
  MAXINDEX infovec = 4 => infovec.4
  'lookupIncomplete

stuffSlot(dollar,i,item) ==
  dollar.i :=
    atom item => [SYMBOL_-FUNCTION item,:dollar]
    item is [n,:op] and INTEGERP n => ['newGoGet,dollar,:item]
    item is ['CONS,.,['FUNCALL,a,b]] =>
      b = '$ => ['makeSpadConstant,eval a,dollar,i]
      sayBrightlyNT '"Unexpected constant environment!!"
      pp devaluate b
      nil
--  [dollar,i,:item]    --old form
--  $isOpPackageName = 'T => SUBST(0,6,item)
    item                --new form
--=======================================================================
--                Generate Slot 2 Attribute Alist
--=======================================================================
NRTgenInitialAttributeAlist attributeList ==
  --alist has form ((item pred)...) where some items are constructor forms
  alist := [x for x in attributeList | -- throw out constructors
    not MEMQ(opOf first x,allConstructors())]
  $lisplibAttributes := simplifyAttributeAlist
    [[a,:b] for [a,b] in SUBLIS($pairlis,alist) | a ^= 'nothing]

simplifyAttributeAlist al ==
  al is [[a,:b],:r] =>
    u := [x for x in r | x is [=a,:b]] 
    null u => [first al,:simplifyAttributeAlist rest al]
    pred := simpBool makePrefixForm([b,:ASSOCRIGHT u],'OR)
    $NRTslot1PredicateList := insert(pred,$NRTslot1PredicateList)
    s := [x for x in r | x isnt [=a,:b]]
    [[a,:pred],:simplifyAttributeAlist s]
  nil
 
NRTgenFinalAttributeAlist() ==
  [[a,:k] for [a,:b] in $NRTattributeAlist | (k := predicateBitIndex(b)) ^= -1]
 
predicateBitIndex x == 
  pn(x,false) where
    pn(x,flag) ==
      u := simpBool transHasCode x
      u = 'T  =>  0
      u = nil => -1
      p := POSN1(u,$NRTslot1PredicateList) => p + 1
      not flag => pn(predicateBitIndexRemop x,true)
      systemError nil

predicateBitIndexRemop p==
--transform attribute predicates taken out by removeAttributePredicates
  p is [op,:argl] and op in '(AND and OR or NOT not) => 
    simpBool makePrefixForm([predicateBitIndexRemop x for x in argl],op)
  p is ['has,'$,['ATTRIBUTE,a]] => LASSOC(a,$NRTattributeAlist)
  p
 
predicateBitRef x ==
  x = 'T => 'T
  ['testBitVector,'pv_$,predicateBitIndex x]
 
makePrefixForm(u,op) ==
  u := MKPF(u,op)
  u = ''T => 'T
  u
--=======================================================================
--               Generate Slot 3 Predicate Vector
--=======================================================================
makePredicateBitVector pl ==   --called by NRTbuildFunctor
  if $insideCategoryPackageIfTrue then
    pl := union(pl,$categoryPredicateList)
  $predGensymAlist := nil --bound by NRTbuildFunctor, used by optHas
  for p in removeAttributePredicates pl repeat
    pred := simpBool transHasCode p
    atom pred => 'skip                --skip over T and NIL
    if isHasDollarPred pred then 
      lasts := insert(pred,lasts)
      for q in stripOutNonDollarPreds pred repeat firsts := insert(q,firsts)
    else 
      firsts := insert(pred,firsts)
  firstPl := SUBLIS($pairlis,NREVERSE orderByContainment firsts)
  lastPl  := SUBLIS($pairlis,NREVERSE orderByContainment lasts)
  firstCode:= 
    ['buildPredVector,0,0,mungeAddGensyms(firstPl,$predGensymAlist)]
  lastCode := augmentPredCode(# firstPl,lastPl)
  $lisplibPredicates := [:firstPl,:lastPl] --what is stored under 'predicates
  [$lisplibPredicates,firstCode,:lastCode]  --$pairlis set by compDefineFunctor1

augmentPredCode(n,lastPl) ==
  ['LIST,:pl] := mungeAddGensyms(lastPl,$predGensymAlist)
  delta := 2 ** n
  l := [(u := MKPF([x,['augmentPredVector,"$",delta]],'AND); 
         delta:=2 * delta; u) for x in pl]

augmentPredVector(dollar,value) ==
  setShellEntry(dollar,3,value + QVELT(dollar,3))

isHasDollarPred pred ==
  pred is [op,:r] =>
    MEMQ(op,'(AND and OR or NOT not)) => or/[isHasDollarPred x for x in r]
    MEMQ(op,'(HasCategory HasAttribute)) => CAR r = '$
  false

stripOutNonDollarPreds pred ==
  pred is [op,:r] and MEMQ(op,'(AND and OR or NOT not)) => 
    "append"/[stripOutNonDollarPreds x for x in r]
  not isHasDollarPred pred => [pred]
  nil

removeAttributePredicates pl ==
  [fn p for p in pl] where
    fn p ==
      p is [op,:argl] and op in '(AND and OR or NOT not) => 
          makePrefixForm(fnl argl,op)
      p is ['has,'$,['ATTRIBUTE,a]] =>
        sayBrightlyNT '"Predicate: "
        PRINT p
        sayBrightlyNT '"  replaced by: "
        PRINT LASSOC(a,$NRTattributeAlist)
      p
    fnl p == [fn x for x in p]
 
transHasCode x ==
  atom x => x
  op := QCAR x
  MEMQ(op,'(HasCategory HasAttribute)) => x
  EQ(op,'has) => compHasFormat x
  [transHasCode y for y in x]
 
mungeAddGensyms(u,gal) ==
  ['LIST,:[fn(x,gal,0) for x in u]] where fn(x,gal,n) ==
    atom x => x
    g := LASSOC(x,gal) =>
      n = 0 => ['LET,g,x]
      g
    [first x,:[fn(y,gal,n + 1) for y in rest x]]
 
orderByContainment pl ==
  null pl or null rest pl => pl
  max := first pl
  for x in rest pl repeat
    if (y := CONTAINED(max,x)) then
      if null assoc(max,$predGensymAlist)
      then $predGensymAlist := [[max,:GENSYM()],:$predGensymAlist]
    else if CONTAINED(x,max)
         then if null assoc(x,$predGensymAlist) then $predGensymAlist := [[x,:GENSYM()],:$predGensymAlist]
    if y then max := x
  [max,:orderByContainment delete(max,pl)]
 
buildBitTable(:l) == fn(REVERSE l,0) where fn(l,n) ==
  null l => n
  n := n + n
  if QCAR l then n := n + 1
  fn(rest l,n)
 
buildPredVector(init,n,l) == fn(init,2 ** n,l) where fn(acc,n,l) ==
  null l => acc
  if CAR l then acc := acc + n
  fn(acc,n + n,rest l)

testBitVector(vec,i) ==
--bit vector indices are always 1 larger than position in vector
  i = 0 => true
  LOGBITP(i - 1,vec)
 
bitsOf n ==
  n = 0 => 0
  1 + bitsOf (n/2)
 
--=======================================================================
--               Generate Slot 4 Constructor Vectors
--=======================================================================
NRTmakeCategoryAlist() ==
  $depthAssocCache: local := MAKE_-HASHTABLE 'ID
  $catAncestorAlist: local := NIL
  pcAlist := [:[[x,:"T"] for x in $uncondAlist],:$condAlist]
  $levelAlist: local := depthAssocList [CAAR x for x in pcAlist]
  opcAlist := NREVERSE SORTBY(function NRTcatCompare,pcAlist)
  newPairlis := [[5 + i,:b] for [.,:b] in $pairlis for i in 1..]
  slot1 := [[a,:k] for [a,:b] in SUBLIS($pairlis,opcAlist)
                   | (k := predicateBitIndex b) ^= -1]
  slot0 := [hasDefaultPackage opOf a for [a,:b] in slot1]
  sixEtc := [5 + i for i in 1..#$pairlis]
  formals := ASSOCRIGHT $pairlis
  for x in slot1 repeat
       RPLACA(x,EQSUBSTLIST(CONS("$$",sixEtc),CONS('$,formals),CAR x))
  -----------code to make a new style slot4 -----------------
  predList := ASSOCRIGHT slot1  --is list of predicate indices
  maxPredList := "MAX"/predList
  catformvec := ASSOCLEFT slot1
  maxElement := "MAX"/$byteVec
  ['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList],
    ['CONS, MKQ LIST2VEC slot0,
      ['CONS, MKQ LIST2VEC [encodeCatform x for x in catformvec],
        ['makeByteWordVec2,maxElement,MKQ $byteVec]]]]
  --NOTE: this is new form: old form satisfies VECP CDDR form

encodeCatform x ==
  k := NRTassocIndex x => k
  atom x or atom rest x => x
  [first x,:[encodeCatform y for y in rest x]]
 
NRTcatCompare [catform,:pred] == LASSOC(first catform,$levelAlist)
 
hasDefaultPackage catname ==
  defname := INTERN STRCONC(catname,'"&")
  constructor? defname => defname
--MEMQ(defname,allConstructors()) => defname
  nil
 
 
--=======================================================================
--             Generate Category Level Alist
--=======================================================================
orderCatAnc x == NREVERSE ASSOCLEFT SORTBY('CDR,CDR depthAssoc x)
 
depthAssocList u == 
  u := delete('DomainSubstitutionMacro,u)  --hack by RDJ 8/90
  REMDUP ("append"/[depthAssoc(y) for y in u])
 
depthAssoc x ==
  y := HGET($depthAssocCache,x) => y
  x is ['Join,:u] or (u := getCatAncestors x) =>
    v := depthAssocList u
    HPUT($depthAssocCache,x,[[x,:n],:v])
      where n() == 1 + "MAX"/[rest y for y in v]
  HPUT($depthAssocCache,x,[[x,:0]])
 
getCatAncestors x ==  [CAAR y for y in parentsOf opOf x]
 
listOfEntries form ==
  atom form => form
  form is [op,:l] =>
    op = 'Join => "append"/[listOfEntries x for x in l]
    op = 'CATEGORY => listOfCategoryEntries rest l
    op = 'PROGN => listOfCategoryEntries l
    op = 'ATTRIBUTE and first l is [f,:.] and constructor? f => [first l]
    op in '(ATTRIBUTE SIGNATURE) => nil
    [form]
  categoryFormatError()
 
listOfCategoryEntries l ==
  null l => nil
  l is [[op,:u],:v] =>
    firstItemList:=
      op = 'ATTRIBUTE and first u is [f,:.] and constructor? f =>
        [first u]
      MEMQ(op,'(ATTRIBUTE SIGNATURE)) => nil
      op = 'IF and u is [pred,conseq,alternate] =>
          listOfCategoryEntriesIf(pred,conseq,alternate)
      categoryFormatError()
    [:firstItemList,:listOfCategoryEntries v]
  l is ['PROGN,:l] => listOfCategoryEntries l
  l is '(NIL) => nil
  sayBrightly '"unexpected category format encountered:"
  pp l
 
listOfCategoryEntriesIf(pred,conseq,alternate) ==
  alternate in '(%noBranch NIL) =>
    conseq is ['IF,p,c,a] => listOfCategoryEntriesIf(makePrefixForm([pred,p],'AND),c,a)
    [fn for x in listOfEntries conseq] where fn() ==
      x is ['IF,a,b] => ['IF,makePrefixForm([pred,a],'AND),b]
      ['IF,pred,x]
  notPred := makePrefixForm(pred,'NOT)
  conseq is ['IF,p,c,a] =>
    listOfCategoryEntriesIf(makePrefixForm([notPred,p],'AND),c,a)
  [gn for x in listOfEntries conseq] where gn() ==
    x is ['IF,a,b] => ['IF,makePrefixForm([notPred,a],'AND),b]
    ['IF,notPred,x]
 
--=======================================================================
--                     Display Template
--=======================================================================
dc(:r) ==
  con := KAR r
  options := KDR r
  ok := MEMQ(con,allConstructors()) or (con := abbreviation? con)
  null ok =>
    sayBrightly '"Format is: dc(<constructor name or abbreviation>,option)"
    sayBrightly 
      '"options are: all (default), slots, atts, cats, data, ops, optable"
  option := KAR options
  option = 'all or null option => dcAll con
  option = 'slots   =>  dcSlots con
  option = 'atts    =>  dcAtts  con
  option = 'cats    =>  dcCats  con
  option = 'data    =>  dcData  con
  option = 'ops     =>  dcOps   con
  option = 'size    =>  dcSize( con,'full)
  option = 'optable =>  dcOpTable con

dcSlots con ==
  name := abbreviation? con or con
  $infovec: local := getInfovec name
  template := $infovec.0
  for i in 5..MAXINDEX template repeat
    sayBrightlyNT bright i
    item := template.i
    item is [n,:op] and INTEGERP n => dcOpLatchPrint(op,n)
    null item and i > 5 => sayBrightly ['"arg  ",STRCONC('"#",STRINGIMAGE(i - 5))]
    atom item => sayBrightly ['"fun  ",item]
    item is ['CONS,.,['FUNCALL,[.,a],b]] => sayBrightly ['"constant ",a]
    sayBrightly concat('"lazy ",form2String formatSlotDomain i)
 
dcOpLatchPrint(op,index) ==
  numvec := getCodeVector()
  numOfArgs := numvec.index
  whereNumber := numvec.(index := index + 1)
  signumList := dcSig(numvec,index + 1,numOfArgs)
  index := index + numOfArgs + 1
  namePart := concat(bright "from",
    dollarPercentTran form2String formatSlotDomain whereNumber)
  sayBrightly ['"latch",:formatOpSignature(op,signumList),:namePart]
 
getInfovec name ==
  u := GETL(name,'infovec) => u
  GETL(name,'LOADED) => nil
  fullLibName := GETDATABASE(name,'OBJECT) or return nil
  startTimingProcess 'load
  loadLibNoUpdate(name, name, fullLibName)
  GETL(name,'infovec)
 
getOpSegment index ==
  numOfArgs := (vec := getCodeVector()).index
  [vec.i for i in index..(index + numOfArgs + 3)]

getCodeVector() ==
  proto4 := $infovec.3
  u := CDDR proto4
  VECP u => u           --old style
  CDR u                 --new style

formatSlotDomain x ==
  x = 0 => ["$"]
  x = 2 => ["$$"]
  INTEGERP x =>
    val := $infovec.0.x
    null val => [STRCONC('"#",STRINGIMAGE (x  - 5))]
    formatSlotDomain val
  atom x => x
  x is ['NRTEVAL,y] => (atom y => [y]; y)
  [first x,:[formatSlotDomain y for y in rest x]]
 
--=======================================================================
--                     Display OpTable
--=======================================================================
dcOpTable con ==
  name := abbreviation? con or con
  $infovec: local := getInfovec name
  template := $infovec.0
  $predvec: local := GETDATABASE(con,'PREDICATES)
  opTable := $infovec.1
  for i in 0..MAXINDEX opTable repeat
    op := opTable.i
    i := i + 1
    startIndex := opTable.i
    stopIndex :=
      i + 1 > MAXINDEX opTable => MAXINDEX getCodeVector()
      opTable.(i + 2)
    curIndex := startIndex
    while curIndex < stopIndex repeat
      curIndex := dcOpPrint(op,curIndex)
 
dcOpPrint(op,index) ==
  numvec := getCodeVector()
  segment := getOpSegment index
  numOfArgs := numvec.index
  index := index + 1
  predNumber := numvec.index
  index := index + 1
  signumList := dcSig(numvec,index,numOfArgs)
  index := index + numOfArgs + 1
  slotNumber := numvec.index
  suffix :=
    predNumber = 0 => nil
    [:bright '"if",:pred2English $predvec.(predNumber - 1)]
  namePart := bright
    slotNumber = 0 => '"subsumed by next entry"
    slotNumber = 1 => '"missing"
    name := $infovec.0.slotNumber
    atom name => name
    '"looked up"
  sayBrightly [:formatOpSignature(op,signumList),:namePart, :suffix]
  index + 1
 
dcSig(numvec,index,numOfArgs) ==
  [formatSlotDomain numvec.(index + i) for i in 0..numOfArgs]
 
dcPreds con ==
  name := abbreviation? con or con
  $infovec: local := getInfovec name
  $predvec:= GETDATABASE(con,'PREDICATES)
  for i in 0..MAXINDEX $predvec repeat
    sayBrightlyNT bright (i + 1)
    sayBrightly pred2English $predvec.i
 
dcAtts con ==
  name := abbreviation? con or con
  $infovec: local := getInfovec name
  $predvec:= GETDATABASE(con,'PREDICATES)
  attList := $infovec.2
  for [a,:predNumber] in attList for i in 0.. repeat
    sayBrightlyNT bright i
    suffix :=
      predNumber = 0 => nil
      [:bright '"if",:pred2English $predvec.(predNumber - 1)]
    sayBrightly [a,:suffix]
 
dcCats con ==
  name := abbreviation? con or con
  $infovec: local := getInfovec name
  u := $infovec.3
  VECP CDDR u => dcCats1 con    --old style slot4
  $predvec:= GETDATABASE(con,'PREDICATES)
  catpredvec := CAR u
  catinfo := CADR u
  catvec := CADDR u
  for i in 0..MAXINDEX catvec repeat
    sayBrightlyNT bright i
    form := catvec.i
    predNumber := catpredvec.i
    suffix :=
      predNumber = 0 => nil
      [:bright '"if",:pred2English $predvec.(predNumber - 1)]
    extra :=
      null (info := catinfo.i) => nil
      IDENTP info => bright '"package"
      bright '"instantiated"
    sayBrightly concat(form2String formatSlotDomain form,suffix,extra)
 
dcCats1 con ==
  $predvec:= GETDATABASE(con,'PREDICATES)
  u := $infovec.3
  catvec := CADR u
  catinfo := CAR u
  for i in 0..MAXINDEX catvec repeat
    sayBrightlyNT bright i
    [form,:predNumber] := catvec.i
    suffix :=
      predNumber = 0 => nil
      [:bright '"if",:pred2English $predvec.(predNumber - 1)]
    extra :=
      null (info := catinfo.i) => nil
      IDENTP info => bright '"package"
      bright '"instantiated"
    sayBrightly concat(form2String formatSlotDomain form,suffix,extra)
 
dcData con ==
  name := abbreviation? con or con
  $infovec: local := getInfovec name
  sayBrightly '"Operation data from slot 1"
  PRINT_-FULL $infovec.1
  vec := getCodeVector()
  vec := (PAIRP vec => CDR vec; vec)
  sayBrightly ['"Information vector has ",SIZE vec,'" entries"]
  dcData1 vec

dcData1 vec ==
  n := MAXINDEX vec
  tens := n / 10
  for i in 0..tens repeat
    start := 10*i
    sayBrightlyNT rightJustifyString(STRINGIMAGE start,6)
    sayBrightlyNT '"  |"
    for j in start..MIN(start + 9,n) repeat
      sayBrightlyNT rightJustifyString(STRINGIMAGE vec.j,6)
    sayNewLine()
  vec

dcSize(:options) ==
  con := KAR options
  options := rest options
  null con => dcSizeAll()
  quiet := MEMQ('quiet,options)
  full := MEMQ('full,options)
  name := abbreviation? con or con
  infovec := getInfovec name
  template := infovec.0
  maxindex := MAXINDEX template
  latch := 0  --# of go get slots
  lazy  := 0  --# of lazy domain slots
  fun   := 0  --# of function slots
  lazyNodes := 0 --# of nodes needed for lazy domain slots
  for i in 5..maxindex repeat
    atom (item := template.i) =>   fun := fun + 1
    INTEGERP first item    => latch := latch + 1
    'T                 =>  
       lazy := lazy + 1
       lazyNodes := lazyNodes + numberOfNodes item
  tSize := sum(vectorSize(1 + maxindex),nodeSize(lazyNodes + latch))
  -- functions are free in the template vector
  oSize := vectorSize(SIZE infovec.1)
  aSize := numberOfNodes infovec.2
  slot4 := infovec.3
  catvec := 
    VECP CDDR slot4 => CADR slot4
    CADDR slot4
  n := MAXINDEX catvec
  cSize := sum(nodeSize(2),vectorSize(SIZE CAR slot4),vectorSize(n + 1),
               nodeSize(+/[numberOfNodes catvec.i for i in 0..n]))
  codeVector :=
    VECP CDDR slot4 => CDDR slot4
    CDDDR slot4
  vSize := halfWordSize(SIZE codeVector)
  itotal := sum(tSize,oSize,aSize,cSize,vSize)
  if null quiet then sayBrightly ['"infovec total = ",itotal,'" BYTES"]
  if null quiet then
    lookupFun := getLookupFun infovec
    suffix := (lookupFun = 'lookupIncomplete => '"incomplete"; '"complete")
    sayBrightly ['"template    = ",tSize]
    sayBrightly ['"operations  = ",oSize,'" (",suffix,'")"]
    sayBrightly ['"attributes  = ",aSize]
    sayBrightly ['"categories  = ",cSize]
    sayBrightly ['"data vector = ",vSize]
  if null quiet then
    sayBrightly ['"number of function slots (one extra node) = ",fun]
    sayBrightly ['"number of latch slots (2 extra nodes) = ",latch]
    sayBrightly ['"number of lazy slots (no extra nodes) = ",lazy]
    sayBrightly ['"size of domain vectors = ",1 + maxindex,'" slots"]
  vtotal := itotal + nodeSize(fun)       --fun   slot is ($ . function)
  vtotal := vtotal + nodeSize(2 * latch) --latch slot is (newGoGet $ . code)
  --NOTE: lazy slots require no cost     --lazy  slot is lazyDomainForm
  if null quiet then sayBrightly ['"domain size = ",vtotal,'" BYTES"] 
  etotal := nodeSize(fun + 2 * latch) + vectorSize(1 + maxindex)
  if null quiet then sayBrightly ['"cost per instantiation = ",etotal,'" BYTES"]
  vtotal

dcSizeAll() ==
  count := 0
  total := 0
  for x in allConstructors() | null atom GETL(x,'infovec) repeat
    count := count + 1
    s := dcSize(x,'quiet)
    sayBrightly [s,'" : ",x]
    total := total + s
  sayBrightly '"------------total-------------"
  sayBrightly [count," constructors; ",total," BYTES"]  
    
sum(:l) == +/l

nodeSize(n) == 12 * n

vectorSize(n) == 4 * (1 + n)

halfWordSize(n) == 
  n < 128 => n / 2
  n < 256 => n
  2 * n

numberOfNodes(x) ==
  atom x => 0
  1 + numberOfNodes first x + numberOfNodes rest x

template con ==
  con := abbreviation? con or con
  ppTemplate (getInfovec con).0

ppTemplate vec ==
  for i in 0..MAXINDEX vec repeat
    sayBrightlyNT bright i
    pp vec.i

infovec con == 
  con := abbreviation? con or con
  u := getInfovec con
  sayBrightly '"---------------slot 0 is template-------------------"
  ppTemplate u.0
  sayBrightly '"---------------slot 1 is op table-------------------"
  PRINT_-FULL u.1
  sayBrightly '"---------------slot 2 is attribute list-------------"
  PRINT_-FULL u.2
  sayBrightly '"---------------slot 3.0 is catpredvec---------------"
  PRINT_-FULL u.3.0
  sayBrightly '"---------------slot 3.1 is catinfovec---------------"
  PRINT_-FULL u.3.1
  sayBrightly '"---------------slot 3.2 is catvec-------------------"
  PRINT_-FULL u.3.2
  sayBrightly '"---------------tail of slot 3 is datavector---------"
  dcData1 CDDDR u.3
  'done

dcAll con ==
  con := abbreviation? con or con
  $infovec : local := getInfovec con
  complete? := 
    #$infovec = 4 => false
    $infovec.4 = 'lookupComplete
  sayBrightly '"----------------Template-----------------"
  dcSlots con
  sayBrightly
    complete? => '"----------Complete Ops----------------"
    '"----------Incomplete Ops---------------"
  dcOpTable con
  sayBrightly '"----------------Atts-----------------"
  dcAtts con
  sayBrightly '"----------------Preds-----------------"
  dcPreds con
  sayBrightly '"----------------Cats-----------------"
  dcCats con
  sayBrightly '"----------------Data------------------"
  dcData con
  sayBrightly '"----------------Size------------------"
  dcSize(con,'full)
  'done

dcOps conname ==
  for [op,:u] in REVERSE getOperationAlistFromLisplib conname repeat
    for [sig,slot,pred,key,:.] in u repeat
      suffix := 
        atom pred => nil
        concat('" if ",pred2English pred)
      key = 'Subsumed =>
        sayBrightly [:formatOpSignature(op,sig),'" subsumed by ",:formatOpSignature(op,slot),:suffix]
      sayBrightly [:formatOpSignature(op,sig),:suffix]
  
--=======================================================================
--              Compute the lookup function (complete or incomplete)
--=======================================================================
NRTgetLookupFunction(domform,exCategory,addForm) ==
  domform := SUBLIS($pairlis,domform)
  addForm := SUBLIS($pairlis,addForm)
  $why: local := nil
  atom addForm => 'lookupComplete
  extends := NRTextendsCategory1(domform,exCategory,getExportCategory addForm)
  if null extends then 
    [u,msg,:v] := $why
    sayBrightly '"--------------non extending category----------------------"
    sayBrightlyNT ['"..",:bright form2String domform,"of cat "]
    PRINT u
    sayBrightlyNT bright msg
    if v then PRINT CAR v else TERPRI()
  extends => 'lookupIncomplete
  'lookupComplete

getExportCategory form ==
  [op,:argl] := form
  op = 'Record => ['RecordCategory,:argl]
  op = 'Union => ['UnionCategory,:argl]
  functorModemap := GETDATABASE(op,'CONSTRUCTORMODEMAP)
  [[.,target,:tl],:.] := functorModemap
  EQSUBSTLIST(argl,$FormalMapVariableList,target)
 
NRTextendsCategory1(domform,exCategory,addForm) ==
  addForm is ['Tuple,:r] => 
    and/[extendsCategory(domform,exCategory,x) for x in r]
  extendsCategory(domform,exCategory,addForm)

--=======================================================================
--         Compute if a domain constructor is forgetful functor
--=======================================================================
extendsCategory(dom,u,v) ==
  --does category u extend category v (yes iff u contains everything in v)
  --is dom of category u also of category v?
  u=v => true
  v is ["Join",:l] => and/[extendsCategory(dom,u,x) for x in l]
  v is ["CATEGORY",.,:l] => and/[extendsCategory(dom,u,x) for x in l]
  v is ["SubsetCategory",cat,d] => extendsCategory(dom,u,cat) and isSubset(dom,d,$e)
  v := substSlotNumbers(v,$template,$functorForm)
  extendsCategoryBasic0(dom,u,v) => true
  $why :=
    v is ['SIGNATURE,op,sig] => [u,['"  has no ",:formatOpSignature(op,sig)]]
    [u,'" has no",v]
  nil
 
extendsCategoryBasic0(dom,u,v) ==
  v is ['IF,p,['ATTRIBUTE,c],.] =>
    uVec := (compMakeCategoryObject(u,$EmptyEnvironment)).expr
    null atom c and isCategoryForm(c,nil) =>
      slot4 := uVec.4
      LASSOC(c,CADR slot4) is [=p,:.]
    slot2 := uVec.2
    LASSOC(c,slot2) is [=p,:.]
  extendsCategoryBasic(dom,u,v)
 
extendsCategoryBasic(dom,u,v) ==
  u is ["Join",:l] => or/[extendsCategoryBasic(dom,x,v) for x in l]
  u = v => true
  uVec := (compMakeCategoryObject(u,$EmptyEnvironment)).expr
  isCategoryForm(v,nil) => catExtendsCat?(u,v,uVec)
  v is ['SIGNATURE,op,sig] =>
    or/[uVec.i is [[=op,=sig],:.] for i in 6..MAXINDEX uVec]
  u is ['CATEGORY,.,:l] =>
    v is ['IF,:.] => member(v,l)
    nil
  nil
 
catExtendsCat?(u,v,uvec) ==
  u = v => true
  uvec := uvec or (compMakeCategoryObject(u,$EmptyEnvironment)).expr
  slot4 := uvec.4
  prinAncestorList := CAR slot4
  member(v,prinAncestorList) => true
  vOp := KAR v
  if similarForm := assoc(vOp,prinAncestorList) then
    PRINT u
    sayBrightlyNT '"   extends "
    PRINT similarForm
    sayBrightlyNT '"   but not "
    PRINT v
  or/[catExtendsCat?(x,v,nil) for x in ASSOCLEFT CADR slot4]
 
substSlotNumbers(form,template,domain) ==
  form is [op,:.] and
    MEMQ(op,allConstructors()) => expandType(form,template,domain)
  form is ['SIGNATURE,op,sig] =>
    ['SIGNATURE,op,[substSlotNumbers(x,template,domain) for x in sig]]
  form is ['CATEGORY,k,:u] =>
    ['CATEGORY,k,:[substSlotNumbers(x,template,domain) for x in u]]
  expandType(form,template,domain)
 
expandType(lazyt,template,domform) ==
  atom lazyt => expandTypeArgs(lazyt,template,domform)
  [functorName,:argl] := lazyt
  MEMQ(functorName, '(Record Union)) and first argl is [":",:.] =>
     [functorName,:[['_:,tag,expandTypeArgs(dom,template,domform)]
                                 for [.,tag,dom] in argl]]
  lazyt is ['local,x] =>
    n := POSN1(x,$FormalMapVariableList)
    ELT(domform,1 + n)
  [functorName,:[expandTypeArgs(a,template,domform) for a in argl]]
 
expandTypeArgs(u,template,domform) ==
  u = '$ => u --template.0      -------eliminate this as $ is rep by 0
  INTEGERP u => expandType(templateVal(template, domform, u), template,domform)
  u is ['NRTEVAL,y] => y  --eval  y
  u is ['QUOTE,y] => y
  atom u => u
  expandType(u,template,domform)
 
templateVal(template,domform,index) ==
--returns a domform or a lazy slot
  index = 0 => harhar() --template
  template.index