Initial population.

1 files changed, 527 insertions, 0 deletions

diff --git a/src/interp/cattable.boot.pamphlet b/src/interp/cattable.boot.pamphlet
new file mode 100644
index 00000000..d25eaf80
--- /dev/null
+++ b/src/interp/cattable.boot.pamphlet
@@ -0,0 +1,527 @@
+\documentclass{article}
+\usepackage{axiom}
+
+\title{\File{src/interp cattable.boot} Pamphlet}
+\author{The Axiom Team}
+
+\begin{document}
+\maketitle
+\begin{abstract}
+\end{abstract}
+\eject
+\tableofcontents
+\eject
+
+\section{License}
+
+<<license>>=
+-- 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.
+
+@
+<<*>>=
+<<license>>
+
+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) ==
+  $newcompMode = true => nil
+  $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)
+
+
+
+
+
+
+
+
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}