path: root/src/interp/cattable.boot

-- Copyright (C) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2013, 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 [[a,:b],:val] in entries $HasCategoryTable
     | symbolEq?(a,con) and val ~= nil]

displayCategoryTable(:options) ==
  conList := IFCAR options
  SETQ($ct,hashTable 'EQ)
  for [[a,:b],:val] in entries $HasCategoryTable repeat
    tableValue($ct,a) := [[b,:val],:tableValue($ct,a)]
  for [id,:val] in entries $ct | null conList or symbolMember?(id,conList) repeat
    sayMSG [:bright id,'"extends:"]
    PRINT val

generateCategoryTable ancestors ==
  $HasCategoryTable := makeTable function EQUAL
  generateAncestorCategoryTable ancestors
  domainTable :=
    [addDomainToTable(con,getConstrCat getConstructorCategory con)
      for con in allConstructors() | not builtinFunctorName? con
        and 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 | id ~= 'Cross], :domainTable]
  for [id,:entry] in domainTable repeat
    for [a,:b] in encodeCategoryAlist(id,entry) repeat
      tableValue($HasCategoryTable,[id,:a]) := b
  simplifyAncestorCategoryTable ancestors
  simpCategoryTable()

simplifyAncestorCategoryTable ancestors ==
  for [id,:.] in entries ancestors repeat
    for u in getConstructorAncestorsFromDB id repeat
      u.rest := simpHasPred rest u

simpCategoryTable() ==
  for [key,:entry] in entries $HasCategoryTable repeat
    null entry => tableRemove!($HasCategoryTable,key)
    change :=
      opOf entry isnt [.,:.] => simpHasPred entry
      [[x,:npred] for [x,:pred] in entry | npred := simpHasPred pred]
    tableValue($HasCategoryTable,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 := symbolTarget(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)
    ident? a or hasIdent b => pred
    npred := evalHas pred
    ident? 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
  ident? conform => pred
  [conname,:args] := conform
  n := #sig
  u := symbolTarget(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
  ident? conform => pred
  conname := conform.op
  getConstructorKindFromDB conname is "category" =>
      simpCatHasAttribute(conform,attr)
  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,
      getConstructorPredicates conname)
  simpHasPred predvec.(k - 1)

simpCatHasAttribute(domform,attr) ==
  conform := getConstructorForm opOf domform
  catval :=  eval mkEvalable conform
  if KDR attr isnt [.,:.] 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
  ident? 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
          [[cat1,:true],:getCategoryExtensionAlist cat1]]
      alist:= [:alist,:newAlist]
    alist:= [:alist,[cat,:true],:getCategoryExtensionAlist cat]
  [id,:alist]

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

generateAncestorCategoryTable ancestors ==
  --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(ancestors,con)
  for [id,:item] in entries ancestors repeat
    for u in item repeat
      u.rest := simpCatPredicate simpBool rest u
    tableValue(ancestors,id) := listSort(function GLESSEQP,item)

addToCategoryTable(ancestors,con) ==
  -- adds an entry to $tempCategoryTable with key=con and alist entries
  u := getConstructorModemap(con).mmDC --domain
  alist := getCategoryExtensionAlist u
  tableValue(ancestors,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]

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

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

isFormalArgumentList argl ==
  and/[symbolEq?(x,fa) for x in argl for fa in $FormalMapVariableList]

mkCategoryExtensionAlist cform ==
  not cons? cform => nil
  cop := cform.op
  builtinCategoryName? cop => mkCategoryExtensionAlistBasic cform
  catlist := formalSubstitute(cform, first getConstructorExports(cform, true))
  extendsList:= nil
  for [cat,:pred] in catlist repeat
    newList := [[cat,:true],:getCategoryExtensionAlist 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 := cform.op
  category :=      -- changed by RSS on 7/29/87
    macrop cop => eval cform
    apply(cop, cform.args)
  extendsList := [[x,:'T] for x in categoryPrincipals category]
  for [cat,pred,:.] in categoryAncestors category repeat
    newList := [[cat,:true],:getCategoryExtensionAlist cat]
    finalList :=
      pred = true => 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? z3.op 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,
  getConstructorCategory 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(#conform.args,$TriangleVariableList)
      res := applySubst(pairList(tvl,$FormalMapVariableList),res)
    res
  build(item,pred) ==
    item is ['SIGNATURE,op,sig,:.] => $oplist := [[op,sig,:pred],:$oplist]
    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,:y] in entries ht repeat compressSexpr(y,nil,nil)
  sayBrightly   "done"
  ht

compressSexpr(x,left,right) ==
-- recursive version of compressHashTable
  x isnt [.,:.] => 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

updateCategoryTable(cname,kind) ==
  kind is 'domain =>
    updateCategoryTableForDomain(cname,getConstrCat(
      getConstructorCategory cname))

updateCategoryTableForDomain(cname,category) ==
  clearCategoryTable(cname)
  [cname,:domainEntry]:= addDomainToTable(cname,category)
  for [a,:b] in encodeCategoryAlist(cname,domainEntry) repeat
    tableValue($HasCategoryTable,[cname,:a]) := b

clearCategoryTable($cname) ==
  MAPHASH('clearCategoryTable1,$HasCategoryTable)

clearCategoryTable1(key,val) ==
  key.op = $cname => tableRemove!($HasCategoryTable,key)
  nil