path: root/src/interp/cattable.boot

-- Copyright (C) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2011, 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 simpbool
import c_-util
namespace BOOT
module cattable where
  hasCat: (%Instantiation,%Instantiation) -> %Code

hasCat(dom,cat) ==
  cat.op is "Type"  -- every domain is a Type
    or constructorHasCategoryFromDB [dom.op,:cat.op]

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

displayCategoryTable(:options) ==
  conList := IFCAR options
  SETQ($ct,hashTable 'EQ)
  for (key:=[a,:b]) in HKEYS _*HASCATEGORY_-HASH_* repeat
    tableValue($ct,a) := [[b,:tableValue(_*HASCATEGORY_-HASH_*,key)],:tableValue($ct,a)]
  for id in HKEYS $ct | null conList or symbolMember?(id,conList) repeat
    sayMSG [:bright id,'"extends:"]
    PRINT tableValue($ct,id)

genCategoryTable() ==
  SETQ(_*ANCESTORS_-HASH_*,  hashTable 'EQ)
  SETQ(_*HASCATEGORY_-HASH_*,hashTable 'EQUAL)
  genTempCategoryTable()
  domainTable :=
    [addDomainToTable(con,getConstrCat getConstructorCategoryFromDB con)
      for con in allConstructors() | getConstructorKindFromDB con is "domain"]
  -- $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
      tableValue(_*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 getConstructorAncestorsFromDB id repeat
      u.rest := simpHasPred b

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

simpHasPred(pred,:options) == main where
  main() ==
    $hasArgs: local := IFCDR IFCAR options
    simp pred
  simp pred ==
    pred is [op,:r] =>
      op is "has" => simpHas(pred,first r,second r)
      op is 'HasCategory => simp ["has",first r,simpDevaluate second r]
      op is 'HasSignature =>
         [op,sig] := simpDevaluate second r
         ["has",first r,['SIGNATURE,op,sig]]
      op is 'HasAttribute =>
        form := ["has",a := first r,['ATTRIBUTE,b := simpDevaluate second r]]
        simpHasAttribute(form,a,b)
      op in '(AND OR NOT) =>
        null (u := MKPF([simp p for p in r],op)) => nil
        u is '%true or u is '(QUOTE T) => true
        simpBool u
      op is 'hasArgs => ($hasArgs => $hasArgs = r; pred)
      null r and opOf op = "has" => simp first pred
      pred is '%true or pred is '(QUOTE T) => true
      op1 := symbolLassoc(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 substitute('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 := evalHas pred
    IDENTP npred or null hasIdent npred => npred
    pred
  evalHas (pred := ["has",d,cat]) ==
    x := hasCat(d,cat)
    y := rest 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 := symbolLassoc(op,getConstructorOperationsFromDB conname)
  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 := conform.op
  getConstructorKindFromDB conname is "category" =>
      simpCatHasAttribute(conform,attr)
  asharpConstructorName? conname =>
    p := LASSOC(attr,getConstructorAttributesFromDB conname) =>
      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(conform.args,
      getConstructorPredicatesFromDB conname)
  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 applySubst(pairList(conform.args,domform.args),pred)

hasIdent pred ==
  pred is [op,:r] =>
    op is 'QUOTE => false
    or/[hasIdent x for x in r]
  pred is '_$ => 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) ==
  tableValue(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
    getConstructorKindFromDB con is "category" =>
      addToCategoryTable con
  for id in HKEYS _*ANCESTORS_-HASH_* repeat
    item := tableValue(_*ANCESTORS_-HASH_*, id) 
    for (u:=[.,:b]) in item repeat
      u.rest := simpCatPredicate simpBool b
    tableValue(_*ANCESTORS_-HASH_*,id) := listSort(function GLESSEQP,item)

addToCategoryTable con ==
  -- adds an entry to $tempCategoryTable with key=con and alist entries
  u := getConstructorModemapFromDB(con).mmDC --domain
  alist := getCategoryExtensionAlist u
  tableValue(_*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 => u.rest := encodeUnion(id,first newEntry,rest u)
      if newEntry ~= rest u then
        p:= moreGeneralCategoryPredicate(id,newEntry,rest u) => u.rest := p
        sayMSG '"Duplicate entries:"
        PRINT [newEntry,rest u]
    newAl:= [[key,:newEntry],:newAl]
  newAl

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

moreGeneralCategoryPredicate(id,new,old) ==
  old is 'T or new is '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 getConstructorAncestorsFromDB first b]

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

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

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

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

mkCategoryExtensionAlist cform ==
  not cons? cform => nil
  cop := first cform
  builtinCategoryName? cop => mkCategoryExtensionAlistBasic cform
  catlist := formalSubstitute(cform, first getConstructorExports(cform, true))
  extendsList:= nil
  for [cat,:pred] in catlist repeat
    newList := getCategoryExtensionAlist0 cat
    finalList :=
      pred is '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 is '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
      u.rest := 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:= getConstructorAncestorsFromDB op) 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:= [y,:cats]
  cats:= reverse! 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 cons? z3 and
        constructor? first z3 then
          cats:= [['IF,quickAnd(["has",z1,z2], thePred),z3,'%noBranch],:cats]
      at is ['IF, pred, :.] =>
        cats := makeCatPred(at, cats, curPred)
  cats

getConstructorExports(conform,:options) == categoryParts(conform,
  getConstructorCategoryFromDB opOf conform,IFCAR options)

categoryParts(conform,category,:options) == main where
  main() ==
    addCtor? := 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 addCtor? then
      res := [listSort(function GLESSEQP,$conslist),:res]
    if getConstructorKindFromDB conname is "category" then
      tvl := TAKE(#rest conform,$TriangleVariableList)
      res := applySubst(pairList(tvl,$FormalMapVariableList),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 is '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]))
    null item => 'ok
    item is "%noBranch" => 'ok
    item is ['PROGN,:r] => for x in r repeat build(x,pred)
    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 := hashTable 'EQUAL
  for x in HKEYS ht repeat compressSexpr(tableValue(ht,x),nil,nil)
  sayBrightly   "done"
  ht

compressSexpr(x,left,right) ==
-- recursive version of compressHashTable
  atom x => nil
  u:= tableValue($found,x) =>
    left => left.first := u
    right => right.rest := u
    nil
  compressSexpr(first x,x,nil)
  compressSexpr(rest x,nil,x)
  tableValue($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:= first l
  y:=
    atom x => x
    z:= member(x,$found) => first z
    $found:= [x,:$found]
    squeeze1 x
  l.first := y
  x:= rest l
  y:=
    atom x => x
    z:= member(x,$found) => first z
    $found:= [x,:$found]
    squeeze1 x
  l.rest := y

updateCategoryTable(cname,kind) ==
  $updateCatTableIfTrue =>
    kind is 'package => nil
    kind is 'category => updateCategoryTableForCategory(cname)
    updateCategoryTableForDomain(cname,getConstrCat(
      getConstructorCategoryFromDB cname))
--+
  kind is 'domain =>
    updateCategoryTableForDomain(cname,getConstrCat(
      getConstructorCategoryFromDB cname))

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

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

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

clearCategoryTable1(key,val) ==
  (first key=$cname)=> tableRemove!(_*HASCATEGORY_-HASH_*,key)
  nil

clearTempCategoryTable(catNames) ==
  for key in HKEYS(_*ANCESTORS_-HASH_*) repeat
    symbolMember?(key,catNames) => nil
    extensions:= nil
    for (extension:= [catForm,:.]) in getConstructorAncestorsFromDB key
      repeat
        symbolMember?(first catForm,catNames) => nil
        extensions:= [extension,:extensions]
    tableValue(_*ANCESTORS_-HASH_*,key) := extensions