diff options
Diffstat (limited to 'src/interp/info.boot')
| -rw-r--r-- | src/interp/info.boot | 285 |
1 files changed, 285 insertions, 0 deletions
diff --git a/src/interp/info.boot b/src/interp/info.boot new file mode 100644 index 00000000..4506c676 --- /dev/null +++ b/src/interp/info.boot @@ -0,0 +1,285 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, 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. + + + +--% ADDINFORMATION CODE +--% This code adds various items to the special value of $Information, +--% in order to keep track of all the compiler's information about +--% various categories and similar objects +--% An actual piece of (unconditional) information can have one of 3 forms: +--% (ATTRIBUTE domainname attribute) +--% --These are only stored here +--% (SIGNATURE domainname operator signature) +--% --These are also stored as 'modemap' properties +--% (has domainname categoryexpression) +--% --These are also stored as 'value' properties +--% Conditional attributes are of the form +--% (COND +--% (condition info info ...) +--% ... ) +--% where the condition looks like a 'has' clause, or the 'and' of several +--% 'has' clauses: +--% (has name categoryexpression) +--% (has name (ATTRIBUTE attribute)) +--% (has name (SIGNATURE operator signature)) +--% The use of two representations is admitted to be clumsy + + +import '"g-util" +)package "BOOT" + +printInfo $e == + for u in get("$Information","special",$e) repeat PRETTYPRINT u + nil + +addInformation(m,$e) == + $Information: local + --$Information:= nil: done by previous statement anyway + info m where + info m == + --Processes information from a mode declaration in compCapsule + atom m => nil + m is ["CATEGORY",.,:stuff] => for u in stuff repeat addInfo u + m is ["Join",:stuff] => for u in stuff repeat info u + nil + $e:= + put("$Information","special",[:$Information,: + get("$Information","special",$e)],$e) + $e + +addInfo u == $Information:= [formatInfo u,:$Information] + +formatInfo u == + atom u => u + u is ["SIGNATURE",:v] => ["SIGNATURE","$",:v] + --u is ("CATEGORY",junk,:l) => ("PROGN",:(formatInfo v for v in l)) + u is ["PROGN",:l] => ["PROGN",:[formatInfo v for v in l]] + u is ["ATTRIBUTE",v] => + + -- The parser can't tell between those attributes that really + -- are attributes, and those that are category names + atom v and isCategoryForm([v],$e) => ["has","$",[v]] + atom v => ["ATTRIBUTE","$",v] + isCategoryForm(v,$e) => ["has","$",v] + ["ATTRIBUTE","$",v] + u is ["IF",a,b,c] => + c="noBranch" => ["COND",:liftCond [formatPred a,formatInfo b]] + b="noBranch" => ["COND",:liftCond [["not",formatPred a],formatInfo c]] + ["COND",:liftCond [formatPred a,formatInfo b],: + liftCond [["not",formatPred a],formatInfo c]] + systemError '"formatInfo" + +liftCond (clause is [ante,conseq]) == + conseq is ["COND",:l] => + [[lcAnd(ante,a),:b] for [a,:b] in l] where + lcAnd(pred,conj) == + conj is ["and",:ll] => ["and",pred,:ll] + ["and",pred,conj] + [clause] + +formatPred u == + --Assumes that $e is set up to point to an environment + u is ["has",a,b] => + atom b and isCategoryForm([b],$e) => ["has",a,[b]] + atom b => ["has",a,["ATTRIBUTE",b]] + isCategoryForm(b,$e) => u + b is ["ATTRIBUTE",.] => u + b is ["SIGNATURE",:.] => u + ["has",a,["ATTRIBUTE",b]] + atom u => u + u is ["and",:v] => ["and",:[formatPred w for w in v]] + systemError '"formatPred" + +chaseInferences(pred,$e) == + foo hasToInfo pred where + foo pred == + knownInfo pred => nil + $e:= actOnInfo(pred,$e) + pred:= infoToHas pred + for u in get("$Information","special",$e) repeat + u is ["COND",:l] => + for [ante,:conseq] in l repeat + ante=pred => [foo w for w in conseq] + ante is ["and",:ante'] and member(pred,ante') => + ante':= delete(pred,ante') + v':= + LENGTH ante'=1 => first ante' + ["and",:ante'] + v':= ["COND",[v',:conseq]] + member(v',get("$Information","special",$e)) => nil + $e:= + put("$Information","special",[v',: + get("$Information","special",$e)],$e) + nil + $e + +hasToInfo (pred is ["has",a,b]) == + b is ["SIGNATURE",:data] => ["SIGNATURE",a,:data] + b is ["ATTRIBUTE",c] => ["ATTRIBUTE",a,c] + pred + +infoToHas a == + a is ["SIGNATURE",b,:data] => ["has",b,["SIGNATURE",:data]] + a is ["ATTRIBUTE",b,c] => ["has",b,["ATTRIBUTE",c]] + a + +knownInfo pred == + --true %if the information is already known + pred=true => true + --pred = "true" => true + member(pred,get("$Information","special",$e)) => true + pred is ["OR",:l] => or/[knownInfo u for u in l] + pred is ["AND",:l] => and/[knownInfo u for u in l] + pred is ["or",:l] => or/[knownInfo u for u in l] + pred is ["and",:l] => and/[knownInfo u for u in l] + pred is ["ATTRIBUTE",name,attr] => + v:= compForMode(name,$EmptyMode,$e) + null v => stackSemanticError(["can't find category of ",name],nil) + [vv,.,.]:= compMakeCategoryObject(CADR v,$e) + null vv => stackSemanticError(["can't make category of ",name],nil) + member(attr,vv.2) => true + x:= assoc(attr,vv.2) => knownInfo CADR x + --format is a list of two elements: information, predicate + false + pred is ["has",name,cat] => + cat is ["ATTRIBUTE",:a] => knownInfo ["ATTRIBUTE",name,:a] + cat is ["SIGNATURE",:a] => knownInfo ["SIGNATURE",name,:a] + name is ['Union,:.] => false + v:= compForMode(name,$EmptyMode,$e) + null v => stackSemanticError(["can't find category of ",name],nil) + vmode := CADR v + cat = vmode => true + vmode is ["Join",:l] and member(cat,l) => true + [vv,.,.]:= compMakeCategoryObject(vmode,$e) + catlist := vv.4 + --catlist := SUBST(name,'$,vv.4) + null vv => stackSemanticError(["can't make category of ",name],nil) + member(cat,first catlist) => true --checks princ. ancestors + (u:=assoc(cat,CADR catlist)) and knownInfo(CADR u) => true + -- previous line checks fundamental anscestors, we should check their + -- principal anscestors but this requires instantiating categories + + -- This line caused recursion on predicates which are no use in deciding + -- whether a category was present. +-- this is correct TPD feb, 19, 2003 + or/[AncestorP(cat,LIST CAR u) for u in CADR catlist | knownInfo CADR u] => true +-- this is wrong TPD feb, 19, 2003 + -- or/[AncestorP(cat,LIST CAR u) and knownInfo CADR u for u in CADR catlist] => true + false + pred is ["SIGNATURE",name,op,sig,:.] => + v:= get(op,"modemap",$e) + for w in v repeat + ww:= CDAR w + --the actual signature part + LENGTH ww=LENGTH sig and SourceLevelSubsume(ww,sig) => + --NULL CAADR w => return false + CAADR w = true => return true + --return false + --error '"knownInfo" + false + +--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) +actOnInfo(u,$e) == + null u => $e + u is ["PROGN",:l] => (for v in l repeat $e:= actOnInfo(v,$e); $e) + $e:= + put("$Information","special",Info:= [u,:get("$Information","special",$e)],$e + ) + u is ["COND",:l] => + --there is nowhere %else that this sort of thing exists + for [ante,:conseq] in l repeat + if member(hasToInfo ante,Info) then for v in conseq repeat + $e:= actOnInfo(v,$e) + $e + u is ["ATTRIBUTE",name,att] => + [vval,vmode,venv]:= GetValue name + SAY("augmenting ",name,": ",u) + key:= if CONTAINED("$",vmode) then "domain" else name + cat:= ["CATEGORY",key,["ATTRIBUTE",att]] + $e:= put(name,"value",[vval,mkJoin(cat,vmode),venv],$e) + --there is nowhere %else that this sort of thing exists + u is ["SIGNATURE",name,operator,modemap] => + implem:= + (implem:=assoc([name,:modemap],get(operator,'modemap,$e))) => + CADADR implem + ['ELT,name,nil] + $e:= addModemap(operator,name,modemap,true,implem,$e) + [vval,vmode,venv]:= GetValue name + SAY("augmenting ",name,": ",u) + key:= if CONTAINED("$",vmode) then "domain" else name + cat:= ["CATEGORY",key,["SIGNATURE",operator,modemap]] + $e:= put(name,"value",[vval,mkJoin(cat,vmode),venv],$e) + u is ["has",name,cat] => + [vval,vmode,venv]:= GetValue name + cat=vmode => $e --stating the already known + u:= compMakeCategoryObject(cat,$e) => + --we are adding information about a category + [catvec,.,$e]:= u + [ocatvec,.,$e]:= compMakeCategoryObject(vmode,$e) + -- member(vmode,CAR catvec.4) => + -- JHD 82/08/08 01:40 This does not mean that we can ignore the + -- extension, since this may not be compatible with the view we + -- were passed + + --we are adding a principal descendant of what was already known + -- $e:= augModemapsFromCategory(name,name,nil,catvec,$e) + -- SAY("augmenting ",name,": ",cat) + -- put(name, "value", (vval, cat, venv), $e) + member(cat,first ocatvec.4) or + assoc(cat,CADR ocatvec.4) is [.,'T,.] => $e + --SAY("Category extension error: + --cat shouldn't be a join + --what was being asserted is an ancestor of what was known + if name="$" + then $e:= augModemapsFromCategory(name,name,name,cat,$e) + else + viewName:=genDomainViewName(name,cat) + genDomainView(viewName,name,cat,"HasCategory") + if not MEMQ(viewName,$functorLocalParameters) then + $functorLocalParameters:=[:$functorLocalParameters,viewName] + SAY("augmenting ",name,": ",cat) + $e:= put(name,"value",[vval,mkJoin(cat,vmode),venv],$e) + SAY("extension of ",vval," to ",cat," ignored") + $e + systemError '"knownInfo" + +mkJoin(cat,mode) == + mode is ['Join,:cats] => ['Join,cat,:cats] + ['Join,cat,mode] + +GetValue name == + u:= get(name,"value",$e) => u + u:= comp(name,$EmptyMode,$e) => u --name may be a form + systemError [name,'" is not bound in the current environment"] + |