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
34DEFVAR($has_category_hash, nil)
35DEFVAR($ancestor_hash, nil)
36
37compressHashTable(ht) == ht
38
39hasCat(domainOrCatName,catName) ==
40  catName='Type  -- every domain is a Type
41   or GETDATABASE([domainOrCatName,:catName],'HASCATEGORY)
42
43showCategoryTable con ==
44  [[b,:val] for (key :=[a,:b]) in HKEYS $has_category_hash
45     | a = con and (val := HGET($has_category_hash, key))]
46
47displayCategoryTable(:options) ==
48    conList := IFCAR options
49    ct := MAKE_HASHTABLE('ID)
50    for (key := [a, :b]) in HKEYS $has_category_hash repeat
51        HPUT(ct, a, [[b, :HGET($has_category_hash, key)], :HGET(ct, a)])
52    for id in HKEYS ct | null conList or MEMQ(id,conList) repeat
53        sayMSG [:bright id, '"extends:"]
54        PRINT HGET(ct, id)
55
56genCategoryTable() ==
57  $ancestors_hash := MAKE_HASHTABLE('ID)
58  $has_category_hash := MAKE_HASHTABLE('UEQUAL)
59  genTempCategoryTable()
60  domainList:=
61    [con for con in allConstructors()
62      | GETDATABASE(con,'CONSTRUCTORKIND) = 'domain]
63  domainTable:= [addDomainToTable(con,getConstrCat catl) for con
64    in domainList | catl := GETDATABASE(con,'CONSTRUCTORCATEGORY)]
65  -- $nonLisplibDomains, $noCategoryDomains are set in BUILDOM BOOT
66  specialDs := SETDIFFERENCE($nonLisplibDomains,$noCategoryDomains)
67  domainTable:= [:[addDomainToTable(id, getConstrCat (eval [id]).3)
68    for id in specialDs], :domainTable]
69  for [id,:entry] in domainTable repeat
70    for [a,:b] in encodeCategoryAlist(id,entry) repeat
71      HPUT($has_category_hash, [id, :a], b)
72  simpTempCategoryTable()
73  compressHashTable $ancestors_hash
74  simpCategoryTable()
75  compressHashTable $has_category_hash
76
77simpTempCategoryTable() ==
78  for id in HKEYS $ancestors_hash repeat
79    for (u:=[a,:b]) in GETDATABASE(id,'ANCESTORS) repeat
80      RPLACD(u,simpHasPred b)
81
82simpCategoryTable() == main where
83  main ==
84    for key in HKEYS $has_category_hash repeat
85      entry := HGET($has_category_hash, key)
86      null entry => HREM($has_category_hash, key)
87      change :=
88        atom opOf entry => simpHasPred entry
89        [[x,:npred] for [x,:pred] in entry | npred := simpHasPred pred]
90      HPUT($has_category_hash, key, change)
91
92simpHasPred(pred) == simpHasPred2(pred, [])
93
94simpHasPred2(pred, options) == main where
95  main ==
96    $hasArgs: local := IFCDR IFCAR options
97    simp pred
98  simp pred ==
99    pred is [op,:r] =>
100      op = 'has => simpHas(pred,first r,first rest r)
101      op = 'HasCategory => simp ['has, first r, simpDevaluate CADR r]
102      op = 'HasSignature =>
103         [op,sig] := simpDevaluate CADR r
104         ['has, first r, ['SIGNATURE, op, sig]]
105      op = 'HasAttribute => BREAK()
106      MEMQ(op,'(AND OR NOT)) =>
107        null (u := MKPF([simp p for p in r],op)) => nil
108        u is '(QUOTE T) => true
109        simpBool u
110      op = 'hasArgs => ($hasArgs => $hasArgs = r; pred)
111      null r and opOf op = 'has => simp first pred
112      pred is '(QUOTE T) => true
113      op1 := LASSOC(op,'((and . AND)(or . OR)(not . NOT))) => simp [op1,:r]
114    pred in '(T etc) => pred
115    null pred => nil
116    pred
117  simpDevaluate a == EVAL SUBST('QUOTE,'devaluate,a)
118  simpHas(pred,a,b) ==
119    b is ['ATTRIBUTE,attr] => BREAK()
120    b is ['SIGNATURE,op,sig] => simpHasSignature(pred,a,op,sig)
121    STRINGP(a) => pred
122    IDENTP a or hasIdent b => pred
123    npred := eval pred
124    IDENTP npred or null hasIdent npred => npred
125    pred
126  eval (pred := ['has,d,cat]) ==
127    x := hasCat(first d, first cat)
128    y := rest cat =>
129      npred := or/[p for [args,:p] in x | y = args] => simp npred
130      false  --if not there, it is false
131    x
132
133simpHasSignature(pred,conform,op,sig) == --eval w/o loading
134  IDENTP conform => pred
135  [conname,:args] := conform
136  n := #sig
137  u := LASSOC(op,GETDATABASE(conname,'OPERATIONALIST))
138  candidates := [x for (x := [sig1,:.]) in u | #sig1 = #sig]  or return false
139  match := or/[x for (x := [sig1,:.]) in candidates
140                | sig = sublisFormal(args,sig1)] or return false
141  simpHasPred(match is [sig,., p, :.] and sublisFormal(args,p) or true)
142
143hasIdent pred ==
144  pred is [op,:r] =>
145    op = 'QUOTE => false
146    or/[hasIdent x for x in r]
147  pred = '_$ => false
148  IDENTP pred => true
149  false
150
151addDomainToTable(id,catl) ==
152  alist:= nil
153  for cat in catl repeat
154    cat is ['CATEGORY,:.] => nil
155    cat is ['IF,pred,cat1,:.] =>
156      newAlist:=
157        [[a,:quickAnd(pred,b)] for [a,:b] in getCategoryExtensionAlist0 cat1]
158      alist:= [:alist,:newAlist]
159    alist:= [:alist,:getCategoryExtensionAlist0 cat]
160  [id,:alist]
161
162genTempCategoryTable() ==
163  --generates hashtable with key=categoryName and value of the form
164  --     ((form . pred) ..) meaning that
165  --           "IF pred THEN ofCategory(key,form)"
166  --  where form can involve #1, #2, ... the parameters of key
167  for con in allConstructors()  repeat
168    GETDATABASE(con,'CONSTRUCTORKIND) = 'category =>
169      addToCategoryTable con
170  for id in HKEYS $ancestors_hash repeat
171    item := HGET($ancestors_hash, id)
172    for (u:=[.,:b]) in item repeat
173      RPLACD(u,simpCatPredicate simpBool b)
174    HPUT($ancestors_hash, id, listSort(function GLESSEQP, item))
175
176addToCategoryTable con ==
177  u := CAAR GETDATABASE(con,'CONSTRUCTORMODEMAP) --domain
178  alist := getCategoryExtensionAlist u
179  HPUT($ancestors_hash, first u, alist)
180  alist
181
182encodeCategoryAlist(id,alist) ==
183  newAl:= nil
184  for [a,:b] in alist repeat
185    [key,:argl] := a
186    newEntry:=
187      argl => [[argl,:b]]
188      b
189    u:= assoc(key,newAl) =>
190      argl => RPLACD(u,encodeUnion(id,first newEntry,rest u))
191      if newEntry ~= rest u then
192        p:= moreGeneralCategoryPredicate(id,newEntry,rest u) => RPLACD(u,p)
193        sayMSG '"Duplicate entries:"
194        PRINT [newEntry,rest u]
195    newAl:= [[key,:newEntry],:newAl]
196  newAl
197
198encodeUnion(id,new:=[a,:b],alist) ==
199  u := assoc(a,alist) =>
200    RPLACD(u,moreGeneralCategoryPredicate(id,b,rest u))
201    alist
202  [new,:alist]
203
204moreGeneralCategoryPredicate(id,new,old) ==
205  old = 'T or new = 'T => 'T
206  old is ['has,a,b] and new is ['has,=a,c] =>
207    tempExtendsCat(b,c) => new
208    tempExtendsCat(c,b) => old
209    ['OR,old,new]
210  mkCategoryOr(new,old)
211
212mkCategoryOr(new,old) ==
213  old is ['OR,:l] => simpCategoryOr(new,l)
214  ['OR,old,new]
215
216simpCategoryOr(new,l) ==
217  newExtendsAnOld:= false
218  anOldExtendsNew:= false
219  ['has,a,b] := new
220  newList:= nil
221  for pred in l repeat
222    pred is ['has,=a,c] =>
223      tempExtendsCat(c,b) => anOldExtendsNew:= true
224      if tempExtendsCat(b,c) then newExtendsAnOld:= true
225      newList:= [pred,:newList]
226    newList:= [pred,:newList]
227  if not newExtendsAnOld then newList:= [new,:newList]
228  newList is [.] => first newList
229  ['OR,:newList]
230
231tempExtendsCat(b,c) ==
232  or/[first c = a for [[a,:.],:.] in GETDATABASE(first b,'ANCESTORS)]
233
234getCategoryExtensionAlist0 cform ==
235  [[cform,:'T],:getCategoryExtensionAlist cform]
236
237getCategoryExtensionAlist cform ==
238  --avoids substitution as much as possible
239  u:= GETDATABASE(first cform,'ANCESTORS) => formalSubstitute(cform,u)
240  mkCategoryExtensionAlist cform
241
242formalSubstitute(form:=[.,:argl],u) ==
243  isFormalArgumentList argl => u
244  EQSUBSTLIST(argl,$FormalMapVariableList,u)
245
246isFormalArgumentList argl ==
247  and/[x=fa for x in argl for fa in $FormalMapVariableList]
248
249mkCategoryExtensionAlist cform ==
250  not CONSP cform => nil
251  cop := first cform
252  MEMQ(cop, $CategoryNames) => mkCategoryExtensionAlistBasic cform
253  catlist := formalSubstitute(cform, first getConstructorExports(cform, true))
254  extendsList:= nil
255  for [cat,:pred] in catlist repeat
256    newList := getCategoryExtensionAlist0 cat
257    finalList :=
258      pred = 'T => newList
259      [[a,:quickAnd(b,pred)] for [a,:b] in newList]
260    extendsList:= catPairUnion(extendsList,finalList,cop,cat)
261  extendsList
262
263-- following code to handle Unions Records Mapping etc.
264mkCategoryExtensionAlistBasic cform ==
265  cop := first cform
266--category:= eval cform
267  category :=      -- changed by RSS on 7/29/87
268    macrop cop => eval cform
269    APPLY(cop, rest cform)
270  extendsList:= [[x,:'T] for x in category.4.0]
271  for [cat,pred,:.] in category.4.1 repeat
272    newList := getCategoryExtensionAlist0 cat
273    finalList :=
274      pred = 'T => newList
275      [[a,:quickAnd(b,pred)] for [a,:b] in newList]
276    extendsList:= catPairUnion(extendsList,finalList,cop,cat)
277  extendsList
278
279catPairUnion(oldList,newList,op,cat) ==
280  for pair in newList repeat
281    u:= assoc(first pair,oldList) =>
282      rest u = rest pair => nil
283      RPLACD(u,addConflict(rest pair,rest u)) where addConflict(new,old) ==
284        quickOr(new,old)
285    oldList:= [pair,:oldList]
286  oldList
287
288simpCatPredicate p ==
289  p is ['OR,:l] =>
290    (u:= simpOrUnion l) is [p] => p
291    ['OR,:u]
292  p
293
294simpOrUnion l ==
295  if l then simpOrUnion1(first l,simpOrUnion rest l)
296  else l
297
298simpOrUnion1(x,l) ==
299  null l => [x]
300  p:= mergeOr(x,first l) => [p,:rest l]
301  [first l,:simpOrUnion1(x,rest l)]
302
303mergeOr(x,y) ==
304  x is ['has,a,b] and y is ['has,=a,c] =>
305    testExtend(b,c) => y
306    testExtend(c,b) => x
307    nil
308  nil
309
310testExtend(a:=[op,:argl],b) ==
311  (u:= GETDATABASE(op,'ANCESTORS)) and (val:= LASSOC(b,u)) =>
312    formalSubstitute(a,val)
313  nil
314
315getConstrCat(x) ==
316-- gets a different representation of the constructorCategory from the
317-- lisplib, which is a list of named categories or conditions
318  x:= if x is ['Join,:y] then y else [x]
319  cats:= NIL
320  for y in x repeat
321    y is ['CATEGORY,.,:z] =>
322      for zz in z repeat cats := makeCatPred(zz, cats, true)
323    cats:= CONS(y,cats)
324  cats:= nreverse cats
325  cats
326
327
328makeCatPred(zz, cats, thePred) ==
329  if zz is ['IF,curPred := ['has,z1,z2],ats,.] then
330    ats := if ats is ['PROGN,:atl] then atl else [ats]
331    for at in ats repeat
332--      at is ['ATTRIBUTE,z3] =>
333--          BREAK()
334      if at is ['ATTRIBUTE,z3] and not atom z3 and
335        constructor? first z3 then
336          cats:= CONS(['IF,quickAnd(['has,z1,z2], thePred),z3,'noBranch],cats)
337      at is ['IF, pred, :.] =>
338        cats := makeCatPred(at, cats, curPred)
339  cats
340
341getConstructorExports(conform, do_constr) == categoryParts(conform,
342  GETDATABASE(opOf conform, 'CONSTRUCTORCATEGORY), do_constr)
343
344DEFVAR($oplist)
345DEFVAR($conslist)
346
347categoryParts(conform, category, do_constr) ==
348    kind := GETDATABASE(opOf(conform), 'CONSTRUCTORKIND)
349    categoryParts1(kind, conform, category, do_constr)
350
351categoryParts1(kind, conform, category, do_constr) == main where
352  main ==
353    $oplist  : local := nil
354    $conslist: local := nil
355    for x in exportsOf(category) repeat build(x,true)
356    $oplist   := listSort(function GLESSEQP,$oplist)
357    res :=
358        do_constr => listSort(function GLESSEQP, $conslist)
359        []
360    res := [res, :$oplist]
361    if kind = 'category then
362      tvl := TAKE(#rest conform,$TriangleVariableList)
363      res := SUBLISLIS($FormalMapVariableList,tvl,res)
364    res
365  build(item,pred) ==
366    item is ['SIGNATURE,op,sig,:.] => $oplist   := [[opOf op,sig,:pred],:$oplist]
367    --note: opOf is needed!!! Bug in compiler puts in (One) and (Zero)
368    item is ['ATTRIBUTE, attr] =>
369      constructor? opOf attr =>
370        $conslist := [[attr,:pred],:$conslist]
371        nil
372      BREAK()
373    item is ['TYPE,op,type] =>
374        BREAK()
375        $oplist := [[op,[type],:pred],:$oplist]
376    item is ['IF,pred1,s1,s2] =>
377      build(s1,quickAnd(pred,pred1))
378      s2 => build(s2,quickAnd(pred,['NOT,pred1]))
379    item is ['PROGN,:r] => for x in r repeat build(x,pred)
380    item is ['CATEGORY, ., :l] => for x in l repeat build(x, pred)
381    item in '(noBranch) => 'ok
382    null item => 'ok
383    systemError '"build error"
384  exportsOf(target) ==
385    target is ['CATEGORY,.,:r] => r
386    target is ['Join,:r,f] =>
387      for x in r repeat $conslist := [[x,:true],:$conslist]
388      exportsOf f
389    $conslist := [[target,:true],:$conslist]
390    nil
391
392updateCategoryTable(cname,kind) ==
393  kind = 'domain =>
394    updateCategoryTableForDomain(cname,getConstrCat(
395      GETDATABASE(cname,'CONSTRUCTORCATEGORY)))
396
397updateCategoryTableForDomain(cname,category) ==
398  clearCategoryTable(cname)
399  [cname,:domainEntry]:= addDomainToTable(cname,category)
400  for [a,:b] in encodeCategoryAlist(cname,domainEntry) repeat
401    HPUT($has_category_hash, [cname, :a], b)
402  $doNotCompressHashTableIfTrue = true => $has_category_hash
403  compressHashTable $has_category_hash
404
405clearCategoryTable($cname) ==
406  MAPHASH('clearCategoryTable1, $has_category_hash)
407
408clearCategoryTable1(key,val) ==
409  (first key = $cname) => HREM($has_category_hash, key)
410  nil
411
412clearTempCategoryTable(catNames) ==
413  for key in HKEYS($ancestors_hash) repeat
414    MEMQ(key,catNames) => nil
415    extensions:= nil
416    for (extension:= [catForm,:.]) in GETDATABASE(key,'ANCESTORS)
417      repeat
418        MEMQ(first catForm, catNames) => nil
419        extensions:= [extension,:extensions]
420    HPUT($ancestors_hash, key, extensions)
421