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