aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/category.boot6
-rw-r--r--src/interp/compiler.boot25
-rw-r--r--src/interp/define.boot94
-rw-r--r--src/interp/functor.boot10
-rw-r--r--src/interp/info.boot57
-rw-r--r--src/interp/nruncomp.boot6
-rw-r--r--src/interp/wi1.boot6
-rw-r--r--src/interp/wi2.boot21
8 files changed, 84 insertions, 141 deletions
diff --git a/src/interp/category.boot b/src/interp/category.boot
index 15fe1efe..dbdf9919 100644
--- a/src/interp/category.boot
+++ b/src/interp/category.boot
@@ -370,8 +370,10 @@ FindFundAncs l ==
CatEval: %Thing -> %Shell
CatEval x ==
REFVECP x => x
- $InteractiveMode => first compMakeCategoryObject(x,$CategoryFrame)
- first compMakeCategoryObject(x,$e)
+ e :=
+ $InteractiveMode => $CategoryFrame
+ $e
+ (compMakeCategoryObject(x,e)).expr
--RemovePrinAncs(l,leaves) ==
-- l=nil => nil
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index 6cf3cc84..aa09ea1f 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -267,7 +267,7 @@ compWithMappingMode(x,m is ["Mapping",m',:sl],oldE) ==
) and extendsCategoryForm("$",target,m') then return [x,m,e]
if STRINGP x then x:= INTERN x
for m in sl for v in (vl:= take(#sl,$FormalMapVariableList)) repeat
- [.,.,e]:= compMakeDeclaration([":",v,m],$EmptyMode,e)
+ [.,.,e]:= compMakeDeclaration(v,m,e)
(vl ^= nil) and not hasFormalMapVariable(x, vl) => return
[u,.,.] := comp([x,:vl],m',e) or return nil
extractCodeAndConstructTriple(u, m, oldE)
@@ -787,7 +787,7 @@ compSetq(["%LET",form,val],m,E) ==
compSetq1(form,val,m,E) ==
IDENTP form => setqSingle(form,val,m,E)
form is [":",x,y] =>
- [.,.,E']:= compMakeDeclaration(form,$EmptyMode,E)
+ [.,.,E']:= compMakeDeclaration(x,y,E)
compSetq(["%LET",x,val],m,E')
form is [op,:l] =>
op="CONS" => setqMultiple(uncons form,val,m,E)
@@ -797,7 +797,7 @@ compSetq1(form,val,m,E) ==
compMakeDeclaration: (%Form,%Mode,%Env) -> %Maybe %Triple
compMakeDeclaration(x,m,e) ==
$insideExpressionIfTrue: local := false
- compColon(x,m,e)
+ compColon([":",x,m],$EmptyMode,e)
setqSetelt([v,:s],val,m,E) ==
comp(["setelt",v,:s,val],m,E)
@@ -1828,7 +1828,7 @@ compRetractAlternative(x,t,stmt,m,s,T) ==
-- 1.3. Everything else failed; nice try.
else return stackAndThrow('"%1 is not retractable to %2bp",[s,t])
-- 2. Now declare `x'.
- [.,.,e] := compMakeDeclaration([":",x,t],$EmptyMode,e) or return nil
+ [.,.,e] := compMakeDeclaration(x,t,e) or return nil
e := put(x,"value",[genSomeVariable(),t,e],e)
-- 3. Compile body of the retract pattern.
stmtT := comp(stmt,m,e) or return
@@ -1863,7 +1863,7 @@ compRecoverAlternative(x,t,stmt,m,s,T) ==
stackAndThrow('"Scrutinee must be of type %b Any %d in type recovery alternative of case pattern",nil)
caseCode := ["EQUAL",["devaluate",t],["objMode",y]]
-- 2. Declare `x'.
- [.,.,e] := compMakeDeclaration([":",x,t],$EmptyMode,e) or return nil
+ [.,.,e] := compMakeDeclaration(x,t,e) or return nil
e := put(x,"value",[genSomeVariable(),t,e],e)
-- 3. Compile body of alternative
stmtT := comp(stmt,m,e) or return
@@ -1885,8 +1885,7 @@ compMatch(["%Match",subject,altBlock],m,e) ==
-- 1. subjectTmp := subject
[se,sm,e] := comp(subject,$EmptyMode,e) or return nil
sn := GENSYM()
- [.,.,e] := compMakeDeclaration([":",sn,sm],$EmptyMode,e)
- or return nil
+ [.,.,e] := compMakeDeclaration(sn,sm,e) or return nil
e := put(sn,"value",[genSomeVariable(),sm,e],e)
-- 2. compile alternatives.
altsCode := nil
@@ -2046,7 +2045,7 @@ compIterator(it,e) ==
modeIsAggregateOf("List",m,e) or return
stackMessage('"mode: %1pb must be a list of some mode",[m])
if null get(x,"mode",e) then [.,.,e]:=
- compMakeDeclaration([":",x,mUnder],$EmptyMode,e) or return nil
+ compMakeDeclaration(x,mUnder,e) or return nil
e:= put(x,"value",[genSomeVariable(),mUnder,e],e)
[y'',m'',e] := coerce([y',m,e], mOver) or return nil
[["IN",x,y''],e]
@@ -2058,7 +2057,7 @@ compIterator(it,e) ==
modeIsAggregateOf("List",m,e) or return
stackMessage('"mode: %1pb must be a list of other modes",[m])
if null get(x,"mode",e) then [.,.,e]:=
- compMakeDeclaration([":",x,m],$EmptyMode,e) or return nil
+ compMakeDeclaration(x,m,e) or return nil
e:= put(x,"value",[genSomeVariable(),m,e],e)
[y'',m'',e] := coerce([y',m,e], mOver) or return nil
[["ON",x,y''],e]
@@ -2077,7 +2076,7 @@ compIterator(it,e) ==
$NonNegativeInteger
$SmallInteger
if null get(index,"mode",e) then [.,.,e]:=
- compMakeDeclaration([":",index,indexmode],$EmptyMode,
+ compMakeDeclaration(index,indexmode,
(final' => final'.env; inc'.env)) or return nil
e:= put(index,"value",[genSomeVariable(),indexmode,e],e)
if final' then optFinal:= [final'.expr]
@@ -2097,7 +2096,7 @@ compIterator(it,e) ==
comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger
$Integer
if null get(index,"mode",e) then [.,.,e]:=
- compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil
+ compMakeDeclaration(index,indexmode,e) or return nil
e:= put(index,"value",[genSomeVariable(),indexmode,e],e)
[["STEP",index,start,inc,:optFinal],e]
it is ["WHILE",p] =>
@@ -2161,7 +2160,7 @@ compIteratorV(it,e) ==
comp(start,$NonNegativeInteger,e) => $NonNegativeInteger
$Integer
if null get(index,"mode",e) then [.,.,e]:=
- compMakeDeclaration([":",index,indexmode],$EmptyMode,final'.env) or
+ compMakeDeclaration(index,indexmode,final'.env) or
return nil
e:= put(index,"value",[genSomeVariable(),indexmode,e],e)
[["ISTEP",index,start'.expr,inc'.expr,final'.expr],e]
@@ -2179,7 +2178,7 @@ compIteratorV(it,e) ==
comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger
$Integer
if null get(index,"mode",e) then [.,.,e]:=
- compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil
+ compMakeDeclaration(index,indexmode,e) or return nil
e:= put(index,"value",[genSomeVariable(),indexmode,e],e)
[["STEP",index,start,inc,final],e]
nil
diff --git a/src/interp/define.boot b/src/interp/define.boot
index a4c31697..7c95510e 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -83,7 +83,6 @@ $NRTslot1PredicateList := []
$NRTattributeAlist := []
$NRTslot1Info := nil
$NRTdeltaListComp := []
-$NRTdomainFormList := []
$template := nil
$signature := nil
$isOpPackageName := false
@@ -182,7 +181,7 @@ $reservedNames == '(per rep _$)
++ Check that `var' (a variable of parameter name) is not a reversed name.
checkVariableName var ==
MEMQ(var,$reservedNames) =>
- stackAndThrow('"You cannot reserved name %1b as variable",[var])
+ stackAndThrow('"You cannot use reserved name %1b as variable",[var])
checkParameterNames parms ==
for p in parms repeat
@@ -279,10 +278,6 @@ compDefine1(form,m,e) ==
-- here signature of lhs is determined by a previous declaration
compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e)
if signature.target=$Category then $insideCategoryIfTrue:= true
---?? following 3 lines seem bogus, BMT 6/23/93
---? if signature.target is ['Mapping,:map] then
---? signature:= map
---? form:= ['DEF,lhs,signature,specialCases,rhs]
-- RDJ (11/83): when argument and return types are all declared,
-- or arguments have types declared in the environment,
@@ -337,10 +332,7 @@ getTargetFromRhs(lhs,rhs,e) ==
rhs is ['add,D,['CAPSULE,:.]] => getTargetFromRhs(lhs,D,e)
rhs is ['Record,:l] => ['RecordCategory,:l]
rhs is ['Union,:l] => ['UnionCategory,:l]
- rhs is ['List,:l] => ['ListCategory,:l]
- rhs is ['Vector,:l] => ['VectorCategory,:l]
- [.,target,.]:= compOrCroak(rhs,$EmptyMode,e)
- target
+ (compOrCroak(rhs,$EmptyMode,e)).mode
giveFormalParametersValues(argl,e) ==
for x in argl repeat
@@ -419,15 +411,13 @@ compDefineCategory1(df is ['DEF,form,sig,sc,body],m,e,prefix,fal) ==
[d,m,e] := T
[d,m,e]
-$tvl := []
-$mvl := []
-
makeCategoryPredicates(form,u) ==
$tvl: local := TAKE(#rest form,$TriangleVariableList)
$mvl: local := TAKE(#rest form,rest $FormalMapVariableList)
fn(u,nil) where
fn(u,pl) ==
u is ['Join,:.,a] => fn(a,pl)
+ u is ["IF",p,:x] => fnl(x,insert(EQSUBSTLIST($mvl,$tvl,p),pl))
u is ['has,:.] => insert(EQSUBSTLIST($mvl,$tvl,u),pl)
u is [op,:.] and MEMQ(op,'(SIGNATURE ATTRIBUTE)) => pl
atom u => pl
@@ -502,7 +492,7 @@ compDefineCategory2(form,signature,specialCases,body,m,e,
$getDomainCode: local := nil
$addForm: local:= nil
for x in sargl for t in rest signature' repeat
- [.,.,e]:= compMakeDeclaration([":",x,t],m,e)
+ [.,.,e]:= compMakeDeclaration(x,t,e)
-- 4. compile body in environment of %type declarations for arguments
op':= $op
@@ -585,6 +575,11 @@ compMakeCategoryObject(c,$e) ==
not isCategoryForm(c,$e) => nil
u:= mkEvalableCategoryForm c => [eval u,$Category,$e]
nil
+
+predicatesFromAttributes: %List -> %List
+predicatesFromAttributes attrList ==
+ REMDUP [second x for x in attrList]
+
compDefineFunctor(df,m,e,prefix,fal) ==
$domainShell: local := nil -- holds the category of the object being compiled
@@ -602,12 +597,6 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body],
-- 1. bind global variables
$addForm: local := nil
$subdomain: local := false
- $viewNames: local:= nil
-
- --This list is only used in genDomainViewName, for generating names
- --for alternate views, if they do not already exist.
- --format: Alist: (domain name . sublist)
- --sublist is alist: category . name of view
$functionStats: local:= [0,0]
$functorStats: local:= [0,0]
$form: local := nil
@@ -618,7 +607,6 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body],
--Set in doIt, accessed in the compiler - compNoStacking
$functorForm: local := nil
$functorLocalParameters: local := nil
- SETQ($myFunctorBody, body)
$CheckVectorList: local := nil
--prevents CheckVector from printing out same message twice
$getDomainCode: local -- code for getting views
@@ -635,11 +623,10 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body],
--true if domain has mutable state
signature':=
[first signature,:[getArgumentModeOrMoan(a,form,$e) for a in argl]]
- $functorForm:= $form:= [$op,:argl]
- if null first signature' then signature':=
+ $functorForm := $form := [$op,:argl]
+ if null signature'.target then signature':=
modemap2Signature getModemap($form,$e)
- target:= first signature'
- $functorTarget:= target
+ $functorTarget := target := signature'.target
$functorKind: local :=
$functorTarget is ["CATEGORY",key,:.] => key
"domain"
@@ -651,13 +638,9 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body],
--+ copy needed since slot1 is reset; compMake.. can return a cached vector
attributeList := ds.2 --see below under "loadTimeAlist"
--+ 7 lines for $NRT follow
--->--these globals used by NRTmakeCategoryAlist, set by NRTsetVector4Part1
$condAlist: local := nil
$uncondAlist: local := nil
--->>-- next global initialized here, reset by buildFunctor
- $NRTslot1PredicateList: local :=
- REMDUP [CADR x for x in attributeList]
--->>-- next global initialized here, used by NRTgenAttributeAlist (NRUNOPT)
+ $NRTslot1PredicateList: local := predicatesFromAttributes attributeList
$NRTattributeAlist: local := NRTgenInitialAttributeAlist attributeList
$NRTslot1Info: local := nil --set in NRTmakeSlot1Info
--this is used below to set $lisplibSlot1 global
@@ -665,13 +648,11 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body],
$NRTdeltaList: local := nil --list of misc. elts used in compiled fncts
$NRTdeltaListComp: local := nil --list of compiled forms for $NRTdeltaList
$NRTdeltaLength: local := 0 -- =length of block of extra entries in vector
- $NRTdomainFormList: local := nil -- of form ((gensym . (Repe...)) ...
- -- the above optimizes the calls to local domains
$template: local:= nil --stored in the lisplib
$functionLocations: local := nil --locations of defined functions in source
-- generate slots for arguments first, then for $NRTaddForm in compAdd
for x in argl repeat NRTgetLocalIndex x
- [.,.,$e]:= compMakeDeclaration([":",'_$,target],m,$e)
+ [.,.,$e]:= compMakeDeclaration("$",target,$e)
if not $insideCategoryPackageIfTrue then
$e:= augModemapsFromCategory('_$,'_$,'_$,target,$e)
$signature:= signature'
@@ -850,31 +831,10 @@ makeFunctorArgumentParameters(argl,sigl,target) ==
['Join,s,['CATEGORY,'package,:ss]]
fn(a,s) ==
isCategoryForm(s,$CategoryFrame) =>
- s is ["Join",:catlist] => genDomainViewList0(a,rest s)
+ s is ["Join",:catlist] => genDomainViewList(a,rest s)
[genDomainView(a,a,s,"getDomainView")]
[a]
-genDomainViewList0(id,catlist) ==
- l:= genDomainViewList(id,catlist,true)
- l
-
-genDomainViewList(id,catlist,firsttime) ==
- null catlist => nil
- catlist is [y] and not isCategoryForm(y,$EmptyEnvironment) => nil
- [genDomainView(if firsttime then id else genDomainViewName(id,first catlist),
- id,first catlist,"getDomainView"),:genDomainViewList(id,rest catlist,nil)]
-
-genDomainView(viewName,originalName,c,viewSelector) ==
- c is ['CATEGORY,.,:l] => genDomainOps(viewName,originalName,c)
- code:=
- c is ['SubsetCategory,c',.] => c'
- c
- $e:= augModemapsFromCategory(originalName,viewName,nil,c,$e)
- cd:= ["%LET",viewName,[viewSelector,originalName,mkTypeForm code]]
- if null member(cd,$getDomainCode) then
- $getDomainCode:= [cd,:$getDomainCode]
- viewName
-
genDomainOps(viewName,dom,cat) ==
oplist:= getOperationAlist(dom,dom,cat)
siglist:= [sig for [sig,:.] in oplist]
@@ -890,6 +850,22 @@ genDomainOps(viewName,dom,cat) ==
$e:= addModemap(op,dom,sig,cond,['ELT,viewName,i],$e)
viewName
+genDomainView(viewName,originalName,c,viewSelector) ==
+ c is ['CATEGORY,.,:l] => genDomainOps(viewName,originalName,c)
+ code:=
+ c is ['SubsetCategory,c',.] => c'
+ c
+ $e:= augModemapsFromCategory(originalName,viewName,nil,c,$e)
+ cd:= ["%LET",viewName,[viewSelector,originalName,mkTypeForm code]]
+ if null member(cd,$getDomainCode) then
+ $getDomainCode:= [cd,:$getDomainCode]
+ viewName
+
+genDomainViewList: (%Symbol,%List) -> %List
+genDomainViewList(id,catlist) ==
+ [genDomainView(id,id,cat,"getDomainView")
+ for cat in catlist | isCategoryForm(cat,$EmptyEnvironment)]
+
mkOpVec(dom,siglist) ==
dom:= getPrincipalView dom
substargs:= [['$,:dom.0],:
@@ -907,9 +883,6 @@ mkOpVec(dom,siglist) ==
ops.i := [function Undef,[dom.0,i],:opSig]
ops
-genDomainViewName(a,category) ==
- a
-
compDefWhereClause(['DEF,form,signature,specialCases,body],m,e) ==
-- form is lhs (f a1 ... an) of definition; body is rhs;
-- signature is (t0 t1 ... tn) where t0= target type, ti=type of ai, i > 0;
@@ -1203,8 +1176,6 @@ compArgumentConditions e ==
[n,x,T.expr]
e
-$body := nil
-
addArgumentConditions($body,$functionName) ==
$argumentConditionList =>
--$body is only used in this function
@@ -1466,7 +1437,7 @@ compSubDomain(["SubDomain",domainForm,predicate],m,e) ==
compSubDomain1(domainForm,predicate,m,e) ==
[.,.,e]:=
- compMakeDeclaration([":","#1",domainForm],$EmptyMode,addDomain(domainForm,e))
+ compMakeDeclaration("#1",domainForm,addDomain(domainForm,e))
u:=
compCompilerPredicate(predicate,e) or
stackSemanticError(["predicate: ",predicate,
@@ -1500,7 +1471,6 @@ processFunctor(form,signature,data,localParList,e) ==
buildFunctor(form,signature,data,localParList,e)
compCapsuleItems(itemlist,$predl,$e) ==
- $myFunctorBody :local := nil ---needed for translator
$signatureOfForm: local := nil
$suffix: local:= 0
for item in itemlist repeat
diff --git a/src/interp/functor.boot b/src/interp/functor.boot
index f2cab9ca..5f65c312 100644
--- a/src/interp/functor.boot
+++ b/src/interp/functor.boot
@@ -530,7 +530,7 @@ DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes) ==
return nil
--I should check that the actual arguments are of the right type
for u in formalArgs for m in newModes repeat
- [.,.,e]:= compMakeDeclaration(['_:,u,m],m,e)
+ [.,.,e]:= compMakeDeclaration(u,m,e)
--we can not substitute in the formal arguments before we comp
--for that may change the shape of the object, but we must before
--we match signatures
@@ -594,7 +594,7 @@ DescendCode(code,flag,viewAssoc,EnvToPass) ==
NREVERSE [v for u in REVERSE codelist |
(v:= DescendCode(u,flag,viewAssoc,EnvToPass))^=nil]]
code is ['COND,:condlist] =>
- c:= [[u2:= ProcessCond(first u,viewAssoc),:q] for u in condlist] where q() ==
+ c:= [[u2:= ProcessCond first u,:q] for u in condlist] where q() ==
null u2 => nil
f:=
TruthP u2 => flag;
@@ -622,7 +622,7 @@ DescendCode(code,flag,viewAssoc,EnvToPass) ==
code:=["setShellEntry",["getShellEntry",'$,5],#$locals-#u,code]
$epilogue:=
TruthP flag => [code,:$epilogue]
- [['COND,[ProcessCond(flag,viewAssoc),code]],:$epilogue]
+ [['COND,[ProcessCond flag,code]],:$epilogue]
nil
code
code -- doItIf deletes entries from $locals so can't optimize this
@@ -638,7 +638,7 @@ DescendCode(code,flag,viewAssoc,EnvToPass) ==
if not $insideCategoryPackageIfTrue then
updateCapsuleDirectory(rest u, flag)
ConstantCreator u =>
- if not (flag=true) then u:= ['COND,[ProcessCond(flag,viewAssoc),u]]
+ if not (flag=true) then u:= ['COND,[ProcessCond flag,u]]
$ConstantAssignments:= [u,:$ConstantAssignments]
nil
u
@@ -661,7 +661,7 @@ ConstantCreator u ==
u is ['CONS,:.] => false
true
-ProcessCond(cond,viewassoc) ==
+ProcessCond cond ==
ncond := SUBLIS($pairlis,cond)
INTEGERP POSN1(ncond,$NRTslot1PredicateList) => predicateBitRef ncond
cond
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")
diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot
index 49713af5..72d88b88 100644
--- a/src/interp/nruncomp.boot
+++ b/src/interp/nruncomp.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2008, Gabriel Dos Reis.
+-- Copyright (C) 2007-2009, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -465,11 +465,9 @@ buildFunctor($definition is [name,:args],sig,code,$locals,$e) ==
$CheckVectorList := NRTcheckVector domainShell
--CODE: part 1
- codePart1:= [:devaluateCode,:domainFormCode,createDomainCode,
+ codePart1:= [:devaluateCode,createDomainCode,
createViewCode,setVector0Code, slot3Code,:slamCode] where
devaluateCode:= [["%LET",b,['devaluate,a]] for [a,:b] in $devaluateList]
- domainFormCode := [["%LET",a,b] for [a,:b] in nreverse $NRTdomainFormList]
- --$NRTdomainFormList is unused now
createDomainCode:=
["%LET",domname,['LIST,MKQ first $definition,:ASSOCRIGHT $devaluateList]]
createViewCode:= ["%LET",'$,["newShell", $NRTbase + $NRTdeltaLength]]
diff --git a/src/interp/wi1.boot b/src/interp/wi1.boot
index 718b413c..d7399ea5 100644
--- a/src/interp/wi1.boot
+++ b/src/interp/wi1.boot
@@ -321,7 +321,7 @@ compWithMappingMode(x,m,oldE) ==
) and extendsCategoryForm("$",target,m') then return [x,m,e]
if STRINGP x then x:= INTERN x
for m in sl for v in (vl:= take(#sl,$FormalMapVariableList)) repeat
- [.,.,e]:= compMakeDeclaration([":",v,m],$EmptyMode,e)
+ [.,.,e]:= compMakeDeclaration(v,m,e)
not null vl and not hasFormalMapVariable(x, vl) => return
[u,.,.] := comp([x,:vl],m',e) or return nil
extractCodeAndConstructTriple(u, m, oldE)
@@ -539,7 +539,7 @@ compSetq1(oform,val,m,E) ==
form := markKillAll oform
IDENTP form => setqSingle(form,val,m,E)
form is [":",x,y] =>
- [.,.,E']:= compMakeDeclaration(form,$EmptyMode,E)
+ [.,.,E']:= compMakeDeclaration(x,y,E)
compSetq(["%LET",x,val],m,E')
form is [op,:l] =>
op="CONS" => setqMultiple(uncons form,val,m,E)
@@ -1195,7 +1195,7 @@ compDefineCategory2(form,signature,specialCases,body,m,e,
$getDomainCode: local := nil
$addForm: local:= nil
for x in sargl for t in rest signature' repeat
- [.,.,e]:= compMakeDeclaration([":",x,t],m,e)
+ [.,.,e]:= compMakeDeclaration(x,t,e)
-- 4. compile body in environment of %type declarations for arguments
op':= $op
diff --git a/src/interp/wi2.boot b/src/interp/wi2.boot
index 5b8a57cb..6d325b0f 100644
--- a/src/interp/wi2.boot
+++ b/src/interp/wi2.boot
@@ -46,12 +46,6 @@ compDefineFunctor1(df, m,$e,$prefix,$formalArgList) ==
[lineNumber,:$functorSpecialCases] := $functorSpecialCases
-- 1. bind global variables
$addForm: local := nil
- $viewNames: local:= nil
-
- --This list is only used in genDomainViewName, for generating names
- --for alternate views, if they do not already exist.
- --format: Alist: (domain name . sublist)
- --sublist is alist: category . name of view
$functionStats: local:= [0,0]
$functorStats: local:= [0,0]
$DEFdepth : local := 0 --for conversion to new compiler 3/93
@@ -125,13 +119,11 @@ compDefineFunctor1(df, m,$e,$prefix,$formalArgList) ==
$NRTdeltaList: local := nil --list of misc. elts used in compiled fncts
$NRTdeltaListComp: local := nil --list of compiled forms for $NRTdeltaList
$NRTdeltaLength: local := 0 -- =length of block of extra entries in vector
- $NRTdomainFormList: local := nil -- of form ((gensym . (Repe...)) ...
- -- the above optimizes the calls to local domains
$template: local:= nil --stored in the lisplib
$functionLocations: local := nil --locations of defined functions in source
-- generate slots for arguments first, then for $NRTaddForm in compAdd
for x in argl repeat NRTgetLocalIndex x
- [.,.,$e]:= compMakeDeclaration([":",'_$,target],m,$e)
+ [.,.,$e]:= compMakeDeclaration("$",target,$e)
--The following loop sees if we can economise on ADDed operations
--by using those of Rep, if that is the same. Example: DIRPROD
if not $insideCategoryPackageIfTrue then
@@ -164,7 +156,6 @@ compDefineFunctor1(df, m,$e,$prefix,$formalArgList) ==
-- 4. compile body in environment of %type declarations for arguments
op':= $op
rettype:= signature'.target
- SETQ($myFunctorBody, body) --------> new <--------
T:= compFunctorBody(body,rettype,$e,parForm)
---------------> new <---------------------
$convert2NewCompiler =>
@@ -262,7 +253,7 @@ makeFunctorArgumentParameters(argl,sigl,target) ==
['Join,s,['CATEGORY,'package,:ss]]
fn(a,s) ==
isCategoryForm(s,$CategoryFrame) =>
- s is ["Join",:catlist] => genDomainViewList0(a,rest s)
+ s is ["Join",:catlist] => genDomainViewList(a,rest s)
[genDomainView(a,a,s,"getDomainView")]
[a]
@@ -826,7 +817,7 @@ compIterator(it,e) ==
modeIsAggregateOf("List",m,e) or modeIsAggregateOf("Vector",m,e) or return
stackMessage ["mode: ",m," must be a list or vector of some mode"]
if null get(x,"mode",e) then [.,.,e]:=
- compMakeDeclaration([":",x,mUnder],$EmptyMode,e) or return nil
+ compMakeDeclaration(x,mUnder,e) or return nil
e:= put(x,"value",[genSomeVariable(),mUnder,e],e)
markReduceIn(it, [["IN",x,y'],e])
it is ["ON",x,y] =>
@@ -842,7 +833,7 @@ compIterator(it,e) ==
modeIsAggregateOf("List",m,e) or return
stackMessage ["mode: ",m," must be a list of other modes"]
if null get(x,"mode",e) then [.,.,e]:=
- compMakeDeclaration([":",x,m],$EmptyMode,e) or return nil
+ compMakeDeclaration(x,m,e) or return nil
e:= put(x,"value",[genSomeVariable(),m,e],e)
[["ON",x,y'],e]
it is ["STEP",oindex,start,inc,:optFinal] =>
@@ -870,7 +861,7 @@ compIterator(it,e) ==
$Integer
-- markImport ['Segment,indexmode]
if null get(index,"mode",e) then [.,.,e]:=
- compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil
+ compMakeDeclaration(index,indexmode,e) or return nil
e:= put(index,"value",[genSomeVariable(),indexmode,e],e)
markReduceStep(it, [["STEP",markStep(index),start,inc,:optFinal],e])
it is ["WHILE",p] =>
@@ -908,7 +899,7 @@ smallIntegerStep(it,index,start,inc,optFinal,e) ==
maximalSuperType T.mode ^= $Integer => return nil
givenRange := T.mode
indexmode:= $SmallInteger
- [.,.,e]:= compMakeDeclaration([":",index,indexmode],$EmptyMode,
+ [.,.,e]:= compMakeDeclaration(index,indexmode,
(final' => final'.env; inc'.env)) or return nil
range :=
FIXP startNum and FIXP incNum =>
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-03 15:50:18 +0000