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
34)if false
35ADDINFORMATION CODE
36This code adds various items to the special value of $Information,
37in order to keep track of all the compiler's information about
38various categories and similar objects
39An actual piece of (unconditional) information can have one of 3 forms:
40 (ATTRIBUTE domainname attribute)
41             --These are only stored here, should be unused
42 (SIGNATURE domainname operator signature)
43             --These are also stored as 'modemap' properties
44 (has domainname categoryexpression)
45             --These are also stored as 'value' properties
46Conditional attributes are of the form
47 (COND
48 (condition info info ...)
49 ... )
50where the condition looks like a 'has' clause, or the 'and' of several
51'has' clauses:
52  (has name categoryexpression)
53  (has name (ATTRIBUTE attribute))
54  (has name (SIGNATURE operator signature))
55The use of two representations is admitted to be clumsy
56)endif
57
58printInfo e ==
59  for u in get("$Information", "special", e) repeat PRETTYPRINT u
60  nil
61
62addInformation(m, e) ==
63  ni := info(m, []) where
64    info(m, il) ==
65      --Processes information from a mode declaration in compCapsule
66      atom m => il
67      m is ["CATEGORY", ., :stuff] =>
68          for u in stuff repeat il := addInfo(u, il)
69          il
70      m is ["Join",:stuff] =>
71          for u in stuff repeat il := info(u, il)
72          il
73      il
74  put("$Information", "special", [:ni,
75        :get("$Information", "special", e)], e)
76  e
77
78addInfo(u, il) == [formatInfo u, :il]
79
80formatInfo u ==
81  atom u => u
82  u is ["SIGNATURE",:v] => ["SIGNATURE","$",:v]
83 --u is ("CATEGORY",junk,:l) => ("PROGN",:(formatInfo v for v in l))
84  u is ["PROGN",:l] => ["PROGN",:[formatInfo v for v in l]]
85  u is ["ATTRIBUTE", v] =>
86      isCategoryForm(v) => ["has", "$", v]
87      BREAK()
88  u is ["IF",a,b,c] =>
89    c="noBranch" => ["COND",:liftCond [formatPred a,formatInfo b]]
90    b="noBranch" => ["COND",:liftCond [["not",formatPred a],formatInfo c]]
91    ["COND",:liftCond [formatPred a,formatInfo b],:
92      liftCond [["not",formatPred a],formatInfo c]]
93  systemError '"formatInfo"
94
95liftCond (clause is [ante,conseq]) ==
96  conseq is ["COND",:l] =>
97    [[lcAnd(ante,a),:b] for [a,:b] in l] where
98      lcAnd(pred,conj) ==
99        conj is ["and",:ll] => ["and",pred,:ll]
100        ["and",pred,conj]
101  [clause]
102
103formatPred u ==
104         --Assumes that $e is set up to point to an environment
105  u is ["has",a,b] =>
106    atom b and isCategoryForm([b]) => ["has", a, [b]]
107    atom b => BREAK()
108    isCategoryForm(b) => u
109    b is ["ATTRIBUTE",.] => BREAK()
110    b is ["SIGNATURE",:.] => u
111    BREAK()
112  atom u => u
113  u is ["and",:v] => ["and",:[formatPred w for w in v]]
114  systemError '"formatPred"
115
116chaseInferences(pred, $info_e) ==
117  foo(hasToInfo(pred)) where
118    foo(pred) ==
119      knownInfo pred => nil
120      $info_e := actOnInfo(pred, $info_e)
121      pred:= infoToHas pred
122      for u in get("$Information", "special", $info_e) repeat
123        u is ["COND",:l] =>
124          for [ante,:conseq] in l repeat
125            ante=pred => [foo w for w in conseq]
126            ante is ["and",:ante'] and member(pred,ante') =>
127              ante':= delete(pred,ante')
128              v':=
129                LENGTH ante'=1 => first ante'
130                ["and",:ante']
131              v':= ["COND",[v',:conseq]]
132              member(v', get("$Information", "special", $info_e)) => nil
133              $info_e :=
134                put("$Information", "special", [v',:
135                  get("$Information", "special", $info_e)], $info_e)
136            nil
137  $info_e
138
139hasToInfo (pred is ["has",a,b]) ==
140  b is ["SIGNATURE",:data] => ["SIGNATURE",a,:data]
141  b is ["ATTRIBUTE",c] => BREAK()
142  pred
143
144infoToHas a ==
145  a is ["SIGNATURE",b,:data] => ["has",b,["SIGNATURE",:data]]
146  a is ["ATTRIBUTE",b,c] => BREAK()
147  a
148
149DEFPARAMETER($cycleMarker, GENSYM())
150
151known_info_in_env(pred, $info_e) == knownInfo(pred)
152
153hashed_known_info(pred) ==
154    $infoHash : local := MAKE_HASHTABLE('EQUAL)
155    knownInfo pred
156
157knownInfo pred ==
158               --true %if the information is already known
159  pred=true => true
160  --pred = "true" => true
161  member(pred, get("$Information", "special", $info_e)) => true
162  not($infoHash) => hashed_known_info(pred)
163  ress := HGET($infoHash, pred) =>
164      ress = $cycleMarker => nil
165      ress
166  -- avoid cycles
167  HPUT($infoHash, pred, $cycleMarker)
168  ress := knownInfo1 pred
169  HPUT($infoHash, pred, ress)
170  ress
171
172get_catlist(vmode, e) ==
173    -- FIXME: setting $compForModeIfTrue should be not needed
174    $compForModeIfTrue : local := true
175    compMakeCategoryObject(vmode, e)
176
177knownInfo1 pred ==
178  pred is ["OR",:l] => or/[knownInfo u for u in l]
179  pred is ["AND",:l] => and/[knownInfo u for u in l]
180  pred is ["or",:l] => or/[knownInfo u for u in l]
181  pred is ["and",:l] => and/[knownInfo u for u in l]
182  pred is ["ATTRIBUTE",name,attr] => BREAK()
183  pred is ["has",name,cat] =>
184    cat is ["ATTRIBUTE",:a] => BREAK()
185    cat is ["SIGNATURE",:a] => knownInfo ["SIGNATURE",name,:a]
186    name is ['Union,:.] => false
187    -- FIXME: there is confusion between '$ in outer domain
188    -- (the one which needs info) and freshly compiled
189    -- domain...
190    v := compForMode(name, $EmptyMode, $info_e)
191    null v => stackSemanticError(["can't find category of ",name],nil)
192    vmode := CADR v
193    cat = vmode => true
194    vmode is ["Join",:l] and member(cat,l) => true
195    [vv, ., .] := get_catlist(vmode, $info_e)
196    catlist := vv.4
197    --catlist := SUBST(name,'$,vv.4)
198    null vv => stackSemanticError(["can't make category of ",name],nil)
199    member(cat,first catlist) => true  --checks princ. ancestors
200    (u:= assoc(cat,CADR catlist)) and knownInfo(CADR u) => true
201    -- previous line checks fundamental anscestors, we should check their
202    --   principal anscestors but this requires instantiating categories
203    -- Order of tests below is tricky performencewise.  We
204    -- put AncestorP test first because knownInfo in worst case
205    -- may lead to large number of recursive calls.
206    or/[AncestorP(cat, LIST first u) and knownInfo CADR u
207          for u in CADR catlist] => true
208    false
209  pred is ["SIGNATURE",name,op,sig,:.] =>
210      v:= get(op, "modemap", $info_e)
211      res := false
212      for w in v while(not(res)) repeat
213          w1 := first(w)
214          ww := rest(w1)
215          --the actual signature part
216          name = first(w1) and LENGTH ww = LENGTH(sig) and _
217            SourceLevelSubsume(ww, sig) =>
218              CAADR w = true => res := true
219      res
220  false
221
222actOnInfo(u, e) ==
223  null u => e
224  u is ["PROGN", :l] =>
225      for v in l repeat
226          e := actOnInfo(v, e)
227      e
228  Info := [u, :get("$Information", "special", e)]
229  e := put("$Information", "special", Info, e)
230  u is ["COND",:l] =>
231      --there is nowhere %else that this sort of thing exists
232    for [ante,:conseq] in l repeat
233      if member(hasToInfo ante,Info) then for v in conseq repeat
234        e := actOnInfo(v, e)
235    e
236  u is ["ATTRIBUTE",name,att] => BREAK()
237  u is ["SIGNATURE",name,operator,modemap] =>
238    implem:=
239      (implem := assoc([name, :modemap], get(operator, 'modemap, e))) =>
240          CADADR implem
241      name = "$" => ['ELT,name,-1]
242      ['ELT,name,substitute('$,name,modemap)]
243    e := addModemap(operator, name, modemap, true, implem, e)
244    [vval, vmode, venv] := GetValue(name, e)
245    SAY("augmenting ",name,": ",u)
246    key:= if CONTAINED("$",vmode) then "domain" else name
247    cat:= ["CATEGORY",key,["SIGNATURE",operator,modemap]]
248    put(name, "value", [vval, mkJoin(cat, vmode), venv], e)
249  u is ["has",name,cat] =>
250    [vval, vmode, venv] := GetValue(name, e)
251    cat = vmode => e --stating the already known
252    u := compMakeCategoryObject(cat, e) =>
253         --we are adding information about a category
254      [catvec, ., e] := u
255      [ocatvec, ., e] := compMakeCategoryObject(vmode, e)
256      -- member(vmode, first catvec.4) =>
257      --    JHD 82/08/08 01:40 This does not mean that we can ignore the
258      --    extension, since this may not be compatible with the view we
259      --    were passed
260
261      --we are adding a principal descendant of what was already known
262      --    $e:= augModemapsFromCategory(name,name,nil,catvec,$e)
263      --    SAY("augmenting ",name,": ",cat)
264      --    put(name, "value", (vval, cat, venv), $e)
265      member(cat,first ocatvec.4) or
266         assoc(cat, CADR ocatvec.4) is [., 'T, .] => e
267        --SAY("Category extension error:
268        --cat shouldn't be a join
269                      --what was being asserted is an ancestor of what was known
270      -- augModemapsFromCategory asserts that domain is in scope,
271      -- so make sure it really is (and not only the extra view we add)
272      e := addDomain(name, e)
273      if ATOM(name) then
274          e := augModemapsFromCategory(name, name, name, cat, e)
275      else
276          e := augModemapsFromCategory(name, name, nil, cat, e)
277      SAY("augmenting ",name,": ",cat)
278      e := put(name, "value", [vval, mkJoin(cat, vmode), venv], e)
279    SAY("extension of ",vval," to ",cat," ignored")
280    e
281  systemError '"knownInfo"
282
283mkJoin(cat,mode) ==
284  mode is ['Join,:cats] => ['Join,cat,:cats]
285  ['Join,cat,mode]
286
287GetValue(name, e) ==
288  u := get(name,"value", e) => u
289  u := comp(name, $EmptyMode, e) => u  --name may be a form
290  systemError [name,'" is not bound in the current environment"]
291