path: root/src/interp/br-data.boot

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

lefts u ==
   [x for x in HKEYS  _*HASCATEGORY_-HASH_* | rest x = u]



--====================> WAS b-data.boot <================================

--============================================================================
--              Build Library Database (libdb.text,...)
--============================================================================
--Formal for libdb.text:
--  constructors    Cname\#\I\sig \args   \abb \comments (C is C, D, P, X)
--  operations      Op  \#\E\sig \conname\pred\comments (E is one of U/E)
--  attributes      Aname\#\E\args\conname\pred\comments
--  I = <x if exposed><d if category with a default package>
buildLibdb(:options) ==  --called by buildDatabase (database.boot)
  domainList := IFCAR options  --build local libdb if list of domains is given
  $OpLst: local := nil
  $AttrLst: local := nil
  $DomLst : local := nil
  $CatLst : local := nil
  $PakLst : local := nil
  $DefLst : local := nil
  removeFile '"temp.text"
  $outStream: local := MAKE_-OUTSTREAM '"temp.text"
  if null domainList then
    comments :=
      '"\spad{Union(A,B,...,C)} is a primitive type in AXIOM used to represent objects of type \spad{A} or of type \spad{B} or...or of type \spad{C}."
    writedb
      buildLibdbString ['"dUnion",1,'"x",'"special",'"(A,B,...,C)",'union,comments]
    comments :=
      '"\spad{Record(a:A,b:B,...,c:C)} is a primitive type in AXIOM used to represent composite objects made up of objects of type \spad{A}, \spad{B},..., \spad{C} which are indexed by _"keys_" (identifiers) \spad{a},\spad{b},...,\spad{c}."
    writedb
      buildLibdbString ['"dRecord",1,'"x",'"special",'"(a:A,b:B,...,c:C)",'RECORD,comments]
    comments :=
      '"\spad{Mapping(T,S)} is a primitive type in AXIOM used to represent mappings from source type \spad{S} to target type \spad{T}. Similarly, \spad{Mapping(T,A,B)} denotes a mapping from source type \spad{(A,B)} to target type \spad{T}."
    writedb
      buildLibdbString ['"dMapping",1,'"x",'"special",'"(T,S)",'MAPPING,comments]
    comments :=
      '"\spad{Enumeration(a,b,...,c)} is a primitive type in AXIOM used to represent the object composed of the symbols \spad{a},\spad{b},..., and \spad{c}."
    writedb
      buildLibdbString ['"dEnumeration",1,'"x",'"special",'"(a,b,...,c)",'ENUM,comments]
  $conname: local := nil
  $conform: local := nil
  $exposed?:local := nil
  $doc:     local := nil
  $kind:    local := nil
  constructorList := domainList or allConstructors()
  for con in constructorList repeat
    writedb buildLibdbConEntry con
    [attrlist,:oplist] := getConstructorExports $conform
    buildLibOps oplist
    buildLibAttrs attrlist
  SHUT $outStream
  domainList => 'done         --leave new database in temp.text
  runCommand
    $machineType = 'RIOS => '"sort -f -T /tmp -y200 _"temp.text_"  > _"libdb.text_""
    $machineType = 'SPARC => '"sort -f  _"temp.text_"  > _"libdb.text_""
    '"sort  _"temp.text_"  > _"libdb.text_""
  renameFile('"libdb.text", '"olibdb.text")
  removeFile '"temp.text"

buildLibdbConEntry conname ==
    null getConstructorModemapFromDB conname => nil
    abb:= getConstructorAbbreviationFromDB conname
    $conname := conname
    conform := getConstructorFormFromDB conname or [conname] --hack for Category,..
    $conform := dbMkForm substitute('T,"T$",conform)
    null $conform => nil
    $exposed? := (isExposedConstructor conname => '"x"; '"n")
    $doc      := getConstructorDocumentationFromDB conname
    pname := PNAME conname
    kind  := getConstructorKindFromDB conname
    if kind = 'domain
      and getConstructorModemapFromDB conname is [[.,t,:.],:.]
       and t is ['CATEGORY,'package,:.] then kind := 'package
    $kind :=
      pname.(MAXINDEX pname) = char '_& => 'x
      DOWNCASE PNAME(kind).0
    argl := rest $conform
    conComments :=
      LASSOC('constructor,$doc) is [[=nil,:r]] => libdbTrim concatWithBlanks r
      '""
    argpart:= SUBSTRING(form2HtString ['f,:argl],1,nil)
    sigpart:= libConstructorSig $conform
    header := strconc($kind,PNAME conname)
    buildLibdbString [header,#argl,$exposed?,sigpart,argpart,abb,conComments]

dbMkForm x == atom x and [x] or x

buildLibdbString [x,:u] ==
  strconc(STRINGIMAGE x,strconc/[strconc('"`",STRINGIMAGE y) for y in u])

libConstructorSig [conname,:argl] ==
  [[.,:sig],:.] := getConstructorModemapFromDB conname
  formals := TAKE(#argl,$FormalMapVariableList)
  sig := SUBLISLIS(formals,$TriangleVariableList,sig)
  keys := [g(f,sig,i) for f in formals for i in 1..] where
    g(x,u,i) ==  --does x appear in any but i-th element of u?
      or/[CONTAINED(x,y) for y in u for j in 1.. | j ~= i]
  sig := fn SUBLISLIS(argl,$FormalMapVariableList,sig) where
    fn x ==
      atom x => x
      x is ['Join,a,:r] => ['Join,fn a,'etc]
      x is ['CATEGORY,:.] => 'etc
      [fn y for y in x]
  sig := [first sig,:[(k => [":",a,s]; s)
            for a in argl for s in rest sig for k in keys]]
  sigpart:= form2LispString ['Mapping,:sig]
  if null ncParseFromString sigpart then
    sayBrightly ['"Won't parse: ",sigpart]
  sigpart

concatWithBlanks r ==
  r is [head,:tail] =>
    tail => strconc(head,'" ",concatWithBlanks tail)
    head
  '""

writedb(u) ==
  not string? u => nil        --skip if not a string
  PRINTEXP(addPatchesToLongLines(u,500),$outStream)
  --positions for tick(1), dashes(2), and address(9), i.e. 12
  TERPRI $outStream

addPatchesToLongLines(s,n) ==
  #s > n => strconc(SUBSTRING(s,0,n),
              addPatchesToLongLines(strconc('"--",SUBSTRING(s,n,nil)),n))
  s

buildLibOps oplist == for [op,sig,:pred] in oplist repeat buildLibOp(op,sig,pred)

buildLibOp(op,sig,pred) ==
--operations      OKop  \#\sig \conname\pred\comments (K is U or C)
  nsig := SUBLISLIS(rest $conform,$FormalMapVariableList,sig)
  pred := SUBLISLIS(rest $conform,$FormalMapVariableList,pred)
  nsig := substitute('T,"T$",nsig)   --this ancient artifact causes troubles!
  pred := substitute('T,"T$",pred)
  sigpart:= form2LispString ['Mapping,:nsig]
  predString := (pred = 'T => '""; form2LispString pred)
  sop :=
    (s := STRINGIMAGE op) = '"One" => '"1"
    s = '"Zero" => '"0"
    s
  header := strconc('"o",sop)
  conform:= strconc($kind,form2LispString $conform)
  comments:= libdbTrim concatWithBlanks LASSOC(sig,LASSOC(op,$doc))
  checkCommentsForBraces('operation,sop,sigpart,comments)
  writedb
    buildLibdbString [header,# rest sig,$exposed?,sigpart,conform,predString,comments]

libdbTrim s ==
  k := MAXINDEX s
  k < 0 => s
  for i in 0..k repeat
    s.i = $Newline => s.i := char " "
  trimString s

checkCommentsForBraces(kind,sop,sigpart,comments) ==
  count := 0
  for i in 0..MAXINDEX comments repeat
    c := comments.i
    c = char '_{ => count := count + 1
    c = char '_} =>
      count := count - 1
      count < 0 => missingLeft := true
  if count < 0 or missingLeft then
    tail :=
      kind = 'attribute => [sop,'"(",sigpart,'")"]
      [sop,'": ",sigpart]
    sayBrightly ['"(",$conname,'" documentation) missing left brace--> ",:tail]
  if count > 0 then
    sayBrightly ['"(",$conname,'" documentation) missing right brace--> ",:tail]
  if count ~= 0 or missingLeft then pp comments

buildLibAttrs attrlist ==
  for [name,argl,:pred] in attrlist repeat buildLibAttr(name,argl,pred)

buildLibAttr(name,argl,pred) ==
--attributes      AKname\#\args\conname\pred\comments (K is U or C)
  header := strconc('"a",STRINGIMAGE name)
  argPart:= SUBSTRING(form2LispString ['f,:argl],1,nil)
  pred := SUBLISLIS(rest $conform,$FormalMapVariableList,pred)
  predString := (pred = 'T => '""; form2LispString pred)
  header := strconc('"a",STRINGIMAGE name)
  conname := strconc($kind,form2LispString $conname)
  comments:= concatWithBlanks LASSOC(['attribute,:argl],LASSOC(name,$doc))
  checkCommentsForBraces('attribute,STRINGIMAGE name,argl,comments)
  writedb
    buildLibdbString [header,# argl,$exposed?,argPart,conname,predString,comments]

dbAugmentConstructorDataTable() ==
  instream := MAKE_-INSTREAM '"libdb.text"
  while not EOFP instream repeat
    fp   := FILE_-POSITION instream
    line := READLINE instream
    cname := INTERN dbName line
    entry := getCDTEntry(cname,true) =>  --skip over Mapping, Union, Record
       [name,abb,:.] := entry
       entry.rest.rest := PUTALIST(CDDR entry,'dbLineNumber,fp)
--     if xname := constructorHasExamplePage entry then
--       entry.rest := PUTALIST(CDDR entry,'dbExampleFile,xname)
       args := IFCDR getConstructorFormFromDB name
       if args then 
         entry.rest.rest := PUTALIST(CDDR entry,'constructorArgs,args)
  'done

dbHasExamplePage conname ==
  sname    := STRINGIMAGE conname
  abb      := constructor? conname
  ucname   := UPCASE STRINGIMAGE abb
  pathname :=strconc(systemRootDirectory(),'"/share/hypertex/pages/",ucname,'".ht")
  isExistingFile pathname => INTERN strconc(sname,'"XmpPage")
  nil

dbRead(n) ==
  instream := MAKE_-INSTREAM strconc(systemRootDirectory(), '"/algebra/libdb.text")
  FILE_-POSITION(instream,n)
  line := READLINE instream
  SHUT instream
  line

dbReadComments(n) ==
  n = 0 => '""
  instream := MAKE_-INSTREAM strconc(systemRootDirectory(),'"/algebra/comdb.text")
  FILE_-POSITION(instream,n)
  line := READLINE instream
  k := dbTickIndex(line,1,1)
  line := SUBSTRING(line,k + 1,nil)
  while not EOFP instream and (x := READLINE instream) and
    (k := MAXINDEX x) and (j := dbTickIndex(x,1,1)) and (j < k) and
      x.(j := j + 1) = char '_- and x.(j := j + 1) = char '_- repeat
        xtralines := [SUBSTRING(x,j + 1,nil),:xtralines]
  SHUT instream
  strconc(line, strconc/nreverse xtralines)

dbSplitLibdb() ==
  instream := MAKE_-INSTREAM  '"olibdb.text"
  outstream:= MAKE_-OUTSTREAM '"libdb.text"
  comstream:= MAKE_-OUTSTREAM '"comdb.text"
  PRINTEXP(0,    comstream)
  PRINTEXP($tick,comstream)
  PRINTEXP('"",  comstream)
  TERPRI(comstream)
  while not EOFP instream repeat
    line := READLINE instream
    outP := FILE_-POSITION outstream
    comP := FILE_-POSITION comstream
    [prefix,:comments] := dbSplit(line,6,1)
    PRINTEXP(prefix,outstream)
    PRINTEXP($tick ,outstream)
    null comments =>
      PRINTEXP(0,outstream)
      TERPRI(outstream)
    PRINTEXP(comP,outstream)
    TERPRI(outstream)
    PRINTEXP(outP  ,comstream)
    PRINTEXP($tick ,comstream)
    PRINTEXP(first comments,comstream)
    TERPRI(comstream)
    for c in rest comments repeat
      PRINTEXP(outP  ,comstream)
      PRINTEXP($tick ,comstream)
      PRINTEXP(c, comstream)
      TERPRI(comstream)
  SHUT instream
  SHUT outstream
  SHUT comstream
  removeFile '"olibdb.text"

dbSplit(line,n,k) ==
  k := charPosition($tick,line,k + 1)
  n = 1 => [SUBSTRING(line,0,k),:dbSpreadComments(SUBSTRING(line,k + 1,nil),0)]
  dbSplit(line,n - 1,k)

dbSpreadComments(line,n) ==
  line = '"" => nil
  k := charPosition(char '_-,line,n + 2)
  k >= MAXINDEX line => [SUBSTRING(line,n,nil)]
  line.(k + 1) ~= char '_- =>
    u := dbSpreadComments(line,k)
    [strconc(SUBSTRING(line,n,k - n),first u),:rest u]
  [SUBSTRING(line,n,k - n),:dbSpreadComments(SUBSTRING(line,k,nil),0)]

--============================================================================
--                  Build Glossary
--============================================================================
buildGloss() ==  --called by buildDatabase (database.boot)
--starting with gloss.text, build glosskey.text and glossdef.text
  $constructorName : local := nil
  $exposeFlag : local := true
  $outStream: local := MAKE_-OUTSTREAM '"temp.text"
  $x : local := nil
  $attribute? : local := true     --do not surround first word
  pathname := strconc(systemRootDirectory(),'"doc/gloss.text")
  instream := MAKE_-INSTREAM pathname
  keypath  := '"glosskey.text"
  removeFile keypath
  outstream:= MAKE_-OUTSTREAM keypath
  htpath   := '"gloss.ht"
  removeFile htpath
  htstream:= MAKE_-OUTSTREAM htpath
  defpath  := '"glossdef.text"
  defstream:= MAKE_-OUTSTREAM defpath
  pairs := getGlossLines instream
  PRINTEXP('"\begin{page}{GlossaryPage}{G l o s s a r y}\beginscroll\beginmenu",htstream)
  for [name,:line] in pairs repeat
    outP  := FILE_-POSITION outstream
    defP  := FILE_-POSITION defstream
    lines := spreadGlossText transformAndRecheckComments(name,[line])
    PRINTEXP(name, outstream)
    PRINTEXP($tick,outstream)
    PRINTEXP(defP, outstream)
    TERPRI(outstream)
--  PRINTEXP('"\item\newline{\em \menuitemstyle{}}\tab{0}{\em ",htstream)
    PRINTEXP('"\item\newline{\em \menuitemstyle{}}{\em ",htstream)
    PRINTEXP(name,        htstream)
    PRINTEXP('"}\space{}",htstream)
    TERPRI(htstream)
    for x in lines repeat
      PRINTEXP(outP, defstream)
      PRINTEXP($tick,defstream)
      PRINTEXP(x,    defstream)
      TERPRI defstream
    PRINTEXP(strconc/lines,htstream)
    TERPRI htstream
  PRINTEXP('"\endmenu\endscroll",htstream)
  PRINTEXP('"\lispdownlink{Search}{(|htGloss| _"\stringvalue{pattern}_")} for glossary entry matching \inputstring{pattern}{24}{*}",htstream)
  PRINTEXP('"\end{page}",htstream)
  SHUT instream
  SHUT outstream
  SHUT defstream
  SHUT htstream
  SHUT $outStream

spreadGlossText(line) ==
--this function breaks up a line into chunks
--eventually long line is put into gloss.text as several chunks as follows:
----- key1`this is the first chunk
----- XXX`and this is the second
----- XXX`and this is the third
----- key2`and this is the fourth
--where XXX is the file position of key1
--this is because grepping will only pick up the first 512 characters
  line = '"" => nil
  MAXINDEX line > 500 => [SUBSTRING(line,0,500),:spreadGlossText(SUBSTRING(line,500,nil))]
  [line]

getGlossLines instream ==
--instream has text of the form:
----- key1`this is the first line
----- and this is the second
----- key2'and this is the third
--result is
----- key1'this is the first line and this is the second
----- key2'and this is the third
  keys := nil
  text := nil
  lastLineHadTick := false
  while not EOFP instream repeat
    line := READLINE instream
    #line = 0 => 'skip
    n := charPosition($tick,line,0)
    last := IFCAR text
    n > MAXINDEX line =>  --this line is continuation of previous line; concat it
      fill :=
        #last = 0 =>
          lastLineHadTick => '""
          '"\blankline "
        #last > 0 and last.(MAXINDEX last) ~= $charBlank => $charBlank
        '""
      lastLineHadTick := false
      text := [strconc(last,fill,line),:rest text]
    lastLineHadTick := true
    keys := [SUBSTRING(line,0,n),:keys]
    text := [SUBSTRING(line,n + 1,nil),:text]
  ASSOCRIGHT listSort(function GLESSEQP,[[DOWNCASE key,key,:def] for key in keys for def in text])
  --this complication sorts them after lower casing the keys

--============================================================================
--                  Build Users HashTable
-- This database is written out as USERS.DATABASE (database.boot) and read using
-- function getUsersOfConstructor. See functions whoUses and kcuPage in browser.
--============================================================================
mkUsersHashTable() ==  --called by buildDatabase (database.boot)
  $usersTb := MAKE_-HASH_-TABLE()
  for x in allConstructors() repeat
    for conform in getImports x repeat
      name := opOf conform
      if not (name in '(QUOTE)) then
        HPUT($usersTb,name,insert(x,HGET($usersTb,name)))
  for k in HKEYS $usersTb repeat
    HPUT($usersTb,k,listSort(function GLESSEQP,HGET($usersTb,k)))
  for x in allConstructors() | isDefaultPackageName x repeat
    HPUT($usersTb,x,getDefaultPackageClients x)
  $usersTb

getDefaultPackageClients con ==  --called by mkUsersHashTable
  catname := INTERN SUBSTRING(s := PNAME con,0,MAXINDEX s)
  for [catAncestor,:.] in childrenOf([catname]) repeat
    pakname := INTERN strconc(PNAME catAncestor,'"&")
    if getCDTEntry(pakname,true) then acc := [pakname,:acc]
    acc := union([CAAR x for x in domainsOf([catAncestor],nil)],acc)
  listSort(function GLESSEQP,acc)

--============================================================================
--               Build Dependents Hashtable
-- This hashtable is written out by database.boot as DEPENDENTS.DATABASE
-- and read back in by getDependentsOfConstructor (see database.boot)
-- This information is used by function kcdePage when a user asks for the
-- dependents of a constructor.
--============================================================================
mkDependentsHashTable() == --called by buildDatabase (database.boot)
  $depTb := MAKE_-HASH_-TABLE()
  for nam in allConstructors() repeat
    for con in getArgumentConstructors nam repeat
      HPUT($depTb,con,[nam,:HGET($depTb,con)])
  for k in HKEYS $depTb repeat
    HPUT($depTb,k,listSort(function GLESSEQP,HGET($depTb,k)))
  $depTb

getArgumentConstructors con == --called by mkDependentsHashTable
  argtypes := IFCDR IFCAR getConstructorModemapFromDB con or return nil
  fn argtypes where
    fn(u) == "union"/[gn x for x in u]
    gn(x) ==
      atom x => nil
      x is ['Join,:r] => fn(r)
      x is ['CATEGORY,:.] => nil
      constructor? first x => [first x,:fn rest x]
      fn rest x

getImports conname == --called by mkUsersHashTable
  conform := getConstructorFormFromDB conname
  infovec := dbInfovec conname or return nil
  template := infovec.0
  u := [doImport(i,template)
          for i in 5..(MAXINDEX template) | test]  where
    test() == template.i is [op,:.] and IDENTP op
              and not (op in '(Mapping Union Record Enumeration CONS QUOTE local))
    doImport(x,template) ==
      x is [op,:args] =>
        op = 'QUOTE or op = 'NRTEVAL => first args
        op = 'local => first args
        op = 'Record =>
          ['Record,:[[":",second y,doImport(third y,template)] for y in args]]

--TTT next three lines: handles some tagged/untagged Union case.
        op = 'Union=>
          args is [['_:,:x1],:x2] =>
--          CAAR args = '_: => -- tagged!
               ['Union,:[[":",second y,doImport(third y,template)] for y in args]]
          [op,:[doImport(y,template) for y in args]]

        [op,:[doImport(y,template) for y in args]]
      integer? x => doImport(template.x,template)
      x = '$ => '$
      x = "$$" => "$$"
      string? x => x
      systemError '"bad argument in template"
  listSort(function GLESSEQP,SUBLISLIS(rest conform,$FormalMapVariableList,u))


--============================================================================
--                 Get Hierarchical Information
--============================================================================
getParentsFor(cname,formalParams,constructorCategory) ==
--called by compDefineFunctor1
  acc := nil
  formals := TAKE(#formalParams,$TriangleVariableList)
  constructorForm := getConstructorFormFromDB cname
  for x in folks constructorCategory repeat
    x := SUBLISLIS(formalParams,formals,x)
    x := SUBLISLIS(IFCDR constructorForm,formalParams,x)
    x := substitute('Type,'Object,x)
    acc := [:explodeIfs x,:acc]
  nreverse acc

$parentsCache := nil

parentsOf con == --called by kcpPage, ancestorsRecur
  if null $parentsCache then 
     $parentsCache := hashTable 'EQ
  HGET($parentsCache,con) or
    parents := getParentsForDomain con
    HPUT($parentsCache,con,parents)
    parents

parentsOfForm [op,:argl] ==
  parents := parentsOf op
  null argl or argl = (newArgl := rest getConstructorFormFromDB op) =>
    parents
  SUBLISLIS(argl, newArgl, parents)

getParentsForDomain domname  == --called by parentsOf
  acc := nil
  for x in folks getConstructorCategoryFromDB domname repeat
    x :=
      getConstructorKindFromDB domname = "category" =>
        sublisFormal(IFCDR getConstructorForm domname,x,$TriangleVariableList)
      sublisFormal(IFCDR getConstructorForm domname,x)
    acc := [:explodeIfs x,:acc]
  nreverse acc

explodeIfs x == main where  --called by getParents, getParentsForDomain
  main() ==
    x is ['IF,p,a,b] => fn(p,a,b)
    [[x,:true]]
  fn(p,a,b) ==
    [:"append"/[gn(p,y) for y in a],:"append"/[gn(['NOT,p],y) for y in b]]
  gn(p,a) ==
    a is ['IF,q,b,:.] => fn(MKPF([p,q],'AND),b,nil)
    [[a,:p]]

folks u == --called by getParents and getParentsForDomain
  atom u => nil
  u is [op,:v] and op in '(Join PROGN)
    or u is ['CATEGORY,a,:v] => "append"/[folks x for x in v]
  u is ['SIGNATURE,:.] => nil
  u is ['TYPE,:.] => nil
  u is ['ATTRIBUTE,a] =>
    cons? a and constructor? opOf a => folks a
    nil
  u is ['IF,p,q,r] =>
    q1 := folks q
    r1 := folks r
    q1 or r1 => [['IF,p,q1,r1]]
    nil
  [u]

descendantsOf(conform,domform) ==  --called by kcdPage
  "category" = getConstructorKindFromDB(conname := opOf conform) =>
    cats := catsOf(conform,domform)
    [op,:argl] := conform
    null argl or argl = (newArgl := rest getConstructorFormFromDB op)
        => cats
    SUBLISLIS(argl, newArgl, cats)
  'notAvailable

childrenOf conform ==
  [pair for pair in descendantsOf(conform,nil) |
    childAssoc(conform,parentsOfForm first pair)]

childAssoc(form,alist) ==
  null (argl := rest form) => assoc(form,alist)
  u := assocCar(opOf form, alist) => childArgCheck(argl,rest first u) and u
  nil

assocCar(x, al) == or/[pair for pair in al | x = CAAR pair]

childArgCheck(argl, nargl) ==
  and/[fn for x in argl for y in nargl for i in 0..] where
    fn() ==
      x = y or constructor? opOf y => true
      isSharpVar y => i = POSN1(y, $FormalMapVariableList)
      false

--computeDescendantsOf cat ==
--dynamically generates descendants
--  hash := hashTable 'EQUAL
--  for [child,:pred] in childrenOf cat repeat
--    childForm := getConstructorForm child
--    HPUT(hash,childForm,pred)
--    for [form,:pred] in descendantsOf(childForm,nil) repeat
--      newPred :=
--        oldPred := HGET(hash,form) => quickOr(oldPred,pred)
--        pred
--      HPUT(hash,form,newPred)
--  mySort [[key,:HGET(hash,key)] for key in HKEYS hash]

ancestorsOf(conform,domform) ==  --called by kcaPage, originsInOrder,...
  "category" = getConstructorKindFromDB(conname := opOf conform) =>
       alist := getConstructorAncestorsFromDB conname
       argl := IFCDR domform or IFCDR conform
       [pair for [a,:b] in alist | pair] where pair() ==
         left :=  sublisFormal(argl,a)
         right := sublisFormal(argl,b)
         if domform then right := simpHasPred right
         null right => false
         [left,:right]
  computeAncestorsOf(conform,domform)

computeAncestorsOf(conform,domform) ==
  $done: local := hashTable 'EQUAL
  $if:   local := hashTable 'EQ
  ancestorsRecur(conform,domform,true,true)
  acc := nil
  for op in listSort(function GLESSEQP,HKEYS $if) repeat
    for pair in HGET($if,op) repeat acc := [pair,:acc]
  nreverse acc

ancestorsRecur(conform,domform,pred,firstTime?) == --called by ancestorsOf
  op      := opOf conform
  pred = HGET($done,conform) => nil   --skip if already processed
  parents :=
    firstTime? and ($insideCategoryIfTrue or $insideFunctorIfTrue) =>
      $lisplibParents
    parentsOf op
  originalConform :=
    firstTime? and ($insideCategoryIfTrue or $insideFunctorIfTrue) => $form
    getConstructorForm op
  if conform ~= originalConform then
    parents := SUBLISLIS(IFCDR conform,IFCDR originalConform,parents)
  for [newform,:p] in parents repeat
    if domform and rest domform then
      newdomform := SUBLISLIS(rest domform,rest conform,newform)
      p          := SUBLISLIS(rest domform,rest conform,p)
    newPred := quickAnd(pred,p)
    ancestorsAdd(simpHasPred newPred,newdomform or newform)
    ancestorsRecur(newform,newdomform,newPred,false)
  HPUT($done,conform,pred)                  --mark as already processed

ancestorsAdd(pred,form) == --called by ancestorsRecur
  null pred => nil
  op := IFCAR form or form
  alist := HGET($if,op)
  existingNode := assoc(form,alist) =>
    existingNode.rest := quickOr(rest existingNode,pred)
  HPUT($if,op,[[form,:pred],:alist])

domainsOf(conform,domname,:options) ==
  $hasArgList := IFCAR options
  conname := opOf conform
  u := [key for key in HKEYS _*HASCATEGORY_-HASH_*
    | key is [anc,: =conname]]
  --u is list of pairs (a . b) where b() = conname
  --we sort u then replace each b by the predicate for which this is true
  s := listSort(function GLESSEQP,COPY u)
  s := [[first pair,:constructorHasCategoryFromDB pair] for pair in s]
  transKCatAlist(conform,domname,listSort(function GLESSEQP,s))

catsOf(conform,domname,:options) ==
  $hasArgList := IFCAR options
  conname := opOf conform
  alist := nil
  for key in allConstructors() repeat
    for item in getConstructorAncestorsFromDB key | conname = CAAR item repeat
      [[op,:args],:pred] := item
      newItem :=
        args => [[args,:pred],:LASSOC(key,alist)]
        pred
      alist := insertShortAlist(key,newItem,alist)
  transKCatAlist(conform,domname,listSort(function GLESSEQP,alist))

transKCatAlist(conform,domname,s) == main where
  main() ==
    domname => --accept only exact matches after substitution
      domargs := rest domname
      acc := nil
      rest conform =>
        for pair in s repeat --pair has form [con,[conargs,:pred],...]]
          leftForm := getConstructorForm first pair
          for (ap := [args,:pred]) in rest pair repeat
            match? :=
              domargs = args => true
              HAS__SHARP__VAR args => domargs = sublisFormal(KDR domname,args)
              nil
            null match? => 'skip
            npred := sublisFormal(KDR leftForm,pred)
            acc := [[leftForm,:npred],:acc]
        nreverse acc
      --conform has no arguments so each pair has form [con,:pred]
      for pair in s repeat
        leftForm := getConstructorForm first pair or systemError nil
        pair.first := leftForm
        pair.rest := sublisFormal(KDR leftForm,rest pair)
      s
    --no domname, so look for special argument combinations
    acc := nil
    KDR conform =>
      farglist := TAKE(#rest conform,$FormalMapVariableList)
      for pair in s repeat --pair has form [con,[conargs,:pred],...]]
        leftForm := getConstructorForm first pair
        for (ap := [args,:pred]) in rest pair repeat
          hasArgsForm? := args ~= farglist
          npred := sublisFormal(KDR leftForm,pred)
          if hasArgsForm? then
            subargs := sublisFormal(KDR leftForm,args)
            hpred :=
--            $hasArgsList => mkHasArgsPred subargs
              ['hasArgs,:subargs]
            npred := quickAnd(hpred,npred)
          acc := [[leftForm,:npred],:acc]
      nreverse acc
    for pair in s repeat --pair has form [con,:pred]
      leftForm := getConstructorForm first pair
      pair.first := leftForm
      pair.rest := sublisFormal(KDR leftForm,rest pair)
    s

mkHasArgsPred subargs ==
--$hasArgsList gives arguments of original constructor,e.g. LODO(A,M)
--M is required to be Join(B,...); in looking for the domains of B
--  we can find that if B has special value C, it can
  systemError subargs

sublisFormal(args,exp,:options) == main where
  main() ==  --use only on LIST structures; see also sublisFormalAlist
    $formals: local := IFCAR options or $FormalMapVariableList
    null args => exp
    sublisFormal1(args,exp,#args - 1)
  sublisFormal1(args,x,n) ==    --[sublisFormal1(args,y) for y in x]
    x is [.,:.] =>
      acc := nil
      y := x
      while null atom y repeat
        acc := [sublisFormal1(args,QCAR y,n),:acc]
        y := QCDR y
      r := nreverse acc
      if y then
        nd := LASTNODE r
        nd.rest := sublisFormal1(args,y,n)
      r
    IDENTP x =>
      j := or/[i for f in $formals for i in 0..n | EQ(f,x)] =>
          args.j
      x
    x

--=======================================================================
--            Build Table of Lower Case Constructor Names
--=======================================================================

buildDefaultPackageNamesHT() ==
  $defaultPackageNamesHT := MAKE_-HASH_-TABLE()
  for nam in allConstructors() | isDefaultPackageName nam repeat
    HPUT($defaultPackageNamesHT,nam,true)
  $defaultPackageNamesHT

$defaultPackageNamesHT := buildDefaultPackageNamesHT()

--=======================================================================
--            Code for Private Libdbs
--=======================================================================
-- $createLocalLibDb := false

extendLocalLibdb conlist ==   --  called by astran
  not $createLocalLibDb => nil
  null conlist => nil
  buildLibdb conlist          --> puts datafile into temp.text
  $newConstructorList := union(conlist, $newConstructorList)
  localLibdb := '"libdb.text"
  not PROBE_-FILE '"libdb.text" =>
    RENAME_-FILE('"temp.text",'"libdb.text")
  oldlines := purgeNewConstructorLines(dbReadLines localLibdb, conlist)
  newlines := dbReadLines '"temp.text"
  dbWriteLines(MSORT union(oldlines,newlines), '"libdb.text")
  removeFile '"temp.text"