aboutsummaryrefslogtreecommitdiff
path: root/src/interp/i-spec1.boot.pamphlet
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2007-11-07 20:46:16 +0000
committerdos-reis <gdr@axiomatics.org>2007-11-07 20:46:16 +0000
commit45ce0071c30e84b72e4c603660285fa6a462e7f7 (patch)
tree0fbc27e2b283ac3509f0adec45447b6e0e60242d /src/interp/i-spec1.boot.pamphlet
parent51282a7ef3256b61db639aad48fb86af43c562bc (diff)
downloadopen-axiom-45ce0071c30e84b72e4c603660285fa6a462e7f7.tar.gz
* Makefile.pamphlet (i-toplev.$(FASLEXT)): New rule.
(i-syscmd.$(FASLEXT)): Likewise. (i-spec2.$(FASLEXT)): Likewise. (i-spec1.$(FASLEXT)): Likewise. (i-funsel.$(FASLEXT)): Likewise. (i-map.$(FASLEXT)): Likewise. (i-eval.$(FASLEXT)): Likewise. (i-coerfn.$(FASLEXT)): Likewise. (i-coerce.$(FASLEXT)): Likewise. (i-resolv.$(FASLEXT)): Likewise. (i-analy.$(FASLEXT)): Likewise. (i-code.$(FASLEXT)): Likewise. (i-intern.$(FASLEXT)): Likewise. (<<i-analy.clisp>>): Remove. (<<i-code.clisp>>): Likewise. (<<i-coerce.clisp>>): Likewise. (<<i-coerfn.clisp>>): Likewise. (<<i-eval.clisp>>): Likewise. (<<i-funsel.clisp>>): Likewise. (<<i-intern.clisp>>): Likewise. (<<i-map.clisp>>): Likewise. (<<i-resolv.clisp>>): Likewise. (<<i-spec1.clisp>>): Likewise. (<<i-spec2.clisp>>): Likewise. (<<i-syscmd.clisp>>): Likewise. (<<i-toplev.clisp>>): Likewise. (<<i-util.clisp>>): Likewise. * apply.boot (compFormWithModemap): Fix syntax. * i-analy.boot.pamphlet: Push into package "BOOT". * i-code.boot.pamphlet: Likewise. * i-coerce.boot.pamphlet: Likewise. * i-coerfn.boot.pamphlet: Likewise. * i-eval.boot.pamphlet: Likewise. * i-funsel.boot.pamphlet: Likewise. * i-intern.boot.pamphlet: Likewise. * i-map.boot.pamphlet: Likewise. * i-resolv.boot.pamphlet: Likewise. * i-spec1.boot.pamphlet: Likewise. * i-spec2.boot.pamphlet: Likewise. * i-syscmd.bot.pamphlet: Likewise. * i-toplev.boot.pamphlet: Likewise. * i-util.boot.pamphlet: Likewise.
Diffstat (limited to 'src/interp/i-spec1.boot.pamphlet')
-rw-r--r--src/interp/i-spec1.boot.pamphlet121
1 files changed, 62 insertions, 59 deletions
diff --git a/src/interp/i-spec1.boot.pamphlet b/src/interp/i-spec1.boot.pamphlet
index 8175bc6a..2e178fe0 100644
--- a/src/interp/i-spec1.boot.pamphlet
+++ b/src/interp/i-spec1.boot.pamphlet
@@ -89,17 +89,20 @@ There are several special modes used in these functions:
<<*>>=
<<license>>
+import '"i-analy"
+)package "BOOT"
+
-- Functions which require special handlers (also see end of file)
-SETANDFILEQ($repeatLabel, NIL)
-SETANDFILEQ($breakCount, 0)
-SETANDFILEQ($anonymousMapCounter, 0)
+$repeatLabel := NIL
+$breakCount := 0
+$anonymousMapCounter := 0
-SETANDFILEQ($specialOps, '(
- ADEF AlgExtension and case COERCE COLLECT construct Declare DEF Dollar
- equation error free has IF is isnt iterate break LET local MDEF or
- pretend QUOTE REDUCE REPEAT return SEQ TARGET Tuple typeOf where ))
+$specialOps := '(
+ ADEF AlgExtension _and _case COERCE COLLECT construct Declare DEF Dollar
+ equation error free has IF _is _isnt iterate _break LET _local MDEF _or
+ pretend QUOTE REDUCE REPEAT _return SEQ TARGET Tuple typeOf _where )
--% Void stuff
@@ -185,9 +188,9 @@ mkInterpTargetedADEF(t,vars,types,oldBody) ==
null first types =>
throwKeyedMsg("S2IS0056",NIL)
throwMessage '" map result type needed but not present."
- arglCode := ['LIST,:[argCode for type in rest types for var in vars]]
- where argCode == ['putValueValue,['mkAtreeNode,MKQ var],
- objNewCode(['wrap,var],type)]
+ arglCode := ["LIST",:[argCode for type in rest types for var in vars]]
+ where argCode() == ['putValueValue,['mkAtreeNode,MKQ var],
+ objNewCode(["wrap",var],type)]
put($mapName,'mapBody,oldBody,$e)
body := ['rewriteMap1,MKQ $mapName,arglCode,MKQ types]
compileADEFBody(t,vars,types,body,first types)
@@ -227,7 +230,7 @@ compileADEFBody(t,vars,types,body,computedResultType) ==
--
-- MCD 13/3/96
if not $definingMap and ($genValue or $compilingMap) then
- fun := ['function,['LAMBDA,[:vars,'envArg],body]]
+ fun := ["function",["LAMBDA",[:vars,'envArg],body]]
code := wrap timedEVALFUN ['LIST,fun]
else
$freeVariables := []
@@ -235,8 +238,8 @@ compileADEFBody(t,vars,types,body,computedResultType) ==
-- CCL does not support upwards funargs, so we check for any free variables
-- and pass them into the lambda as part of envArg.
body := checkForFreeVariables(body,"ALL")
- fun := ['function,['LAMBDA,[:vars,'envArg],body]]
- code := ['CONS, fun, ["VECTOR", :reverse $freeVariables]]
+ fun := ["function",["LAMBDA",[:vars,'envArg],body]]
+ code := ["CONS", fun, ["VECTOR", :reverse $freeVariables]]
val := objNew(code,rt := ['Mapping,computedResultType,:rest types])
putValue(t,val)
@@ -316,9 +319,9 @@ upand x ==
ms := bottomUp term2
ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"and_""],term2)
-- generate an IF expression and let the rest of the code handle it
- cond := [mkAtreeNode "=",mkAtree 'false,term1]
+ cond := [mkAtreeNode "=",mkAtree "false",term1]
putTarget(cond,$Boolean)
- code := [mkAtreeNode 'IF,cond,mkAtree 'false,term2]
+ code := [mkAtreeNode "IF",cond,mkAtree "false",term2]
putTarget(code,$Boolean)
bottomUp code
putValue(x,getValue code)
@@ -346,9 +349,9 @@ upor x ==
ms := bottomUp term2
ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"or_""],term2)
-- generate an IF expression and let the rest of the code handle it
- cond := [mkAtreeNode "=",mkAtree 'true,term1]
+ cond := [mkAtreeNode "=",mkAtree "true",term1]
putTarget(cond,$Boolean)
- code := [mkAtreeNode 'IF,cond,mkAtree 'true,term2]
+ code := [mkAtreeNode "IF",cond,mkAtree "true",term2]
putTarget(code,$Boolean)
bottomUp code
putValue(x,getValue code)
@@ -363,16 +366,16 @@ upcase t ==
objMode(triple) isnt ['Union,:unionDoms] =>
throwKeyedMsg("S2IS0004",NIL)
if (rhs' := isDomainValuedVariable(rhs)) then rhs := rhs'
- if first unionDoms is ['_:,.,.] then
+ if first unionDoms is [":",.,.] then
for i in 0.. for d in unionDoms repeat
- if d is ['_:,=rhs,.] then rhstag := i
- if NULL rhstag then error "upcase: bad Union form"
+ if d is [":",=rhs,.] then rhstag := i
+ if NULL rhstag then error '"upcase: bad Union form"
$genValue =>
rhstag = first unwrap objVal triple => code := wrap 'TRUE
code := wrap NIL
code :=
- ['COND,
- [['EQL,rhstag,['CAR,['unwrap,objVal triple]]],
+ ["COND",
+ [["EQL",rhstag,["CAR",["unwrap",objVal triple]]],
''TRUE],
[''T,NIL]]
else
@@ -380,10 +383,10 @@ upcase t ==
t' := coerceUnion2Branch triple
rhs = objMode t' => code := wrap 'TRUE
code := wrap NIL
- triple' := objNewCode(['wrap,objVal triple],objMode triple)
+ triple' := objNewCode(["wrap",objVal triple],objMode triple)
code :=
- ['COND,
- [['EQUAL,MKQ rhs,['objMode,['coerceUnion2Branch,triple']]],
+ ["COND",
+ [["EQUAL",MKQ rhs,["objMode",['coerceUnion2Branch,triple']]],
''TRUE],
[''T,NIL]]
putValue(op,objNew(code,$Boolean))
@@ -463,29 +466,29 @@ evalCOERCE(op,tree,m) ==
transformCollect [:itrl,body] ==
-- syntactic transformation for COLLECT form, called from mkAtree1
- iterList:=[:iterTran1 for it in itrl] where iterTran1 ==
- it is ['STEP,index,lower,step,:upperList] =>
- [['STEP,index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper
+ iterList:=[:iterTran1 for it in itrl] where iterTran1() ==
+ it is ["STEP",index,lower,step,:upperList] =>
+ [["STEP",index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper
for upper in upperList]]]
- it is ['IN,index,s] =>
- [['IN,index,mkAtree1 s]]
- it is ['ON,index,s] =>
+ it is ["IN",index,s] =>
+ [["IN",index,mkAtree1 s]]
+ it is ["ON",index,s] =>
[['IN,index,mkAtree1 ['tails,s]]]
- it is ['WHILE,b] =>
- [['WHILE,mkAtree1 b]]
- it is ['_|,pred] =>
- [['SUCHTHAT,mkAtree1 pred]]
+ it is ["WHILE",b] =>
+ [["WHILE",mkAtree1 b]]
+ it is ["|",pred] =>
+ [["SUCHTHAT",mkAtree1 pred]]
it is [op,:.] and (op in '(VALUE UNTIL)) => nil
bodyTree:=mkAtree1 body
iterList:=NCONC(iterList,[:iterTran2 for it in itrl]) where
- iterTran2 ==
- it is ['STEP,:.] => nil
- it is ['IN,:.] => nil
- it is ['ON,:.] => nil
- it is ['WHILE,:.] => nil
+ iterTran2() ==
+ it is ["STEP",:.] => nil
+ it is ["IN",:.] => nil
+ it is ["ON",:.] => nil
+ it is ["WHILE",:.] => nil
it is [op,b] and (op in '(UNTIL)) =>
[[op,mkAtree1 b]]
- it is ['_|,pred] => nil
+ it is ["|",pred] => nil
keyedSystemError("S2GE0016",
['"transformCollect",'"Unknown type of iterator"])
[:iterList,bodyTree]
@@ -515,7 +518,7 @@ upCOLLECT1 t ==
ms:= bottomUpCompile body
[m]:= ms
for itr in itrl repeat
- itr is ['UNTIL, pred] => bottomUpCompilePredicate(pred,'"until")
+ itr is ["UNTIL", pred] => bottomUpCompilePredicate(pred,'"until")
mode:= ['Tuple,m]
evalCOLLECT(op,rest t,mode)
putModeSet(op,[mode])
@@ -523,15 +526,15 @@ upCOLLECT1 t ==
upLoopIters itrl ==
-- type analyze iterator loop iterators
for iter in itrl repeat
- iter is ['WHILE,pred] =>
+ iter is ["WHILE",pred] =>
bottomUpCompilePredicate(pred,'"while")
- iter is ['SUCHTHAT,pred] =>
+ iter is ["SUCHTHAT",pred] =>
bottomUpCompilePredicate(pred,'"|")
- iter is ['UNTIL,:.] =>
+ iter is ["UNTIL",:.] =>
NIL -- handle after body is analyzed
- iter is ['IN,index,s] =>
+ iter is ["IN",index,s] =>
upLoopIterIN(iter,index,s)
- iter is ['STEP,index,lower,step,:upperList] =>
+ iter is ["STEP",index,lower,step,:upperList] =>
upLoopIterSTEP(index,lower,step,upperList)
-- following is an optimization
typeIsASmallInteger(get(index,'mode,$env)) =>
@@ -985,10 +988,10 @@ subVecNodes(new,old,form) ==
mkIterVarSub(var,numVars) ==
n := iterVarPos var
n=2 =>
- [mkAtreeNode 'elt,mkNestedElts(numVars-2),mkAtreeNode 'part2]
+ [mkAtreeNode "elt",mkNestedElts(numVars-2),mkAtreeNode 'part2]
n=1 =>
- [mkAtreeNode 'elt,mkNestedElts(numVars-2),mkAtreeNode 'part1]
- [mkAtreeNode 'elt,mkNestedElts(numVars-n),mkAtreeNode 'part1]
+ [mkAtreeNode "elt",mkNestedElts(numVars-2),mkAtreeNode 'part1]
+ [mkAtreeNode "elt",mkNestedElts(numVars-n),mkAtreeNode 'part1]
iterVarPos var ==
for [index,:.] in reverse $indexVars for i in 1.. repeat
@@ -996,7 +999,7 @@ iterVarPos var ==
mkNestedElts n ==
n=0 => mkAtreeNode($index or ($index:= GENSYM()))
- [mkAtreeNode 'elt, mkNestedElts(n-1), mkAtreeNode 'part2]
+ [mkAtreeNode "elt", mkNestedElts(n-1), mkAtreeNode 'part2]
--% Handlers for construct
@@ -1135,8 +1138,8 @@ upRecordConstruct(op,l,tar) ==
for arg in l for ['_:,.,type] in types]
len := #l
code :=
- (len = 1) => ['CONS, :argCode, '()]
- (len = 2) => ['CONS,:argCode]
+ (len = 1) => ["CONS", :argCode, '()]
+ (len = 2) => ["CONS",:argCode]
['VECTOR,:argCode]
if $genValue then code := wrap timedEVALFUN code
putValue(op,objNew(code,tar))
@@ -1154,13 +1157,13 @@ upDeclare t ==
categoryForm?(mode) => throwKeyedMsgSP("S2IE0011",[mode, 'category],op)
packageForm?(mode) => throwKeyedMsgSP("S2IE0011",[mode, 'package],op)
junk :=
- lhs is ['free,['Tuple,:vars]] or lhs is ['free,['LISTOF,:vars]] or
- lhs is ['free,:vars] =>
+ lhs is ["free",['Tuple,:vars]] or lhs is ['free,['LISTOF,:vars]] or
+ lhs is ["free",:vars] =>
for var in vars repeat declare(['free,var],mode)
- lhs is ['local,['Tuple,:vars]] or lhs is ['local,['LISTOF,:vars]] or
- lhs is ['local,:vars] =>
- for var in vars repeat declare(['local,var],mode)
- lhs is ['Tuple,:vars] or lhs is ['LISTOF,:vars] =>
+ lhs is ["local",['Tuple,:vars]] or lhs is ['local,['LISTOF,:vars]] or
+ lhs is ["local",:vars] =>
+ for var in vars repeat declare(["local",var],mode)
+ lhs is ["Tuple",:vars] or lhs is ["LISTOF",:vars] =>
for var in vars repeat declare(var,mode)
declare(lhs,mode)
putValue(op,objNewWrap(voidValue(), $Void))