path: root/src/interp/cattable.boot

-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
--     - Redistributions of source code must retain the above copyright
--       notice, this list of conditions and the following disclaimer.
--
--     - Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in
--       the documentation and/or other materials provided with the
--       distribution.
--
--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
--       names of its contributors may be used to endorse or promote products
--       derived from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


import '"simpbool"
import '"g-util"
)package "BOOT"

hasCat(domainOrCatName,catName) ==
  catName='Object or catName='Type  -- every domain is a Type (Object)
   or GETDATABASE([domainOrCatName,:catName],'HASCATEGORY)

showCategoryTable con ==
  [[b,:val] for (key :=[a,:b]) in HKEYS _*HASCATEGORY_-HASH_*
     | a = con and (val := HGET(_*HASCATEGORY_-HASH_*,key))]

displayCategoryTable(:options) ==
  conList := IFCAR options
  SETQ($ct,MAKE_-HASHTABLE 'ID)
  for (key:=[a,:b]) in HKEYS _*HASCATEGORY_-HASH_* repeat
    HPUT($ct,a,[[b,:HGET(_*HASCATEGORY_-HASH_*,key)],:HGET($ct,a)])
  for id in HKEYS $ct | null conList or MEMQ(id,conList) repeat
    sayMSG [:bright id,'"extends:"]
    PRINT HGET($ct,id)

genCategoryTable() ==
  SETQ(_*ANCESTORS_-HASH_*,  MAKE_-HASHTABLE 'ID)
  SETQ(_*HASCATEGORY_-HASH_*,MAKE_-HASHTABLE 'UEQUAL)
  genTempCategoryTable()
  domainList:=
    [con for con in allConstructors()
      | GETDATABASE(con,'CONSTRUCTORKIND) = 'domain]
  domainTable:= [addDomainToTable(con,getConstrCat catl) for con
    in domainList | catl := GETDATABASE(con,'CONSTRUCTORCATEGORY)]
  -- $nonLisplibDomains, $noCategoryDomains are set in BUILDOM BOOT
  specialDs := SETDIFFERENCE($nonLisplibDomains,$noCategoryDomains)
  domainTable:= [:[addDomainToTable(id, getConstrCat (eval [id]).3)
    for id in specialDs], :domainTable]
  for [id,:entry] in domainTable repeat
    for [a,:b] in encodeCategoryAlist(id,entry) repeat
      HPUT(_*HASCATEGORY_-HASH_*,[id,:a],b)
  simpTempCategoryTable()
  compressHashTable _*ANCESTORS_-HASH_*
  simpCategoryTable()
  compressHashTable _*HASCATEGORY_-HASH_*

simpTempCategoryTable() ==
  for id in HKEYS _*ANCESTORS_-HASH_* repeat
    for (u:=[a,:b]) in GETDATABASE(id,'ANCESTORS) repeat
      RPLACA(u,SUBST('Type,'Object,a))
      RPLACD(u,simpHasPred b)

simpCategoryTable() == main where
  main() ==
    for key in HKEYS _*HASCATEGORY_-HASH_* repeat
      entry := HGET(_*HASCATEGORY_-HASH_*,key)
      null entry => HREM(_*HASCATEGORY_-HASH_*,key)
      change :=
        atom opOf entry => simpHasPred entry
        [[x,:npred] for [x,:pred] in entry | npred := simpHasPred pred]
      HPUT(_*HASCATEGORY_-HASH_*,key,change)

simpHasPred(pred,:options) == main where
  main() ==
    $hasArgs: local := IFCDR IFCAR options
    simp pred
  simp pred ==
    pred is [op,:r] =>
      op = "has" => simpHas(pred,first r,first rest r)
      op = 'HasCategory => simp ['has,CAR r,simpDevaluate CADR r]
      op = 'HasSignature =>
         [op,sig] := simpDevaluate CADR r
         ["has",CAR r,['SIGNATURE,op,sig]]
      op = 'HasAttribute =>
        form := ['has,a := CAR r,['ATTRIBUTE,b := simpDevaluate CADR r]]
        simpHasAttribute(form,a,b)
      MEMQ(op,'(AND OR NOT)) =>
        null (u := MKPF([simp p for p in r],op)) => nil
        u is '(QUOTE T) => true
        simpBool u
      op = 'hasArgs => ($hasArgs => $hasArgs = r; pred)
      null r and opOf op = 'has => simp first pred
      pred is '(QUOTE T) => true
      op1 := LASSOC(op,'((and . AND)(or . OR)(not . NOT))) => simp [op1,:r]
      simp first pred   --REMOVE THIS HACK !!!!
    pred in '(T etc) => pred
    null pred => nil
    pred
  simpDevaluate a == EVAL SUBST('QUOTE,'devaluate,a)
  simpHas(pred,a,b) ==
    b is ['ATTRIBUTE,attr] => simpHasAttribute(pred,a,attr)
    b is ['SIGNATURE,op,sig] => simpHasSignature(pred,a,op,sig)
    IDENTP a or hasIdent b => pred
    npred := eval pred
    IDENTP npred or null hasIdent npred => npred
    pred
  eval (pred := ['has,d,cat]) ==
    x := hasCat(CAR d,CAR cat)
    y := CDR cat =>
      npred := or/[p for [args,:p] in x | y = args] => simp npred
      false  --if not there, it is false
    x

simpHasSignature(pred,conform,op,sig) == --eval w/o loading
  IDENTP conform => pred
  [conname,:args] := conform
  n := #sig
  u := LASSOC(op,GETDATABASE(conname,'OPERATIONALIST))
  candidates := [x for (x := [sig1,:.]) in u | #sig1 = #sig]  or return false
  match := or/[x for (x := [sig1,:.]) in candidates
                | sig = sublisFormal(args,sig1)] or return false
  simpHasPred(match is [sig,.,:p] and sublisFormal(args,p) or true)

simpHasAttribute(pred,conform,attr) ==  --eval w/o loading
  IDENTP conform => pred
  conname := opOf conform
  GETDATABASE(conname,'CONSTRUCTORKIND) = 'category =>
      simpCatHasAttribute(conform,attr)
  asharpConstructorName? conname =>
    p := LASSOC(attr,GETDATABASE(conname,'attributes)) =>
      simpHasPred sublisFormal(rest conform,p)
  infovec := dbInfovec conname
  k := LASSOC(attr,infovec.2) or return nil --if not listed then false
  k = 0 => true
  $domain => kTestPred k    --from koOps
  predvec := $predvec or sublisFormal(rest conform,
      GETDATABASE(conname,'PREDICATES))
  simpHasPred predvec.(k - 1)

simpCatHasAttribute(domform,attr) ==
  conform := getConstructorForm opOf domform
  catval :=  EVAL mkEvalable conform
  if atom KDR attr then attr := IFCAR attr
  pred :=
    u := LASSOC(attr,catval . 2) => first u
    return false                            --exit: not there
  pred = true => true
  EVAL SUBLISLIS(rest domform,rest conform,pred)

hasIdent pred ==
  pred is [op,:r] =>
    op = 'QUOTE => false
    or/[hasIdent x for x in r]
  pred = '_$ => false
  IDENTP pred => true
  false

addDomainToTable(id,catl) ==
  alist:= nil
  for cat in catl repeat
    cat is ['CATEGORY,:.] => nil
    cat is ['IF,pred,cat1,:.] =>
      newAlist:=
        [[a,:quickAnd(pred,b)] for [a,:b] in getCategoryExtensionAlist0 cat1]
      alist:= [:alist,:newAlist]
    alist:= [:alist,:getCategoryExtensionAlist0 cat]
  [id,:alist]

domainHput(table,key:=[id,:a],b) ==
  HPUT(table,key,b)

genTempCategoryTable() ==
  --generates hashtable with key=categoryName and value of the form
  --     ((form . pred) ..) meaning that
  --           "IF pred THEN ofCategory(key,form)"
  --  where form can involve #1, #2, ... the parameters of key
  for con in allConstructors()  repeat
    GETDATABASE(con,'CONSTRUCTORKIND) = 'category =>
      addToCategoryTable con
  for id in HKEYS _*ANCESTORS_-HASH_* repeat
    item := HGET(_*ANCESTORS_-HASH_*, id) 
    for (u:=[.,:b]) in item repeat
      RPLACD(u,simpCatPredicate simpBool b)
    HPUT(_*ANCESTORS_-HASH_*,id,listSort(function GLESSEQP,item))

addToCategoryTable con ==
  -- adds an entry to $tempCategoryTable with key=con and alist entries
  u := CAAR GETDATABASE(con,'CONSTRUCTORMODEMAP) --domain
  alist := getCategoryExtensionAlist u
  HPUT(_*ANCESTORS_-HASH_*,first u,alist)
  alist

encodeCategoryAlist(id,alist) ==
  newAl:= nil
  for [a,:b] in alist repeat
    [key,:argl] := a
    newEntry:=
      argl => [[argl,:b]]
      b
    u:= assoc(key,newAl) =>
      argl => RPLACD(u,encodeUnion(id,first newEntry,rest u))
      if newEntry ^= rest u then
        p:= moreGeneralCategoryPredicate(id,newEntry,rest u) => RPLACD(u,p)
        sayMSG '"Duplicate entries:"
        PRINT [newEntry,rest u]
    newAl:= [[key,:newEntry],:newAl]
  newAl

encodeUnion(id,new:=[a,:b],alist) ==
  u := assoc(a,alist) =>
    RPLACD(u,moreGeneralCategoryPredicate(id,b,rest u))
    alist
  [new,:alist]

moreGeneralCategoryPredicate(id,new,old) ==
  old = 'T or new = 'T => 'T
  old is ['has,a,b] and new is ['has,=a,c] =>
    tempExtendsCat(b,c) => new
    tempExtendsCat(c,b) => old
    ['OR,old,new]
  mkCategoryOr(new,old)

mkCategoryOr(new,old) ==
  old is ['OR,:l] => simpCategoryOr(new,l)
  ['OR,old,new]

simpCategoryOr(new,l) ==
  newExtendsAnOld:= false
  anOldExtendsNew:= false
  ['has,a,b] := new
  newList:= nil
  for pred in l repeat
    pred is ['has,=a,c] =>
      tempExtendsCat(c,b) => anOldExtendsNew:= true
      if tempExtendsCat(b,c) then newExtendsAnOld:= true
      newList:= [pred,:newList]
    newList:= [pred,:newList]
  if not newExtendsAnOld then newList:= [new,:newList]
  newList is [.] => first newList
  ['OR,:newList]

tempExtendsCat(b,c) ==
  or/[first c = a for [[a,:.],:.] in GETDATABASE(first b,'ANCESTORS)]

getCategoryExtensionAlist0 cform ==
  [[cform,:'T],:getCategoryExtensionAlist cform]

getCategoryExtensionAlist cform ==
  --avoids substitution as much as possible
  u:= GETDATABASE(first cform,'ANCESTORS) => formalSubstitute(cform,u)
  mkCategoryExtensionAlist cform

formalSubstitute(form:=[.,:argl],u) ==
  isFormalArgumentList argl => u
  EQSUBSTLIST(argl,$FormalMapVariableList,u)

isFormalArgumentList argl ==
  and/[x=fa for x in argl for fa in $FormalMapVariableList]

mkCategoryExtensionAlist cform ==
  not CONSP cform => nil
  cop := first cform
  MEMQ(cop, $CategoryNames) => mkCategoryExtensionAlistBasic cform
  catlist := formalSubstitute(cform, first getConstructorExports(cform, true))
  extendsList:= nil
  for [cat,:pred] in catlist repeat
    newList := getCategoryExtensionAlist0 cat
    finalList :=
      pred = 'T => newList
      [[a,:quickAnd(b,pred)] for [a,:b] in newList]
    extendsList:= catPairUnion(extendsList,finalList,cop,cat)
  extendsList

-- following code to handle Unions Records Mapping etc.
mkCategoryExtensionAlistBasic cform ==
  cop := first cform
--category:= eval cform
  category :=      -- changed by RSS on 7/29/87
    macrop cop => eval cform
    APPLY(cop, rest cform)
  extendsList:= [[x,:'T] for x in category.4.0]
  for [cat,pred,:.] in category.4.1 repeat
    newList := getCategoryExtensionAlist0 cat
    finalList :=
      pred = 'T => newList
      [[a,:quickAnd(b,pred)] for [a,:b] in newList]
    extendsList:= catPairUnion(extendsList,finalList,cop,cat)
  extendsList

catPairUnion(oldList,newList,op,cat) ==
  for pair in newList repeat
    u:= assoc(first pair,oldList) =>
      rest u = rest pair => nil
      RPLACD(u,addConflict(rest pair,rest u)) where addConflict(new,old) ==
        quickOr(new,old)
    oldList:= [pair,:oldList]
  oldList

simpCatPredicate p ==
  p is ['OR,:l] =>
    (u:= simpOrUnion l) is [p] => p
    ['OR,:u]
  p

simpOrUnion l ==
  if l then simpOrUnion1(first l,simpOrUnion rest l)
  else l

simpOrUnion1(x,l) ==
  null l => [x]
  p:= mergeOr(x,first l) => [p,:rest l]
  [first l,:simpOrUnion1(x,rest l)]

mergeOr(x,y) ==
  x is ["has",a,b] and y is ['has,=a,c] =>
    testExtend(b,c) => y
    testExtend(c,b) => x
    nil
  nil

testExtend(a:=[op,:argl],b) ==
  (u:= GETDATABASE(op,'ANCESTORS)) and (val:= LASSOC(b,u)) =>
    formalSubstitute(a,val)
  nil

getConstrCat(x) ==
-- gets a different representation of the constructorCategory from the
-- lisplib, which is a list of named categories or conditions
  x:= if x is ['Join,:y] then y else [x]
  cats:= NIL
  for y in x repeat
    y is ['CATEGORY,.,:z] =>
      for zz in z repeat cats := makeCatPred(zz, cats, true)
    cats:= CONS(y,cats)
  cats:= nreverse cats
  cats


makeCatPred(zz, cats, thePred) ==
  if zz is ['IF,curPred := ['has,z1,z2],ats,.] then
    ats := if ats is ['PROGN,:atl] then atl else [ats]
    for at in ats repeat
      if at is ['ATTRIBUTE,z3] and not atom z3 and
        constructor? CAR z3 then
          cats:= CONS(['IF,quickAnd(['has,z1,z2], thePred),z3,'%noBranch],cats)
      at is ['IF, pred, :.] =>
        cats := makeCatPred(at, cats, curPred)
  cats

getConstructorExports(conform,:options) == categoryParts(conform,
  GETDATABASE(opOf conform,'CONSTRUCTORCATEGORY),IFCAR options)

categoryParts(conform,category,:options) == main where
  main() ==
    cons? := IFCAR options  --means to include constructors as well
    $attrlist: local := nil
    $oplist  : local := nil
    $conslist: local := nil
    conname := opOf conform
    for x in exportsOf(category) repeat build(x,true)
    $attrlist := listSort(function GLESSEQP,$attrlist)
    $oplist   := listSort(function GLESSEQP,$oplist)
    res := [$attrlist,:$oplist]
    if cons? then res := [listSort(function GLESSEQP,$conslist),:res]
    if GETDATABASE(conname,'CONSTRUCTORKIND) = 'category then
      tvl := TAKE(#rest conform,$TriangleVariableList)
      res := SUBLISLIS($FormalMapVariableList,tvl,res)
    res
  build(item,pred) ==
    item is ['SIGNATURE,op,sig,:.] => $oplist   := [[opOf op,sig,:pred],:$oplist]
    --note: opOf is needed!!! Bug in compiler puts in (One) and (Zero)
    item is ['ATTRIBUTE,attr] =>
      constructor? opOf attr =>
        $conslist := [[attr,:pred],:$conslist]
        nil
      opOf attr = 'nothing => 'skip
      $attrlist := [[opOf attr,IFCDR attr,:pred],:$attrlist]
    item is ['TYPE,op,type] =>
        $oplist := [[op,[type],:pred],:$oplist]
    item is ['IF,pred1,s1,s2] =>
      build(s1,quickAnd(pred,pred1))
      s2 => build(s2,quickAnd(pred,['NOT,pred1]))
    item is ['PROGN,:r] => for x in r repeat build(x,pred)
    item in '(%noBranch) => 'ok
    null item => 'ok
    systemError '"build error"
  exportsOf(target) ==
    target is ['CATEGORY,.,:r] => r
    target is ['Join,:r,f] =>
      for x in r repeat $conslist := [[x,:true],:$conslist]
      exportsOf f
    $conslist := [[target,:true],:$conslist]
    nil

--------------------> NEW DEFINITION (override in patches.lisp.pamphlet)
compressHashTable ht ==
-- compresses hash table ht, to give maximal sharing of cells
  sayBrightlyNT '"compressing hash table..."
  $found: local := MAKE_-HASHTABLE 'UEQUAL
  for x in HKEYS ht repeat compressSexpr(HGET(ht,x),nil,nil)
  sayBrightly   "done"
  ht

compressSexpr(x,left,right) ==
-- recursive version of compressHashTable
  atom x => nil
  u:= HGET($found,x) =>
    left => RPLACA(left,u)
    right => RPLACD(right,u)
    nil
  compressSexpr(first x,x,nil)
  compressSexpr(rest x,nil,x)
  HPUT($found,x,x)

squeezeList(l) ==
-- changes the list l, so that is has maximal sharing of cells
  $found:local:= NIL
  squeeze1 l

squeeze1(l) ==
-- recursive version of squeezeList
  x:= CAR l
  y:=
    atom x => x
    z:= member(x,$found) => CAR z
    $found:= CONS(x,$found)
    squeeze1 x
  RPLACA(l,y)
  x:= CDR l
  y:=
    atom x => x
    z:= member(x,$found) => CAR z
    $found:= CONS(x,$found)
    squeeze1 x
  RPLACD(l,y)

updateCategoryTable(cname,kind) ==
  $updateCatTableIfTrue =>
    kind = 'package => nil
    kind = 'category => updateCategoryTableForCategory(cname)
    updateCategoryTableForDomain(cname,getConstrCat(
      GETDATABASE(cname,'CONSTRUCTORCATEGORY)))
--+
  kind = 'domain and $NRTflag = true =>
    updateCategoryTableForDomain(cname,getConstrCat(
      GETDATABASE(cname,'CONSTRUCTORCATEGORY)))

updateCategoryTableForCategory(cname) ==
  clearTempCategoryTable([[cname,'category]])
  addToCategoryTable(cname)
  for id in HKEYS _*ANCESTORS_-HASH_* repeat
      for (u:=[.,:b]) in GETDATABASE(id,'ANCESTORS) repeat
        RPLACD(u,simpCatPredicate simpBool b)

updateCategoryTableForDomain(cname,category) ==
  clearCategoryTable(cname)
  [cname,:domainEntry]:= addDomainToTable(cname,category)
  for [a,:b] in encodeCategoryAlist(cname,domainEntry) repeat
    HPUT(_*HASCATEGORY_-HASH_*,[cname,:a],b)
  $doNotCompressHashTableIfTrue = true => _*HASCATEGORY_-HASH_*
  compressHashTable _*HASCATEGORY_-HASH_*

clearCategoryTable($cname) ==
  MAPHASH('clearCategoryTable1,_*HASCATEGORY_-HASH_*)

clearCategoryTable1(key,val) ==
  (CAR key=$cname)=> HREM(_*HASCATEGORY_-HASH_*,key)
  nil

clearTempCategoryTable(catNames) ==
  for key in HKEYS(_*ANCESTORS_-HASH_*) repeat
    MEMQ(key,catNames) => nil
    extensions:= nil
    for (extension:= [catForm,:.]) in GETDATABASE(key,'ANCESTORS)
      repeat
        MEMQ(CAR catForm,catNames) => nil
        extensions:= [extension,:extensions]
    HPUT(_*ANCESTORS_-HASH_*,key,extensions)