1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
2-- All rights reserved.
3--
4-- Redistribution and use in source and binary forms, with or without
5-- modification, are permitted provided that the following conditions are
6-- met:
7--
8--     - Redistributions of source code must retain the above copyright
9--       notice, this list of conditions and the following disclaimer.
10--
11--     - Redistributions in binary form must reproduce the above copyright
12--       notice, this list of conditions and the following disclaimer in
13--       the documentation and/or other materials provided with the
14--       distribution.
15--
16--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
17--       names of its contributors may be used to endorse or promote products
18--       derived from this software without specific prior written permission.
19--
20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31
32)package "BOOT"
33
34lefts u ==
35   [x for x in HKEYS  $has_category_hash | rest x = u]
36
37
38--============================================================================
39--              Build Library Database (libdb.text,...)
40--============================================================================
41--Format for libdb.text:
42--  constructors    Cname\#\I\sig \args   \abb \comments (C is C, D, P, X)
43--  operations      Op  \#\E\sig \conname\pred\comments (E is one of U/E)
44--  I = <x if exposed><d if category with a default package>
45buildLibdb(domainList) ==  --called by make-databases (daase.lisp)
46  $OpLst: local := nil
47  $AttrLst: local := nil
48  $DomLst : local := nil
49  $CatLst : local := nil
50  $PakLst : local := nil
51  $DefLst : local := nil
52  $outStream : local := MAKE_OUTSTREAM('"temp.text")
53  --build local libdb if list of domains is given
54  if null domainList then
55    comments :=
56      '"\spad{Union(A,B,...,C)} is a primitive type in FriCAS used to represent objects of type \spad{A} or of type \spad{B} or...or of type \spad{C}."
57    writedb
58      buildLibdbString ['"dUnion",1,'"x",'"special",'"(A,B,...,C)",'UNION,comments]
59    comments :=
60      '"\spad{Record(a:A,b:B,...,c:C)} is a primitive type in FriCAS 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}."
61    writedb
62      buildLibdbString ['"dRecord",1,'"x",'"special",'"(a:A,b:B,...,c:C)",'RECORD,comments]
63    comments :=
64      '"\spad{Mapping(T,S)} is a primitive type in FriCAS 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}."
65    writedb
66      buildLibdbString ['"dMapping",1,'"x",'"special",'"(T,S)",'MAPPING,comments]
67    comments :=
68      '"\spad{Enumeration(a,b,...,c)} is a primitive type in FriCAS used to represent the object composed of the symbols \spad{a},\spad{b},..., and \spad{c}."
69    writedb
70      buildLibdbString ['"dEnumeration",1,'"x",'"special",'"(a,b,...,c)",'ENUM,comments]
71  $conname: local := nil
72  $conform: local := nil
73  $exposed?:local := nil
74  $doc:     local := nil
75  $kind:    local := nil
76  constructorList := domainList or allConstructors()
77  for con in constructorList repeat
78    writedb buildLibdbConEntry con
79    [., :oplist] := getConstructorExports($conform, false)
80    buildLibOps oplist
81  SHUT $outStream
82  domainList => 'done         --leave new database in temp.text
83  OBEY '"sort  _"temp.text_"  > _"libdb.text_""
84  RENAME_-FILE('"libdb.text", '"olibdb.text")
85  deleteFile '"temp.text"
86
87buildLibdbConEntry conname ==
88    NULL GETDATABASE(conname, 'CONSTRUCTORMODEMAP) => nil
89    abb:=GETDATABASE(conname,'ABBREVIATION)
90    $conname := conname
91    conform := GETDATABASE(conname,'CONSTRUCTORFORM) or [conname] --hack for Category,..
92    $conform := dbMkForm SUBST('T,"T$",conform)
93    null $conform => nil
94    $exposed? := (isExposedConstructor conname => '"x"; '"n")
95    $doc      := GETDATABASE(conname, 'DOCUMENTATION)
96    pname := PNAME conname
97    kind  := GETDATABASE(conname,'CONSTRUCTORKIND)
98    if kind = 'domain
99      and GETDATABASE(conname,'CONSTRUCTORMODEMAP) is [[.,t,:.],:.]
100       and t is ['CATEGORY,'package,:.] then kind := 'package
101    $kind :=
102      pname.(MAXINDEX pname) = char '_& => 'x
103      DOWNCASE (PNAME kind).0
104    argl := rest $conform
105    conComments :=
106      LASSOC('constructor,$doc) is [[=nil,:r]] => libdbTrim concatWithBlanks r
107      '""
108    argpart:= SUBSTRING(form2HtString ['f,:argl],1,nil)
109    sigpart:= libConstructorSig $conform
110    header := STRCONC($kind,PNAME conname)
111    buildLibdbString [header,#argl,$exposed?,sigpart,argpart,abb,conComments]
112
113dbMkForm x == atom x and [x] or x
114
115buildLibdbString [x,:u] ==
116  STRCONC(STRINGIMAGE x,"STRCONC"/[STRCONC('"`",STRINGIMAGE y) for y in u])
117
118libConstructorSig [conname,:argl] ==
119  [[.,:sig],:.] := GETDATABASE(conname,'CONSTRUCTORMODEMAP)
120  formals := TAKE(#argl,$FormalMapVariableList)
121  sig := SUBLISLIS(formals,$TriangleVariableList,sig)
122  keys := [g(f,sig,i) for f in formals for i in 1..] where
123    g(x,u,i) ==  --does x appear in any but i-th element of u?
124      or/[CONTAINED(x,y) for y in u for j in 1.. | j ~= i]
125  sig := fn SUBLISLIS(argl,$FormalMapVariableList,sig) where
126    fn x ==
127      atom x => x
128      x is ['Join,a,:r] => ['Join,fn a,'etc]
129      x is ['CATEGORY,:.] => 'etc
130      [fn y for y in x]
131  sig := [first sig,:[(k => [":",a,s]; s)
132            for a in argl for s in rest sig for k in keys]]
133  sigpart:= form2LispString ['Mapping,:sig]
134  if null ncParseFromString sigpart then
135    sayBrightly ['"Won't parse: ",sigpart]
136  sigpart
137
138concatWithBlanks r ==
139  r is [head,:tail] =>
140    tail => STRCONC(head,'" ",concatWithBlanks tail)
141    head
142  '""
143
144writedb(u) ==
145  not STRINGP u => nil        --skip if not a string
146  PRINTEXP(u, $outStream)
147  TERPRI $outStream
148
149buildLibOps oplist == for [op,sig,:pred] in oplist repeat buildLibOp(op,sig,pred)
150
151buildLibOp(op,sig,pred) ==
152--operations      OKop  \#\sig \conname\pred\comments (K is U or C)
153  nsig := SUBLISLIS(rest $conform,$FormalMapVariableList,sig)
154  pred := SUBLISLIS(rest $conform,$FormalMapVariableList,pred)
155  nsig := SUBST('T,"T$",nsig)   --this ancient artifact causes troubles!
156  pred := SUBST('T,"T$",pred)
157  sigpart:= form2LispString ['Mapping,:nsig]
158  predString := (pred = 'T => '""; form2LispString pred)
159  sop :=
160    (s := STRINGIMAGE op) = '"One" => '"1"
161    s = '"Zero" => '"0"
162    s
163  header := STRCONC('"o",sop)
164  conform:= STRCONC($kind,form2LispString $conform)
165  comments:= libdbTrim concatWithBlanks LASSOC(sig,LASSOC(op,$doc))
166  checkCommentsForBraces('operation,sop,sigpart,comments)
167  writedb
168    buildLibdbString [header,# rest sig,$exposed?,sigpart,conform,predString,comments]
169
170libdbTrim s ==
171  k := MAXINDEX s
172  k < 0 => s
173  for i in 0..k repeat
174    s.i = $Newline => SETELT(s,i,char '_ )
175  trimString s
176
177checkCommentsForBraces(kind,sop,sigpart,comments) ==
178  count := 0
179  for i in 0..MAXINDEX comments repeat
180    c := comments.i
181    c = char '_{ => count := count + 1
182    c = char '_} =>
183      count := count - 1
184      count < 0 => missingLeft := true
185  if count < 0 or missingLeft then
186    tail :=
187      kind = 'attribute => [sop,'"(",sigpart,'")"]
188      [sop,'": ",sigpart]
189    sayBrightly ['"(",$conname,'" documentation) missing left brace--> ",:tail]
190  if count > 0 then
191    sayBrightly ['"(",$conname,'" documentation) missing right brace--> ",:tail]
192  if count ~= 0 or missingLeft then pp comments
193
194dbHasExamplePage conname ==
195  sname    := STRINGIMAGE conname
196  abb      := constructor? conname
197  ucname   := UPCASE STRINGIMAGE abb
198  pathname :=STRCONC(getEnv '"FRICAS",'"/share/hypertex/pages/",ucname,'".ht")
199  isExistingFile pathname => INTERN STRCONC(sname,'"XmpPage")
200  nil
201
202dbReadComments(n) ==
203  n = 0 => '""
204  instream := MAKE_INSTREAM(STRCONC(getEnv('"FRICAS"), '"/algebra/comdb.text"))
205  FILE_-POSITION(instream,n)
206  line := read_line instream
207  k := dbTickIndex(line,1,1)
208  line := SUBSTRING(line,k + 1,nil)
209  while not EOFP instream and (x := read_line instream) and
210    (k := MAXINDEX x) and (j := dbTickIndex(x,1,1)) and (j < k) and
211      x.(j := j + 1) = char '_- and x.(j := j + 1) = char '_- repeat
212        xtralines := [SUBSTRING(x,j + 1,nil),:xtralines]
213  SHUT instream
214  STRCONC(line, "STRCONC"/NREVERSE xtralines)
215
216dbSplitLibdb() ==
217  instream := MAKE_INSTREAM('"olibdb.text")
218  outstream := MAKE_OUTSTREAM('"libdb.text")
219  comstream := MAKE_OUTSTREAM('"comdb.text")
220  PRINTEXP(0,    comstream)
221  PRINTEXP($tick,comstream)
222  PRINTEXP('"",  comstream)
223  TERPRI(comstream)
224  while not EOFP instream repeat
225    line := read_line instream
226    outP := FILE_-POSITION outstream
227    comP := FILE_-POSITION comstream
228    [prefix,:comments] := dbSplit(line,6,1)
229    PRINTEXP(prefix,outstream)
230    PRINTEXP($tick ,outstream)
231    null comments =>
232      PRINTEXP(0,outstream)
233      TERPRI(outstream)
234    PRINTEXP(comP,outstream)
235    TERPRI(outstream)
236    PRINTEXP(outP  ,comstream)
237    PRINTEXP($tick ,comstream)
238    PRINTEXP(first comments,comstream)
239    TERPRI(comstream)
240    for c in rest comments repeat
241      PRINTEXP(outP  ,comstream)
242      PRINTEXP($tick ,comstream)
243      PRINTEXP(c, comstream)
244      TERPRI(comstream)
245  SHUT instream
246  SHUT outstream
247  SHUT comstream
248  deleteFile '"olibdb.text"
249
250dbSplit(line,n,k) ==
251  k := charPosition($tick,line,k + 1)
252  n = 1 => [SUBSTRING(line,0,k),:dbSpreadComments(SUBSTRING(line,k + 1,nil),0)]
253  dbSplit(line,n - 1,k)
254
255dbSpreadComments(line,n) ==
256  line = '"" => nil
257  k := charPosition(char '_-,line,n + 2)
258  k >= MAXINDEX line => [SUBSTRING(line,n,nil)]
259  line.(k + 1) ~= char '_- =>
260    u := dbSpreadComments(line,k)
261    [STRCONC(SUBSTRING(line,n,k - n),first u),:rest u]
262  [SUBSTRING(line,n,k - n),:dbSpreadComments(SUBSTRING(line,k,nil),0)]
263
264--============================================================================
265--                  Build Glossary
266--============================================================================
267buildGloss() ==  --called by buildDatabase (database.boot)
268--starting with gloss.text, build glosskey.text and glossdef.text
269  $constructorName : local := nil
270  $exposeFlag : local := true
271  $outStream : local := MAKE_OUTSTREAM('"temp.text")
272  $x : local := nil
273  $attribute? : local := true     --do not surround first word
274  pathname := '"gloss.text"
275  instream := MAKE_INSTREAM(pathname)
276  keypath  := '"glosskey.text"
277  maybe_delete_file(keypath)
278  outstream := MAKE_OUTSTREAM(keypath)
279  htpath   := '"gloss.ht"
280  maybe_delete_file(htpath)
281  htstream := MAKE_OUTSTREAM(htpath)
282  defpath  := '"glossdef.text"
283  defstream := MAKE_OUTSTREAM(defpath)
284  pairs := getGlossLines instream
285  PRINTEXP('"\begin{page}{GlossaryPage}{G l o s s a r y}\beginscroll\beginmenu",htstream)
286  for [name,:line] in pairs repeat
287    outP  := FILE_-POSITION outstream
288    defP  := FILE_-POSITION defstream
289    lines := spreadGlossText transformAndRecheckComments(name,[line])
290    PRINTEXP(name, outstream)
291    PRINTEXP($tick,outstream)
292    PRINTEXP(defP, outstream)
293    TERPRI(outstream)
294--  PRINTEXP('"\item\newline{\em \menuitemstyle{}}\tab{0}{\em ",htstream)
295    PRINTEXP('"\item\newline{\em \menuitemstyle{}}{\em ",htstream)
296    PRINTEXP(name,        htstream)
297    PRINTEXP('"}\space{}",htstream)
298    TERPRI(htstream)
299    for x in lines repeat
300      PRINTEXP(outP, defstream)
301      PRINTEXP($tick,defstream)
302      PRINTEXP(x,    defstream)
303      TERPRI defstream
304    PRINTEXP("STRCONC"/lines,htstream)
305    TERPRI htstream
306  PRINTEXP('"\endmenu\endscroll",htstream)
307  PRINTEXP('"\lispdownlink{Search}{(|htGloss| _"\stringvalue{pattern}_")} for glossary entry matching \inputstring{pattern}{24}{*}",htstream)
308  PRINTEXP('"\end{page}",htstream)
309  SHUT instream
310  SHUT outstream
311  SHUT defstream
312  SHUT htstream
313  SHUT $outStream
314
315spreadGlossText(line) ==
316--this function breaks up a line into chunks
317--eventually long line is put into gloss.text as several chunks as follows:
318----- key1`this is the first chunk
319----- XXX`and this is the second
320----- XXX`and this is the third
321----- key2`and this is the fourth
322--where XXX is the file position of key1
323--this is because grepping will only pick up the first 512 characters
324  line = '"" => nil
325  MAXINDEX line > 500 => [SUBSTRING(line,0,500),:spreadGlossText(SUBSTRING(line,500,nil))]
326  [line]
327
328getGlossLines instream ==
329--instream has text of the form:
330----- key1`this is the first line
331----- and this is the second
332----- key2'and this is the third
333--result is
334----- key1'this is the first line and this is the second
335----- key2'and this is the third
336  keys := nil
337  text := nil
338  lastLineHadTick := false
339  while not EOFP instream repeat
340    line := read_line instream
341    #line = 0 => 'skip
342    n := charPosition($tick,line,0)
343    last := IFCAR text
344    n > MAXINDEX line =>  --this line is continuation of previous line; concat it
345      fill :=
346        #last = 0 =>
347          lastLineHadTick => '""
348          '"\blankline "
349        #last > 0 and last.(MAXINDEX last) ~= $charBlank => $charBlank
350        '""
351      lastLineHadTick := false
352      text := [STRCONC(last,fill,line),:rest text]
353    lastLineHadTick := true
354    keys := [SUBSTRING(line,0,n),:keys]
355    text := [SUBSTRING(line,n + 1,nil),:text]
356  ASSOCRIGHT listSort(function GLESSEQP,[[DOWNCASE key,key,:def] for key in keys for def in text])
357  --this complication sorts them after lower casing the keys
358
359--============================================================================
360--                  Build Users HashTable
361-- This database is written out as USERS.DATABASE (database.boot) and read using
362-- function getUsersOfConstructor. See functions whoUses and kcuPage in browser.
363--============================================================================
364mkUsersHashTable() ==  --called by make-databases (daase.lisp)
365  $usersTb := MAKE_HASHTABLE('EQUAL)
366  for x in allConstructors() repeat
367    for conform in getImports x repeat
368      name := opOf conform
369      if not MEMQ(name,'(QUOTE)) then
370        HPUT($usersTb,name,insert(x,HGET($usersTb,name)))
371  for k in HKEYS $usersTb repeat
372    HPUT($usersTb,k,listSort(function GLESSEQP,HGET($usersTb,k)))
373  for x in allConstructors() | isDefaultPackageName x repeat
374    HPUT($usersTb,x,getDefaultPackageClients x)
375  $usersTb
376
377getDefaultPackageClients con ==  --called by mkUsersHashTable
378  catname := INTERN SUBSTRING(s := PNAME con,0,MAXINDEX s)
379  for [catAncestor,:.] in childrenOf([catname]) repeat
380    pakname := INTERN STRCONC(PNAME catAncestor,'"&")
381    if getCDTEntry(pakname,true) then acc := [pakname,:acc]
382    acc := union([CAAR x for x in domainsOf([catAncestor],nil)],acc)
383  listSort(function GLESSEQP,acc)
384
385--============================================================================
386--               Build Dependents Hashtable
387-- This hashtable is written out by database.boot as DEPENDENTS.DATABASE
388-- and read back in by getDependentsOfConstructor (see database.boot)
389-- This information is used by function kcdePage when a user asks for the
390-- dependents of a constructor.
391--============================================================================
392mkDependentsHashTable() == --called by make-databases (database.boot)
393  $depTb := MAKE_HASHTABLE('EQUAL)
394  for nam in allConstructors() repeat
395    for con in getArgumentConstructors nam repeat
396      HPUT($depTb,con,[nam,:HGET($depTb,con)])
397  for k in HKEYS $depTb repeat
398    HPUT($depTb,k,listSort(function GLESSEQP,HGET($depTb,k)))
399  $depTb
400
401getArgumentConstructors con == --called by mkDependentsHashTable
402  argtypes := IFCDR IFCAR getConstructorModemap con or return nil
403  fn argtypes where
404    fn(u) == "union"/[gn x for x in u]
405    gn(x) ==
406      atom x => nil
407      x is ['Join,:r] => fn(r)
408      x is ['CATEGORY,:.] => nil
409      constructor? first x => [first x,:fn rest x]
410      fn rest x
411
412getImports conname == --called by mkUsersHashTable
413  conform := GETDATABASE(conname,'CONSTRUCTORFORM)
414  infovec := dbInfovec conname or return nil
415  template := infovec.0
416  u := [import(i,template)
417          for i in 5..(MAXINDEX template) | test]  where
418    test == template.i is [op,:.] and IDENTP op
419              and not MEMQ(op,'(Mapping Union Record Enumeration CONS QUOTE local))
420    import(x,template) ==
421      x is [op,:args] =>
422        op = 'QUOTE or op = 'NRTEVAL => first args
423        op = 'local => first args
424        op = 'Record =>
425          ['Record,:[[":",CADR y,import(CADDR y,template)] for y in args]]
426
427--TTT next three lines: handles some tagged/untagged Union case.
428        op = 'Union=>
429          args is [['_:,:x1],:x2] =>
430--          CAAR args = '_: => -- tagged!
431               ['Union,:[[":",CADR y,import(CADDR y,template)] for y in args]]
432          [op,:[import(y,template) for y in args]]
433
434        [op,:[import(y,template) for y in args]]
435      INTEGERP x => import(template.x,template)
436      x = '$ => '$
437      x = "$$" => "$$"
438      STRINGP x => x
439      systemError '"bad argument in template"
440  listSort(function GLESSEQP,SUBLISLIS(rest conform,$FormalMapVariableList,u))
441
442
443--============================================================================
444--                 Get Hierarchical Information
445--============================================================================
446getParentsFor(cname,formalParams,constructorCategory) ==
447--called by compDefineFunctor1
448  acc := nil
449  formals := TAKE(#formalParams,$TriangleVariableList)
450  constructorForm := GETDATABASE(cname, 'CONSTRUCTORFORM)
451  for x in folks constructorCategory repeat
452    x := SUBLISLIS(formalParams,formals,x)
453    x := SUBLISLIS(IFCDR constructorForm,formalParams,x)
454    acc := [:explodeIfs x,:acc]
455  NREVERSE acc
456
457parentsOf con == --called by kcpPage, ancestorsRecur
458  if null BOUNDP '$parentsCache then SETQ($parentsCache, MAKE_HASHTABLE('ID))
459  HGET($parentsCache,con) or
460    parents := getParentsForDomain con
461    HPUT($parentsCache,con,parents)
462    parents
463
464parentsOfForm [op,:argl] ==
465  parents := parentsOf op
466  null argl or argl = (newArgl := rest GETDATABASE(op,'CONSTRUCTORFORM)) =>
467    parents
468  SUBLISLIS(argl, newArgl, parents)
469
470getParentsForDomain domname  == --called by parentsOf
471  acc := nil
472  for x in folks GETDATABASE(domname,'CONSTRUCTORCATEGORY) repeat
473    x :=
474      GETDATABASE(domname,'CONSTRUCTORKIND) = 'category =>
475        sublisFormal(IFCDR getConstructorForm domname,x,$TriangleVariableList)
476      sublisFormal(IFCDR getConstructorForm domname,x)
477    acc := [:explodeIfs x,:acc]
478  NREVERSE acc
479
480explodeIfs x == main where  --called by getParents, getParentsForDomain
481  main ==
482    x is ['IF,p,a,b] => fn(p,a,b)
483    [[x,:true]]
484  fn(p,a,b) ==
485    [:"append"/[gn(p,y) for y in a],:"append"/[gn(['NOT,p],y) for y in b]]
486  gn(p,a) ==
487    a is ['IF,q,b,:.] => fn(MKPF([p,q],'AND),b,nil)
488    [[a,:p]]
489
490folks u == --called by getParents and getParentsForDomain
491  atom u => nil
492  u is [op,:v] and MEMQ(op,'(Join PROGN))
493    or u is ['CATEGORY,a,:v] => "append"/[folks x for x in v]
494  u is ['SIGNATURE,:.] => nil
495  u is ['TYPE,:.] => nil
496  u is ['ATTRIBUTE,a] =>
497    PAIRP a and constructor? opOf a => folks a
498    nil
499  u is ['IF,p,q,r] =>
500    q1 := folks q
501    r1 := folks r
502    q1 or r1 => [['IF,p,q1,r1]]
503    nil
504  [u]
505
506descendantsOf(conform,domform) ==  --called by kcdPage
507  'category = GETDATABASE((conname := opOf conform),'CONSTRUCTORKIND) =>
508    cats := catsOf(conform,domform)
509    [op,:argl] := conform
510    null argl or argl = (newArgl := rest (GETDATABASE(op,'CONSTRUCTORFORM)))
511        => cats
512    SUBLISLIS(argl, newArgl, cats)
513  'notAvailable
514
515childrenOf conform ==
516  [pair for pair in descendantsOf(conform,nil) |
517    childAssoc(conform,parentsOfForm first pair)]
518
519childAssoc(form,alist) ==
520  null (argl := rest form) => assoc(form, alist)
521  u := assocCar(opOf form, alist) => childArgCheck(argl, rest first u) and u
522  nil
523
524assocCar(x, al) == or/[pair for pair in al | x = CAAR pair]
525
526childArgCheck(argl, nargl) ==
527  and/[fn for x in argl for y in nargl for i in 0..] where
528    fn ==
529      x = y or constructor? opOf y => true
530      isSharpVar y => i = POSN1(y, $FormalMapVariableList)
531      false
532
533--computeDescendantsOf cat ==
534--dynamically generates descendants
535--  hash := MAKE_HASHTABLE('UEQUAL)
536--  for [child,:pred] in childrenOf cat repeat
537--    childForm := getConstructorForm child
538--    HPUT(hash,childForm,pred)
539--    for [form,:pred] in descendantsOf(childForm,nil) repeat
540--      newPred :=
541--        oldPred := HGET(hash,form) => quickOr(oldPred,pred)
542--        pred
543--      HPUT(hash,form,newPred)
544--  mySort [[key,:HGET(hash,key)] for key in HKEYS hash]
545
546ancestors_of_cat(conform, domform) ==
547       conname := opOf(conform)
548       alist := GETDATABASE(conname,'ANCESTORS)
549       argl := IFCDR domform or IFCDR conform
550       [pair for [a,:b] in alist | pair] where pair ==
551         left :=  sublisFormal(argl,a)
552         right := sublisFormal(argl,b)
553         if domform then right := simpHasPred right
554         null right => false
555         [left,:right]
556
557ancestorsOf(conform,domform) ==  --called by kcaPage, originsInOrder,...
558  'category = GETDATABASE((conname := opOf(conform)), 'CONSTRUCTORKIND) =>
559       ancestors_of_cat(conform, domform)
560  computeAncestorsOf(conform,domform)
561
562computeAncestorsOf(conform,domform) ==
563  $done : local := MAKE_HASHTABLE('UEQUAL)
564  $if :   local := MAKE_HASHTABLE('ID)
565  ancestorsRecur(conform,domform,true,true)
566  acc := nil
567  for op in listSort(function GLESSEQP,HKEYS $if) repeat
568    for pair in HGET($if,op) repeat acc := [pair,:acc]
569  NREVERSE acc
570
571ancestorsRecur(conform,domform,pred,firstTime?) == --called by ancestorsOf
572  op      := opOf conform
573  pred = HGET($done,conform) => nil   --skip if already processed
574  parents :=
575    firstTime? and ($insideCategoryIfTrue or $insideFunctorIfTrue) =>
576      $lisplibParents
577    parentsOf op
578  originalConform :=
579    firstTime? and ($insideCategoryIfTrue or $insideFunctorIfTrue) =>
580        $functorForm
581    getConstructorForm op
582  if conform ~= originalConform then
583    parents := SUBLISLIS(IFCDR conform,IFCDR originalConform,parents)
584  for [newform,:p] in parents repeat
585    if domform and rest domform then
586      newdomform := SUBLISLIS(rest domform,rest conform,newform)
587      p          := SUBLISLIS(rest domform,rest conform,p)
588    newPred := quickAnd(pred,p)
589    ancestorsAdd(simpHasPred newPred,newdomform or newform)
590    ancestorsRecur(newform,newdomform,newPred,false)
591  HPUT($done,conform,pred)                  --mark as already processed
592
593ancestorsAdd(pred,form) == --called by ancestorsRecur
594  null pred => nil
595  op := IFCAR form or form
596  alist := HGET($if,op)
597  existingNode := assoc(form,alist) =>
598    RPLACD(existingNode, quickOr(rest existingNode, pred))
599  HPUT($if,op,[[form,:pred],:alist])
600
601domainsOf(conform, domname) ==
602  conname := opOf conform
603  u := [key for key in HKEYS $has_category_hash
604    | key is [anc,: =conname]]
605  --u is list of pairs (a . b) where b = conname
606  --we sort u then replace each b by the predicate for which this is true
607  s := listSort(function GLESSEQP,COPY u)
608  s := [[first pair, :GETDATABASE(pair, 'HASCATEGORY)] for pair in s]
609  transKCatAlist(conform,domname,listSort(function GLESSEQP,s))
610
611catsOf(conform, domname) ==
612  conname := opOf conform
613  alist := nil
614  for key in allConstructors() repeat
615    for item in GETDATABASE(key,'ANCESTORS) | conname = CAAR item repeat
616      [[op,:args],:pred] := item
617      newItem :=
618        args => [[args,:pred],:LASSOC(key,alist)]
619        pred
620      alist := insertShortAlist(key,newItem,alist)
621  transKCatAlist(conform,domname,listSort(function GLESSEQP,alist))
622
623transKCatAlist(conform,domname,s) == main where
624  main ==
625    domname => --accept only exact matches after substitution
626      domargs := rest domname
627      acc := nil
628      rest conform =>
629        for pair in s repeat --pair has form [con,[conargs,:pred],...]]
630          leftForm := getConstructorForm first pair
631          for (ap := [args, :pred]) in rest pair repeat
632            match? :=
633              domargs = args => true
634              HAS_SHARP_VAR args => domargs = sublisFormal(IFCDR domname, args)
635              nil
636            null match? => 'skip
637            npred := sublisFormal(IFCDR leftForm, pred)
638            acc := [[leftForm,:npred],:acc]
639        NREVERSE acc
640      --conform has no arguments so each pair has form [con,:pred]
641      for pair in s repeat
642        leftForm := getConstructorForm first pair or systemError nil
643        RPLACA(pair,leftForm)
644        RPLACD(pair, sublisFormal(IFCDR leftForm, rest pair))
645      s
646    --no domname, so look for special argument combinations
647    acc := nil
648    IFCDR conform =>
649      farglist := TAKE(#rest conform,$FormalMapVariableList)
650      for pair in s repeat --pair has form [con,[conargs,:pred],...]]
651        leftForm := getConstructorForm first pair
652        for (ap := [args, :pred]) in rest pair repeat
653          hasArgsForm? := args ~= farglist
654          npred := sublisFormal(IFCDR leftForm, pred)
655          if hasArgsForm? then
656            subargs := sublisFormal(IFCDR leftForm, args)
657            hpred :=
658--            $hasArgsList => mkHasArgsPred subargs
659              ['hasArgs,:subargs]
660            npred := quickAnd(hpred,npred)
661          acc := [[leftForm,:npred],:acc]
662      NREVERSE acc
663    for pair in s repeat --pair has form [con,:pred]
664      leftForm := getConstructorForm first pair
665      RPLACA(pair,leftForm)
666      RPLACD(pair, sublisFormal(IFCDR leftForm, rest pair))
667    s
668
669mkHasArgsPred subargs ==
670--$hasArgsList gives arguments of original constructor,e.g. LODO(A,M)
671--M is required to be Join(B,...); in looking for the domains of B
672--  we can find that if B has special value C, it can
673  systemError subargs
674
675sublisFormal(args,exp,:options) == main where
676  main ==  --use only on LIST structures; see also sublisFormalAlist
677    $formals: local := IFCAR options or $FormalMapVariableList
678    null args => exp
679    sublisFormal1(args,exp,#args - 1)
680  sublisFormal1(args,x,n) ==    --[sublisFormal1(args,y) for y in x]
681    x is [.,:.] =>
682      acc := nil
683      y := x
684      while null atom y repeat
685        acc := [sublisFormal1(args,QCAR y,n),:acc]
686        y := QCDR y
687      r := NREVERSE acc
688      if y then
689        nd := LASTNODE r
690        RPLACD(nd,sublisFormal1(args,y,n))
691      r
692    IDENTP x =>
693      j := or/[i for f in $formals for i in 0..n | EQ(f,x)] =>
694          args.j
695      x
696    x
697
698--=======================================================================
699--            Build Table of Lower Case Constructor Names
700--=======================================================================
701
702buildDefaultPackageNamesHT() ==
703  $defaultPackageNamesHT := MAKE_HASHTABLE('EQUAL)
704  for nam in allConstructors() | isDefaultPackageName nam repeat
705    HPUT($defaultPackageNamesHT,nam,true)
706  $defaultPackageNamesHT
707
708$defaultPackageNamesHT := buildDefaultPackageNamesHT()
709
710--=======================================================================
711--            Code for Private Libdbs
712--=======================================================================
713-- $createLocalLibDb := false
714
715extendLocalLibdb conlist ==   --  called by astran
716  not $createLocalLibDb => nil
717  null conlist => nil
718  buildLibdb conlist          --> puts datafile into temp.text
719  $newConstructorList := union(conlist, $newConstructorList)
720  localLibdb := '"libdb.text"
721  not PROBE_-FILE '"libdb.text" =>
722    RENAME_-FILE('"temp.text",'"libdb.text")
723  oldlines := purgeNewConstructorLines(dbReadLines localLibdb, conlist)
724  newlines := dbReadLines '"temp.text"
725  dbWriteLines(MSORT union(oldlines,newlines), '"libdb.text")
726  maybe_delete_file('"temp.text")
727