aboutsummaryrefslogtreecommitdiff
path: root/src/interp/info.boot
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp/info.boot')
-rw-r--r--src/interp/info.boot57
1 files changed, 20 insertions, 37 deletions
diff --git a/src/interp/info.boot b/src/interp/info.boot
index 68bf58e3..36daa11c 100644
--- a/src/interp/info.boot
+++ b/src/interp/info.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007, Gabriel Dos Reis.
+-- Copyright (C) 2007-2009, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -64,8 +64,7 @@ printInfo $e ==
nil
addInformation(m,$e) ==
- $Information: local
- --$Information:= nil: done by previous statement anyway
+ $Information: local := nil
info m where
info m ==
--Processes information from a mode declaration in compCapsule
@@ -78,12 +77,12 @@ addInformation(m,$e) ==
get("$Information","special",$e)],$e)
$e
-addInfo u == $Information:= [formatInfo u,:$Information]
+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] =>
@@ -153,11 +152,11 @@ infoToHas a ==
a is ["SIGNATURE",b,:data] => ["has",b,["SIGNATURE",:data]]
a is ["ATTRIBUTE",b,c] => ["has",b,["ATTRIBUTE",c]]
a
-
+
+++ Return true if we are certain that the information
+++ denotated by `pred' is derivable from the current environment.
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]
@@ -166,10 +165,10 @@ knownInfo pred ==
pred is ["ATTRIBUTE",name,attr] =>
v:= compForMode(name,$EmptyMode,$e) or return
stackAndThrow('"can't find category of %1pb",[name])
- [vv,.,.]:= compMakeCategoryObject(CADR v,$e) or return
+ [vv,.,.]:= compMakeCategoryObject(second v,$e) or return
stackAndThrow('"can't make category of %1pb",[name])
member(attr,vv.2) => true
- x:= assoc(attr,vv.2) => knownInfo CADR x
+ x:= assoc(attr,vv.2) => knownInfo second x
--format is a list of two elements: information, predicate
false
pred is ["has",name,cat] =>
@@ -178,33 +177,27 @@ knownInfo pred ==
name is ['Union,:.] => false
v:= compForMode(name,$EmptyMode,$e) or return
stackAndThrow('"can't find category of %1pb",[name])
- vmode := CADR v
+ vmode := second v
cat = vmode => true
vmode is ["Join",:l] and member(cat,l) => true
[vv,.,.]:= compMakeCategoryObject(vmode,$e) or return
stackAndThrow('"cannot find category %1pb",[vmode])
catlist := vv.4
member(cat,first catlist) => true --checks princ. ancestors
- (u:=assoc(cat,CADR catlist)) and knownInfo(CADR u) => true
+ (u:=assoc(cat,second catlist)) and knownInfo second 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
+ or/[AncestorP(cat,[first u])
+ for u in second catlist | knownInfo second u] => 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
+ ww:= CDAR w --the actual signature part
+ #ww = #sig and SourceLevelSubsume(ww,sig) =>
CAADR w = true => return true
- --return false
+ false
--error '"knownInfo"
false
@@ -247,27 +240,17 @@ actOnInfo(u,$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,second 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
+ --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]
+ genDomainView(name,name,cat,"HasCategory")
+ if not MEMQ(name,$functorLocalParameters) then
+ $functorLocalParameters:=[:$functorLocalParameters,name]
compilerMessage('"augmenting %1: %2p", [name,cat])
$e:= put(name,"value",[vval,mkJoin(cat,vmode),venv],$e)
SAY("extension of ",vval," to ",cat," ignored")