aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog22
-rw-r--r--src/algebra/riccati.spad.pamphlet2
-rw-r--r--src/interp/Makefile.in6
-rw-r--r--src/interp/Makefile.pamphlet6
-rw-r--r--src/interp/buildom.boot2
-rw-r--r--src/interp/clam.boot2
-rw-r--r--src/interp/compiler.boot290
-rw-r--r--src/interp/define.boot29
-rw-r--r--src/interp/format.boot2
-rw-r--r--src/interp/functor.boot20
-rw-r--r--src/interp/g-opt.boot5
-rw-r--r--src/interp/i-funsel.boot2
-rw-r--r--src/interp/i-intern.boot4
-rw-r--r--src/interp/i-spec2.boot2
-rw-r--r--src/interp/i-syscmd.boot2
-rw-r--r--src/interp/i-toplev.boot2
-rw-r--r--src/interp/iterator.boot307
-rw-r--r--src/interp/lisplib.boot6
-rw-r--r--src/interp/msgdb.boot6
-rw-r--r--src/interp/nrungo.boot2
-rw-r--r--src/interp/parse.boot55
-rw-r--r--src/interp/postpar.boot51
-rw-r--r--src/interp/preparse.lisp56
-rw-r--r--src/interp/wi1.boot4
-rw-r--r--src/interp/wi2.boot4
25 files changed, 430 insertions, 459 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 36ab6caf..73a444be 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,25 @@
+2008-12-14 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ * interp/compiler.boot (compFormWithModemap): Tidy.
+ (compLogicalNot): Rename from compNot.
+ (compExclusiveOr): New.
+ (compViableModemap): Likewise.
+ (compResolveCall): Likewise.
+ (compApplyModemap): Tidy.
+ (compMapCond): Tidy.
+ (compMapCond''): Remove.
+ * interp/parse.boot (parseExclusiveOr): Remove.
+ * interp/sys-constants.boot ($SideEffectFreeFunctionList): Include
+ "and", "or", and "not".
+ * interp/modemap.boot (getModemap): Adjust call to compApplyModemap.
+ * interp/nruncomp.boot (NRTputInHead): Error on SPADCONST form.
+ * algebra/boolean.spad.pamphlet (and$Boolean): Use Lisp operation.
+ (or$Boolean): Likewise.
+ (not$Boolean): Likewise.
+ * algebra/mappkg.spad.pamphlet (fixedPoint$MappingPackage1):
+ Specify return type for Lisp expression.
+ * algebra/strap: Update cached Lisp translation.
+
2008-12-12 Gabriel Dos Reis <gdr@cs.tamu.edu>
* interp/c-util.boot (ILinsn): New structure.
diff --git a/src/algebra/riccati.spad.pamphlet b/src/algebra/riccati.spad.pamphlet
index 2ba55a3e..9f4666c5 100644
--- a/src/algebra/riccati.spad.pamphlet
+++ b/src/algebra/riccati.spad.pamphlet
@@ -94,7 +94,7 @@ PrimitiveRatRicDE(F, UP, L, LQ): Exports == Implementation where
refine : (List UP, UP -> Factored UP) -> List UP
polysol : (L, N, Boolean, UP -> List F) -> List POL
fracsol : (L, (UP, UP2) -> List UP, List UP) -> List FRC
- padicsol l : (UP, L, N, Boolean, (UP, UP2) -> List UP) -> List FRC
+ padicsol : (UP, L, N, Boolean, (UP, UP2) -> List UP) -> List FRC
leadingDenomRicDE : (UP, L) -> List REC2
factoredDenomRicDE: L -> List UP
constantCoefficientOperator: (L, N) -> UP
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index 4c6bf1a3..4804f25b 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -94,7 +94,7 @@ INOBJS= setvart.$(FASLEXT) interop.$(FASLEXT) patches.$(FASLEXT)
OCOBJS= \
info.$(FASLEXT) modemap.$(FASLEXT) \
category.$(FASLEXT) define.$(FASLEXT) \
- iterator.$(FASLEXT) compiler.$(FASLEXT) \
+ compiler.$(FASLEXT) \
c-doc.$(FASLEXT) \
profile.$(FASLEXT) functor.$(FASLEXT) \
nruncomp.$(FASLEXT) htcheck.$(FASLEXT)
@@ -302,14 +302,12 @@ setvart.$(FASLEXT): macros.$(FASLEXT)
## OpenAxiom's compiler
wi2.$(FASLEXT): macros.$(FASLEXT) define.$(FASLEXT)
wi1.$(FASLEXT): macros.$(FASLEXT)
-compiler.$(FASLEXT): msgdb.$(FASLEXT) \
- pathname.$(FASLEXT) define.$(FASLEXT) iterator.$(FASLEXT)
+compiler.$(FASLEXT): msgdb.$(FASLEXT) pathname.$(FASLEXT) define.$(FASLEXT)
nrunopt.$(FASLEXT): c-util.$(FASLEXT)
nrunfast.$(FASLEXT): c-util.$(FASLEXT)
nruncomp.$(FASLEXT): nrunopt.$(FASLEXT) profile.$(FASLEXT) \
simpbool.$(FASLEXT) functor.$(FASLEXT)
nrungo.$(FASLEXT): c-util.$(FASLEXT) clam.$(FASLEXT) interop.$(FASLEXT)
-iterator.$(FASLEXT): g-util.$(FASLEXT)
define.$(FASLEXT): g-error.$(FASLEXT) modemap.$(FASLEXT) \
nruncomp.$(FASLEXT) database.$(FASLEXT)
database.$(FASLEXT): clam.$(FASLEXT) nlib.$(FASLEXT) \
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet
index 0be15564..7ba5f03b 100644
--- a/src/interp/Makefile.pamphlet
+++ b/src/interp/Makefile.pamphlet
@@ -205,7 +205,7 @@ The {\bf OCOBJS} list contains files from the old compiler. Again,
OCOBJS= \
info.$(FASLEXT) modemap.$(FASLEXT) \
category.$(FASLEXT) define.$(FASLEXT) \
- iterator.$(FASLEXT) compiler.$(FASLEXT) \
+ compiler.$(FASLEXT) \
c-doc.$(FASLEXT) \
profile.$(FASLEXT) functor.$(FASLEXT) \
nruncomp.$(FASLEXT) htcheck.$(FASLEXT)
@@ -551,14 +551,12 @@ setvart.$(FASLEXT): macros.$(FASLEXT)
## OpenAxiom's compiler
wi2.$(FASLEXT): macros.$(FASLEXT) define.$(FASLEXT)
wi1.$(FASLEXT): macros.$(FASLEXT)
-compiler.$(FASLEXT): msgdb.$(FASLEXT) \
- pathname.$(FASLEXT) define.$(FASLEXT) iterator.$(FASLEXT)
+compiler.$(FASLEXT): msgdb.$(FASLEXT) pathname.$(FASLEXT) define.$(FASLEXT)
nrunopt.$(FASLEXT): c-util.$(FASLEXT)
nrunfast.$(FASLEXT): c-util.$(FASLEXT)
nruncomp.$(FASLEXT): nrunopt.$(FASLEXT) profile.$(FASLEXT) \
simpbool.$(FASLEXT) functor.$(FASLEXT)
nrungo.$(FASLEXT): c-util.$(FASLEXT) clam.$(FASLEXT) interop.$(FASLEXT)
-iterator.$(FASLEXT): g-util.$(FASLEXT)
define.$(FASLEXT): g-error.$(FASLEXT) modemap.$(FASLEXT) \
nruncomp.$(FASLEXT) database.$(FASLEXT)
database.$(FASLEXT): clam.$(FASLEXT) nlib.$(FASLEXT) \
diff --git a/src/interp/buildom.boot b/src/interp/buildom.boot
index 2570cc82..c54958ad 100644
--- a/src/interp/buildom.boot
+++ b/src/interp/buildom.boot
@@ -294,7 +294,7 @@ UnionCategory(:"x") == constructorCategory ["Union",:x]
constructorCategory (title is [op,:.]) ==
constructorFunction:= GETL(op,"makeFunctionList") or
- systemErrorHere '"constructorCategory"
+ systemErrorHere ['"constructorCategory",title]
[funlist,.]:= FUNCALL(constructorFunction,"$",title,$CategoryFrame)
oplist:= [[[a,b],true,c] for [a,b,c] in funlist]
cat:=
diff --git a/src/interp/clam.boot b/src/interp/clam.boot
index b9b4e254..863b255c 100644
--- a/src/interp/clam.boot
+++ b/src/interp/clam.boot
@@ -488,7 +488,7 @@ assocCacheShiftCount(x,al,fn) ==
clamStats() ==
for [op,kind,:.] in $clamList repeat
- cacheVec:= GETL(op,'cacheInfo) or systemErrorHere "clamStats"
+ cacheVec:= GETL(op,'cacheInfo) or systemErrorHere ["clamStats",op]
prefix:=
$reportCounts^= true => nil
hitCounter:= INTERNL(op,'";hit")
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index f59babe7..49d99f9a 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -36,7 +36,6 @@ import msgdb
import pathname
import modemap
import define
-import iterator
namespace BOOT
module compiler where
@@ -83,7 +82,6 @@ reshapeArgumentList: (%Form,%Signature) -> %Form
applyMapping: (%Form,%Mode,%Env,%List) -> %Maybe %Triple
compMapCond: (%Symbol,%Mode,%Env,%List) -> %Code
compMapCond': (%List,%Symbol,%Mode,%Env) -> %Code
-compMapCond'': (%Thing,%Mode) -> %Boolean
compMapCondFun: (%Thing,%Symbol,%Mode,%Env) -> %Code
@@ -102,7 +100,6 @@ compTopLevel(x,m,e) ==
$NRTderivedTargetIfTrue: local := false
$killOptimizeIfTrue: local:= false
$forceAdd: local:= false
- $packagesUsed: local := []
x is ["DEF",:.] or x is ["where",["DEF",:.],:.] =>
([val,mode,.]:= compOrCroak(x,m,e); [val,mode,e])
--keep old environment after top level function defs
@@ -170,9 +167,6 @@ compNoStacking1(x,m,e,$compStack) ==
comp2(x,m,e) ==
[y,m',e]:= comp3(x,m,e) or return nil
- if $LISPLIB and isDomainForm(x,e) then
- if isFunctor x then
- $packagesUsed:= insert([opOf x],$packagesUsed)
--if null atom y and isDomainForm(y,e) then e := addDomain(x,e)
--line commented out to prevent adding derived domain forms
m^=m' and ($bootStrapMode or isDomainForm(m',e))=>[y,m',addDomain(m',e)]
@@ -1207,7 +1201,7 @@ canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends
atom op => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr]
op is ["XLAM",args,bods] =>
and/[canReturn(u,level,exitCount,ValueFlag) for u in expr]
- systemErrorHere '"canReturn" --for the time being
+ systemErrorHere ['"canReturn",expr] --for the time being
compBoolean(p,m,E) ==
[p',m,E]:= comp(p,m,E) or return nil
@@ -1367,14 +1361,14 @@ compColon([":",f,t],m,e) ==
f is ["LISTOF",:l] =>
(for x in l repeat T:= [.,.,e]:= compColon([":",x,t],m,e); T)
e:=
- f is [op,:argl] and not (t is ["Mapping",:.]) =>
+ f is [op,:argl] =>
--for MPOLY--replace parameters by formal arguments: RDJ 3/83
newTarget:= EQSUBSTLIST(take(#argl,$FormalMapVariableList),
[(x is [":",a,m] => a; x) for x in argl],t)
signature:=
["Mapping",newTarget,:
[(x is [":",a,m] => m;
- getmode(x,e) or systemErrorHere '"compColonOld") for x in argl]]
+ getmode(x,e) or systemErrorHere ['"compColon",x]) for x in argl]]
put(op,"mode",signature,e)
put(f,"mode",t,e)
if not $bootStrapMode and $insideFunctorIfTrue and
@@ -1600,7 +1594,7 @@ autoCoerceByModemap([x,source,e],target) ==
++ vararg operations.
compComma: (%Form,%Mode,%Env) -> %Maybe %Triple
compComma(form,m,e) ==
- form isnt ["%Comma",:argl] => systemErrorHere "compComma"
+ form isnt ["%Comma",:argl] => systemErrorHere ["compComma",form]
Tl := [comp(a,$EmptyMode,e) or return "failed" for a in argl]
Tl = "failed" => nil
-- ??? Ideally, we would like to compile to a Cross type, then
@@ -1885,7 +1879,282 @@ compMatch(["%Match",subject,altBlock],m,e) ==
[code,m,savedEnv]
+--%
+--% ITERATORS
+--%
+
+compReduce(form,m,e) ==
+ compReduce1(form,m,e,$formalArgList)
+
+compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) ==
+ [collectOp,:itl,body]:= collectForm
+ if STRINGP op then op:= INTERN op
+ ^MEMQ(collectOp,'(COLLECT COLLECTV COLLECTVEC)) =>
+ systemError ["illegal reduction form:",form]
+ $sideEffectsList: local := nil
+ $until: local := nil
+ $initList: local := nil
+ $endTestList: local := nil
+ oldEnv := e
+ $e:= e
+ itl:= [([.,$e]:= compIterator(x,$e) or return "failed").(0) for x in itl]
+ itl="failed" => return nil
+ e:= $e
+ acc:= GENSYM()
+ afterFirst:= GENSYM()
+ bodyVal:= GENSYM()
+ [part1,m,e]:= comp(["%LET",bodyVal,body],m,e) or return nil
+ [part2,.,e]:= comp(["%LET",acc,bodyVal],m,e) or return nil
+ [part3,.,e]:= comp(["%LET",acc,parseTran [op,acc,bodyVal]],m,e) or return nil
+ identityCode:=
+ id:= getIdentity(op,e) => u.expr where u() == comp(id,m,e) or return nil
+ ["IdentityError",MKQ op]
+ finalCode:=
+ ["PROGN",
+ ["%LET",afterFirst,nil],
+ ["REPEAT",:itl,
+ ["PROGN",part1,
+ ["IF", afterFirst,part3,
+ ["PROGN",part2,["%LET",afterFirst,MKQ true]]]]],
+ ["IF",afterFirst,acc,identityCode]]
+ if $until then
+ [untilCode,.,e]:= comp($until,$Boolean,e)
+ finalCode:= substitute(["UNTIL",untilCode],'$until,finalCode)
+ [finalCode,m,oldEnv]
+
+++ returns the identity element of the `reduction' operation `x'
+++ over a list -- a monoid homomorphism.
+getIdentity(x,e) ==
+ -- The empty list should be indicated by name, not by its
+ -- object representation.
+ GETL(x,"THETA") is [y] => (y => y; "nil")
+
+numberize x ==
+ x=$Zero => 0
+ x=$One => 1
+ atom x => x
+ [numberize first x,:numberize rest x]
+
+compRepeatOrCollect(form,m,e) ==
+ fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList
+ ,e) where
+ fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) ==
+ $until: local := nil
+ oldEnv := e
+ [repeatOrCollect,:itl,body]:= form
+ itl':=
+ [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl]
+ itl'="failed" => nil
+ targetMode:= first $exitModeStack
+ bodyMode:=
+ repeatOrCollect="COLLECT" =>
+ targetMode = '$EmptyMode => '$EmptyMode
+ (u:=modeIsAggregateOf('List,targetMode,e)) =>
+ CADR u
+ (u:=modeIsAggregateOf('PrimitiveArray,targetMode,e)) =>
+ repeatOrCollect:='COLLECTV
+ CADR u
+ (u:=modeIsAggregateOf('Vector,targetMode,e)) =>
+ repeatOrCollect:='COLLECTVEC
+ CADR u
+ stackMessage('"Invalid collect bodytype")
+ return nil
+ -- If we're doing a collect, and the type isn't conformable
+ -- then we've boobed. JHD 26.July.1990
+ $NoValueMode
+ [body',m',e']:=
+ compOrCroak(body,bodyMode,e) or return nil
+ if $until then
+ [untilCode,.,e']:= comp($until,$Boolean,e')
+ itl':= substitute(["UNTIL",untilCode],'$until,itl')
+ form':= [repeatOrCollect,:itl',body']
+ m'':=
+ repeatOrCollect="COLLECT" =>
+ (u:=modeIsAggregateOf('List,targetMode,e)) => CAR u
+ ["List",m']
+ repeatOrCollect="COLLECTV" =>
+ (u:=modeIsAggregateOf('PrimitiveArray,targetMode,e)) => CAR u
+ ["PrimitiveArray",m']
+ repeatOrCollect="COLLECTVEC" =>
+ (u:=modeIsAggregateOf('Vector,targetMode,e)) => CAR u
+ ["Vector",m']
+ m'
+ T := coerceExit([form',m'',e'],targetMode) or return nil
+ -- iterator variables and other variables declared in
+ -- in a loop are local to the loop.
+ [T.expr,T.mode,oldEnv]
+
+--constructByModemap([x,source,e],target) ==
+-- u:=
+-- [cexpr
+-- for (modemap:= [map,cexpr]) in getModemapList("construct",1,e) | map is [
+-- .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil
+-- fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil
+-- [["call",fn,x],target,e]
+
+listOrVectorElementMode x ==
+ x is [a,b,:.] and member(a,'(PrimitiveArray Vector List)) => b
+
+compIterator(it,e) ==
+ it is ["IN",x,y] =>
+ --these two lines must be in this order, to get "for f in list f"
+ --to give an error message if f is undefined
+ [y',m,e]:= comp(y,$EmptyMode,e) or return nil
+ $formalArgList:= [x,:$formalArgList]
+ [mOver,mUnder]:=
+ 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
+ e:= put(x,"value",[genSomeVariable(),mUnder,e],e)
+ [y'',m'',e] := coerce([y',m,e], mOver) or return nil
+ [["IN",x,y''],e]
+ it is ["ON",x,y] =>
+ $formalArgList:= [x,:$formalArgList]
+ [y',m,e]:= comp(y,$EmptyMode,e) or return nil
+ [mOver,mUnder]:=
+ 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
+ e:= put(x,"value",[genSomeVariable(),m,e],e)
+ [y'',m'',e] := coerce([y',m,e], mOver) or return nil
+ [["ON",x,y''],e]
+ it is ["STEP",index,start,inc,:optFinal] =>
+ $formalArgList:= [index,:$formalArgList]
+ --if all start/inc/end compile as small integers, then loop
+ --is compiled as a small integer loop
+ final':= nil
+ (start':= comp(start,$SmallInteger,e)) and
+ (inc':= comp(inc,$NonNegativeInteger,start'.env)) and
+ (not (optFinal is [final]) or
+ (final':= comp(final,$SmallInteger,inc'.env))) =>
+ indexmode:=
+ comp(start,$NonNegativeInteger,e) =>
+ $NonNegativeInteger
+ $SmallInteger
+ if null get(index,"mode",e) then [.,.,e]:=
+ compMakeDeclaration([":",index,indexmode],$EmptyMode,
+ (final' => final'.env; inc'.env)) or return nil
+ e:= put(index,"value",[genSomeVariable(),indexmode,e],e)
+ if final' then optFinal:= [final'.expr]
+ [["ISTEP",index,start'.expr,inc'.expr,:optFinal],e]
+ [start,.,e]:=
+ comp(start,$Integer,e) or return
+ stackMessage('"start value of index: %1b must be an integer",[start])
+ [inc,.,e]:=
+ comp(inc,$Integer,e) or return
+ stackMessage('"index increment: %1b must be an integer",[inc])
+ if optFinal is [final] then
+ [final,.,e]:=
+ comp(final,$Integer,e) or return
+ stackMessage('"final value of index: %1b must be an integer",[final])
+ optFinal:= [final]
+ indexmode:=
+ comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger
+ $Integer
+ if null get(index,"mode",e) then [.,.,e]:=
+ compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil
+ e:= put(index,"value",[genSomeVariable(),indexmode,e],e)
+ [["STEP",index,start,inc,:optFinal],e]
+ it is ["WHILE",p] =>
+ [p',m,e]:=
+ comp(p,$Boolean,e) or return
+ stackMessage('"WHILE operand: %1b is not Boolean valued",[p])
+ [["WHILE",p'],e]
+ it is ["UNTIL",p] => ($until:= p; ['$until,e])
+ it is ["|",x] =>
+ u:=
+ comp(x,$Boolean,e) or return
+ stackMessage('"SUCHTHAT operand: %1b is not Boolean value",[x])
+ [["|",u.expr],u.env]
+ nil
+
+--isAggregateMode(m,e) ==
+-- m is [c,R] and MEMQ(c,'(Vector List)) => R
+-- name:=
+-- m is [fn,:.] => fn
+-- m="$" => "Rep"
+-- m
+-- get(name,"value",e) is [c,R] and MEMQ(c,'(Vector List)) => R
+
+modeIsAggregateOf(ListOrVector,m,e) ==
+ m is [ =ListOrVector,R] => [m,R]
+--m = '$EmptyMode => [m,m] I don't think this is correct, breaks POLY +
+ m is ["Union",:l] =>
+ mList:= [pair for m' in l | (pair:= modeIsAggregateOf(ListOrVector,m',e))]
+ 1=#mList => first mList
+ name:=
+ m is [fn,:.] => fn
+ m="$" => "Rep"
+ m
+ get(name,"value",e) is [[ =ListOrVector,R],:.] => [m,R]
+
+--% VECTOR ITERATORS
+
+--the following 4 functions are not currently used
+
+compCollectV(form,m,e) ==
+ fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],e) where
+ fn(form,$exitModeStack,$leaveLevelStack,e) ==
+ [repeatOrCollect,it,body]:= form
+ [it',e]:= compIteratorV(it,e) or return nil
+ m:= first $exitModeStack
+ [mOver,mUnder]:= modeIsAggregateOf("Vector",m,e) or $EmptyMode
+ [body',m',e']:= compOrCroak(body,mUnder,e) or return nil
+ form':= ["COLLECTV",it',body']
+ n:=
+ it' is ["STEP",.,s,i,f] or it' is ["ISTEP",.,s,i,f] =>
+ computeMaxIndex(s,f,i);
+ return nil
+ coerce([form',mOver,e'],m)
+
+compIteratorV(it,e) ==
+ it is ["STEP",index,start,inc,final] =>
+ (start':= comp(start,$Integer,e)) and
+ (inc':= comp(inc,$NonNegativeInteger,start'.env)) and
+ (final':= comp(final,$Integer,inc'.env)) =>
+ indexmode:=
+ comp(start,$NonNegativeInteger,e) => $NonNegativeInteger
+ $Integer
+ if null get(index,"mode",e) then [.,.,e]:=
+ compMakeDeclaration([":",index,indexmode],$EmptyMode,final'.env) or
+ return nil
+ e:= put(index,"value",[genSomeVariable(),indexmode,e],e)
+ [["ISTEP",index,start'.expr,inc'.expr,final'.expr],e]
+ [start,.,e]:=
+ comp(start,$Integer,e) or return
+ stackMessage('"start value of index: %1b is not an integer",[start])
+ [inc,.,e]:=
+ comp(inc,$NonNegativeInteger,e) or return
+ stackMessage('"index increment: %1b must be a non-negative integer",
+ [inc])
+ [final,.,e]:=
+ comp(final,$Integer,e) or return
+ stackMessage('"final value of index: %1b is not an integer",[final])
+ indexmode:=
+ comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger
+ $Integer
+ if null get(index,"mode",e) then [.,.,e]:=
+ compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil
+ e:= put(index,"value",[genSomeVariable(),indexmode,e],e)
+ [["STEP",index,start,inc,final],e]
+ nil
+
+computeMaxIndex(s,f,i) ==
+ i^=1 => cannotDo()
+ s=1 => f
+ exprDifference(f,exprDifference(s,1))
+
+exprDifference(x,y) ==
+ y=0 => x
+ FIXP x and FIXP y => DIFFERENCE(x,y)
+ ["DIFFERENCE",x,y]
+
+
+--%
--% Entry point to the compiler
+--%
preprocessParseTree pt ==
$postStack := []
@@ -1919,6 +2188,7 @@ compileParseTree pt ==
TERPRI()
+--%
--% Register compilers for special forms.
-- Those compilers are on the `SPECIAL' property of the corresponding
-- special form operator symbol.
diff --git a/src/interp/define.boot b/src/interp/define.boot
index 2ebbac4e..06b181a9 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -78,7 +78,6 @@ $lisplibAncestors := nil
$lisplibAbbreviation := nil
$LocalDomainAlist := []
$CheckVectorList := []
-$functorsUsed := []
$setelt := nil
$pairlis := []
$functorTarget := nil
@@ -166,12 +165,8 @@ makePredicate l ==
--% FUNCTIONS WHICH MUNCH ON == STATEMENTS
-++ List of packages used by the current domain.
-$packagesUsed := []
-
compDefine(form,m,e) ==
$macroIfTrue: local := false
- $packagesUsed: local := []
compDefine1(form,m,e)
++ We are about to process the body of a capsule. If the capsule defines
@@ -240,7 +235,7 @@ compDefine1(form,m,e) ==
-- 2. if signature list for arguments is not empty, replace ('DEF,..) by
-- ('where,('DEF,..),..) with an empty signature list;
-- otherwise, fill in all NILs in the signature
- not (and/[null x for x in rest signature]) => compDefWhereClause(form,m,e)
+ or/[x ^= nil for x in rest signature] => compDefWhereClause(form,m,e)
signature.target=$Category =>
compDefineCategory(form,m,e,nil,$formalArgList)
isDomainForm(rhs,e) and not $insideFunctorIfTrue =>
@@ -569,7 +564,6 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body],
--prevents CheckVector from printing out same message twice
$getDomainCode: local -- code for getting views
$insideFunctorIfTrue: local:= true
- $functorsUsed: local := nil --not currently used, finds dependent functors
$setelt: local := "setShellEntry"
$genSDVar: local:= 0
originale:= $e
@@ -668,7 +662,6 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body],
reportOnFunctorCompilation()
-- 5. give operator a 'modemap property
--- if $functorsUsed then MAKEPROP(op',"NEEDS",$functorsUsed)
if $LISPLIB then
modemap:= [[parForm,:parSignature],[true,op']]
$lisplibModemap:= modemap
@@ -1174,7 +1167,7 @@ addArgumentConditions($body,$functionName) ==
[$true,["argumentDataError",n,
MKQ untypedCondition,MKQ $functionName]]]
null clist => $body
- systemErrorHere '"addArgumentConditions"
+ systemErrorHere ["addArgumentConditions",clist]
$body
putInLocalDomainReferences (def := [opName,[lam,varl,body]]) ==
@@ -1394,16 +1387,12 @@ compAdd(['add,$addForm,capsule],m,e) ==
''%b,MKQ namestring _/EDITFILE,''%d,'"needs to be compiled"]]]],m,e]
$addFormLhs: local:= $addForm
if $addForm is ["SubDomain",domainForm,predicate] then
- $packagesUsed := [domainForm,:$packagesUsed]
$NRTaddForm := domainForm
NRTgetLocalIndex domainForm
--need to generate slot for add form since all $ go-get
-- slots will need to access it
[$addForm,.,e]:= compSubDomain1(domainForm,predicate,m,e)
else
- $packagesUsed :=
- $addForm is ["%Comma",:u] => [:u,:$packagesUsed]
- [$addForm,:$packagesUsed]
$NRTaddForm := $addForm
[$addForm,.,e]:=
$addForm is ["%Comma",:.] =>
@@ -1496,7 +1485,7 @@ doIt(item,$predl) ==
RPLACD(item,rest u)
doIt(item,$predl)
item is ["%LET",lhs,rhs,:.] =>
- not (compOrCroak(item,$EmptyMode,$e) is [code,.,$e]) =>
+ compOrCroak(item,$EmptyMode,$e) isnt [code,.,$e] =>
stackSemanticError(["cannot compile assigned value to",:bright lhs],nil)
not (code is ["%LET",lhs',rhs',:.] and atom lhs') =>
code is ["PROGN",:.] =>
@@ -1508,9 +1497,6 @@ doIt(item,$predl) ==
not MEMQ(lhs, $functorLocalParameters) then
$functorLocalParameters:= [:$functorLocalParameters,lhs]
if code is ["%LET",.,rhs',:.] and isDomainForm(rhs',$e) then
- if isFunctor rhs' then
- $functorsUsed:= insert(opOf rhs',$functorsUsed)
- $packagesUsed:= insert([opOf rhs'],$packagesUsed)
if lhs="Rep" then
$Representation:= (get("Rep",'value,$e)).expr
--$Representation bound by compDefineFunctor, used in compNoStacking
@@ -1520,8 +1506,7 @@ doIt(item,$predl) ==
[[lhs,:SUBLIS($LocalDomainAlist,(get(lhs,'value,$e)).0)],:$LocalDomainAlist]
code is ["%LET",:.] =>
RPLACA(item,"setShellEntry")
- rhsCode:=
- rhs'
+ rhsCode := rhs'
RPLACD(item,['$,NRTgetLocalIndex lhs,rhsCode])
RPLACA(item,first code)
RPLACD(item,rest code)
@@ -1540,7 +1525,7 @@ doIt(item,$predl) ==
[.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e)
RPLACA(item,"CodeDefine")
--Note that DescendCode, in CodeDefine, is looking for this
- RPLACD(CADR item,[$signatureOfForm])
+ RPLACD(second item,[$signatureOfForm])
--This is how the signature is updated for buildFunctor to recognise
functionPart:= ['dispatchFunction,t.expr]
RPLACA(CDDR item,functionPart)
@@ -1745,7 +1730,7 @@ compCategoryItem(x,predl,env) ==
-- single operator name or a list of names; if a list of names,
-- recurse
x is ["SIGNATURE",:opsig] => compSignature(opsig,pred,env)
- systemErrorHere "compCategoryItem"
+ systemErrorHere ["compCategoryItem",x]
compCategory: (%Form,%Mode,%Env) -> %Maybe %Triple
compCategory(x,m,e) ==
@@ -1758,6 +1743,6 @@ compCategory(x,m,e) ==
rep:= mkExplicitCategoryFunction(domainOrPackage,$sigList,$atList)
--if inside compDefineCategory, provide for category argument substitution
[rep,m,e]
- systemErrorHere '"compCategory"
+ systemErrorHere ["compCategory",x]
--%
diff --git a/src/interp/format.boot b/src/interp/format.boot
index 64414ea6..d3d6fbc9 100644
--- a/src/interp/format.boot
+++ b/src/interp/format.boot
@@ -535,7 +535,7 @@ formIterator2String x ==
x is ["|",y,p] => concat(formatIterator y," | ",form2StringLocal p)
x is ["until",p] => concat("until ",form2StringLocal p)
x is ["while",p] => concat("while ",form2StringLocal p)
- systemErrorHere "formatIterator"
+ systemErrorHere ["formatIterator",x]
tuple2String argl ==
null argl => nil
diff --git a/src/interp/functor.boot b/src/interp/functor.boot
index 595d5a6e..da85828f 100644
--- a/src/interp/functor.boot
+++ b/src/interp/functor.boot
@@ -277,7 +277,7 @@ optFunctorBodyQuotable u ==
optFunctorBodyRequote u ==
atom u => u
u is ['QUOTE,v] => v
- systemErrorHere '"optFunctorBodyRequote"
+ systemErrorHere ["optFunctorBodyRequote",u]
optFunctorPROGN l ==
l is [x,:l'] =>
@@ -616,8 +616,6 @@ DescendCode(code,flag,viewAssoc,EnvToPass) ==
['COND,:c]
code is ["%LET",name,body,:.] =>
--only keep the names that are useful
- if body is [a,:.] and isFunctor a
- then $packagesUsed:=[body,:$packagesUsed]
u:=member(name,$locals) =>
CONTAINED('$,body) and isDomainForm(body,$e) =>
--instantiate domains which depend on $ after constants are set
@@ -651,8 +649,8 @@ DescendCode(code,flag,viewAssoc,EnvToPass) ==
code is ['MDEF,:.] => nil
code is ['call,:.] => code
code is ["setShellEntry",:.] => code -- can be generated by doItIf
- code is ['SETELT,:.] => systemErrorHere "DescendCode"
- code is ['QSETREFV,:.] => systemErrorHere "DescendCode"
+ code is ['SETELT,:.] => systemErrorHere ["DescendCode",code]
+ code is ['QSETREFV,:.] => systemErrorHere ["DescendCode",code]
stackWarning('"unknown Functor code: %1 ",[code])
code
@@ -714,8 +712,8 @@ SetFunctionSlots(sig,body,flag,mode) == --mode is either "original" or "adding"
else
keyedSystemError("S2OR0002",[catImplem])
body is ["setShellEntry",:.] => body
- body is ['SETELT,:.] => systemErrorHere "SetFunctionSlots"
- body is ['QSETREFV,:.] => systemErrorHere "SetFunctionSlots"
+ body is ['SETELT,:.] => systemErrorHere ["SetFunctionSlots",body]
+ body is ['QSETREFV,:.] => systemErrorHere ["SetFunctionSlots",body]
nil
LookUpSigSlots(sig,siglist) ==
@@ -749,7 +747,7 @@ CheckVector(vec,name,catvecListMaker) ==
v=true => nil
null v => nil
--a domain, which setVector4part3 will fill in
- atom v => systemErrorHere '"CheckVector"
+ atom v => systemErrorHere ["CheckVector",v]
atom first v =>
--It's a secondary view of a domain, which we
--must generate code to fill in
@@ -914,7 +912,7 @@ ICformat u ==
l
LENGTH l=1 => first l
['OR,:l]
- systemErrorHere '"ICformat"
+ systemErrorHere ["ICformat",u]
where
ORreduce l ==
for u in l | u is ['AND,:.] or u is ['and,:.] repeat
@@ -936,7 +934,7 @@ partPessimise(a,trueconds) ==
getPossibleViews u ==
--returns a list of all the categories that can be views of this one
[vec,:.]:= compMakeCategoryObject(u,$e) or
- systemErrorHere '"getPossibleViews"
+ systemErrorHere ["getPossibleViews",u]
views:= [first u for u in CADR vec.4]
null vec.0 => [CAAR vec.4,:views] --*
[vec.0,:views] --*
@@ -948,7 +946,7 @@ getViewsConditions u ==
--returns a list of all the categories that can be views of this one
--paired with the condition under which they are such views
[vec,:.]:= compMakeCategoryObject(u,$e) or
- systemErrorHere '"getViewsConditions"
+ systemErrorHere ["getViewsConditions",u]
views:= [[first u,:CADR u] for u in CADR vec.4]
null vec.0 =>
null CAR vec.4 => views
diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
index 5b07aad2..52f54d3f 100644
--- a/src/interp/g-opt.boot
+++ b/src/interp/g-opt.boot
@@ -156,7 +156,7 @@ optCall (x is ["call",:u]) ==
RPLACA(fn,"getShellEntry")
RPLAC(rest x,[:a,fn])
x
- systemErrorHere ['"optCall with", :bright x]
+ systemErrorHere ["optCall",x]
optCallSpecially(q,x,n,R) ==
y:= LASSOC(R,$specialCaseKeyList) => optSpecialCall(x,y,n)
@@ -176,7 +176,6 @@ optCallSpecially(q,x,n,R) ==
nil
optCallEval u ==
- u is ["Boolean"] => Boolean()
u is ["List",:.] => List Integer()
u is ["Vector",:.] => Vector Integer()
u is ["PrimitiveArray",:.] => PrimitiveArray Integer()
@@ -441,7 +440,7 @@ optLET u ==
-- Munge inits into list of dotted-pairs. Lovely Lisp.
for defs in tails inits repeat
def := first defs
- atom def => systemErrorHere "optLET" -- cannot happen
+ atom def => systemErrorHere ["optLET",def] -- cannot happen
rplac(rest def, second def)
SUBLIS(inits,body)
diff --git a/src/interp/i-funsel.boot b/src/interp/i-funsel.boot
index c93a6100..daededbc 100644
--- a/src/interp/i-funsel.boot
+++ b/src/interp/i-funsel.boot
@@ -879,7 +879,7 @@ findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom) ==
fun:= NIL
-- cat := constructorCategory dc
makeFunc := GETL(dcName,"makeFunctionList") or
- systemErrorHere '"findFunctionInCategory"
+ systemErrorHere ["findFunctionInCategory",dcName]
[funlist,.] := FUNCALL(makeFunc,"$",dc,$CategoryFrame)
-- get list of implementations and remove sharps
maxargs := -1
diff --git a/src/interp/i-intern.boot b/src/interp/i-intern.boot
index efee0657..0796d693 100644
--- a/src/interp/i-intern.boot
+++ b/src/interp/i-intern.boot
@@ -114,7 +114,7 @@ mkAtree1 x ==
IDENTP x => mkAtreeNode x
keyedSystemError("S2II0002",[x])
x is [op,:argl] => mkAtree2(x,op,argl)
- systemErrorHere '"mkAtree1"
+ systemErrorHere ["mkAtree1",x]
-- mkAtree2 and mkAtree3 were created because mkAtree1 got so big
@@ -398,7 +398,7 @@ getValueFromSpecificEnvironment(id,mode,e) ==
PAIRP e =>
u := get(id,'value,e) =>
objMode(u) = $EmptyMode =>
- systemErrorHere '"getValueFromSpecificEnvironment"
+ systemErrorHere ["getValueFromSpecificEnvironment",id]
v := objValUnwrap u
mode isnt ['Mapping,:mapSig] => v
v isnt ["%Map",:.] => v
diff --git a/src/interp/i-spec2.boot b/src/interp/i-spec2.boot
index e843a18e..43be7dd2 100644
--- a/src/interp/i-spec2.boot
+++ b/src/interp/i-spec2.boot
@@ -723,7 +723,7 @@ unVectorize body ==
if newOp = 'COERCE then newOp := "::"
if newOp = 'Dollar then newOp := "$elt"
[newOp,:unVectorize argl]
- systemErrorHere '"unVectorize"
+ systemErrorHere ["unVectorize",body]
isType t ==
-- Returns the evaluated type if t is a tree representing a type,
diff --git a/src/interp/i-syscmd.boot b/src/interp/i-syscmd.boot
index 984ad67d..d0386605 100644
--- a/src/interp/i-syscmd.boot
+++ b/src/interp/i-syscmd.boot
@@ -2508,7 +2508,7 @@ reportOpsFromUnitDirectly unitForm ==
if isRecordOrUnion
then
constructorFunction:= GETL(top,"makeFunctionList") or
- systemErrorHere '"reportOpsFromUnitDirectly"
+ systemErrorHere ["reportOpsFromUnitDirectly",top]
[funlist,.]:= FUNCALL(constructorFunction,"$",unitForm,
$CategoryFrame)
sigList := REMDUP MSORT [[[a,b],true,[c,0,1]] for
diff --git a/src/interp/i-toplev.boot b/src/interp/i-toplev.boot
index 563fa1fe..92f89497 100644
--- a/src/interp/i-toplev.boot
+++ b/src/interp/i-toplev.boot
@@ -339,7 +339,7 @@ interpret2(object,m1,posnForm) ==
m=$EmptyMode =>
x is [op,:.] and op in '(%Map STREAM) => objNew(x,m1)
m1 = $EmptyMode => objNew(x,m)
- systemErrorHere '"interpret2"
+ systemErrorHere ["interpret2",x]
m1 =>
if (ans := coerceInteractive(object,m1)) then ans
else throwKeyedMsgCannotCoerceWithValue(x,m,m1)
diff --git a/src/interp/iterator.boot b/src/interp/iterator.boot
deleted file mode 100644
index ab7a76d7..00000000
--- a/src/interp/iterator.boot
+++ /dev/null
@@ -1,307 +0,0 @@
--- 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.
-
-
-import g_-util
-namespace BOOT
-
---% ITERATORS
-
-compReduce(form,m,e) ==
- compReduce1(form,m,e,$formalArgList)
-
-compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) ==
- [collectOp,:itl,body]:= collectForm
- if STRINGP op then op:= INTERN op
- ^MEMQ(collectOp,'(COLLECT COLLECTV COLLECTVEC)) =>
- systemError ["illegal reduction form:",form]
- $sideEffectsList: local := nil
- $until: local := nil
- $initList: local := nil
- $endTestList: local := nil
- oldEnv := e
- $e:= e
- itl:= [([.,$e]:= compIterator(x,$e) or return "failed").(0) for x in itl]
- itl="failed" => return nil
- e:= $e
- acc:= GENSYM()
- afterFirst:= GENSYM()
- bodyVal:= GENSYM()
- [part1,m,e]:= comp(["%LET",bodyVal,body],m,e) or return nil
- [part2,.,e]:= comp(["%LET",acc,bodyVal],m,e) or return nil
- [part3,.,e]:= comp(["%LET",acc,parseTran [op,acc,bodyVal]],m,e) or return nil
- identityCode:=
- id:= getIdentity(op,e) => u.expr where u() == comp(id,m,e) or return nil
- ["IdentityError",MKQ op]
- finalCode:=
- ["PROGN",
- ["%LET",afterFirst,nil],
- ["REPEAT",:itl,
- ["PROGN",part1,
- ["IF", afterFirst,part3,
- ["PROGN",part2,["%LET",afterFirst,MKQ true]]]]],
- ["IF",afterFirst,acc,identityCode]]
- if $until then
- [untilCode,.,e]:= comp($until,$Boolean,e)
- finalCode:= substitute(["UNTIL",untilCode],'$until,finalCode)
- [finalCode,m,oldEnv]
-
-++ returns the identity element of the `reduction' operation `x'
-++ over a list -- a monoid homomorphism.
-getIdentity(x,e) ==
- -- The empty list should be indicated by name, not by its
- -- object representation.
- GETL(x,"THETA") is [y] => (y => y; "nil")
-
-numberize x ==
- x=$Zero => 0
- x=$One => 1
- atom x => x
- [numberize first x,:numberize rest x]
-
-compRepeatOrCollect(form,m,e) ==
- fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList
- ,e) where
- fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) ==
- $until: local := nil
- oldEnv := e
- [repeatOrCollect,:itl,body]:= form
- itl':=
- [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl]
- itl'="failed" => nil
- targetMode:= first $exitModeStack
- bodyMode:=
- repeatOrCollect="COLLECT" =>
- targetMode = '$EmptyMode => '$EmptyMode
- (u:=modeIsAggregateOf('List,targetMode,e)) =>
- CADR u
- (u:=modeIsAggregateOf('PrimitiveArray,targetMode,e)) =>
- repeatOrCollect:='COLLECTV
- CADR u
- (u:=modeIsAggregateOf('Vector,targetMode,e)) =>
- repeatOrCollect:='COLLECTVEC
- CADR u
- stackMessage('"Invalid collect bodytype")
- return nil
- -- If we're doing a collect, and the type isn't conformable
- -- then we've boobed. JHD 26.July.1990
- $NoValueMode
- [body',m',e']:=
- compOrCroak(body,bodyMode,e) or return nil
- if $until then
- [untilCode,.,e']:= comp($until,$Boolean,e')
- itl':= substitute(["UNTIL",untilCode],'$until,itl')
- form':= [repeatOrCollect,:itl',body']
- m'':=
- repeatOrCollect="COLLECT" =>
- (u:=modeIsAggregateOf('List,targetMode,e)) => CAR u
- ["List",m']
- repeatOrCollect="COLLECTV" =>
- (u:=modeIsAggregateOf('PrimitiveArray,targetMode,e)) => CAR u
- ["PrimitiveArray",m']
- repeatOrCollect="COLLECTVEC" =>
- (u:=modeIsAggregateOf('Vector,targetMode,e)) => CAR u
- ["Vector",m']
- m'
- T := coerceExit([form',m'',e'],targetMode) or return nil
- -- iterator variables and other variables declared in
- -- in a loop are local to the loop.
- [T.expr,T.mode,oldEnv]
-
---constructByModemap([x,source,e],target) ==
--- u:=
--- [cexpr
--- for (modemap:= [map,cexpr]) in getModemapList("construct",1,e) | map is [
--- .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil
--- fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil
--- [["call",fn,x],target,e]
-
-listOrVectorElementMode x ==
- x is [a,b,:.] and member(a,'(PrimitiveArray Vector List)) => b
-
-compIterator(it,e) ==
- it is ["IN",x,y] =>
- --these two lines must be in this order, to get "for f in list f"
- --to give an error message if f is undefined
- [y',m,e]:= comp(y,$EmptyMode,e) or return nil
- $formalArgList:= [x,:$formalArgList]
- [mOver,mUnder]:=
- 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
- e:= put(x,"value",[genSomeVariable(),mUnder,e],e)
- [y'',m'',e] := coerce([y',m,e], mOver) or return nil
- [["IN",x,y''],e]
- it is ["ON",x,y] =>
- $formalArgList:= [x,:$formalArgList]
- [y',m,e]:= comp(y,$EmptyMode,e) or return nil
- [mOver,mUnder]:=
- 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
- e:= put(x,"value",[genSomeVariable(),m,e],e)
- [y'',m'',e] := coerce([y',m,e], mOver) or return nil
- [["ON",x,y''],e]
- it is ["STEP",index,start,inc,:optFinal] =>
- $formalArgList:= [index,:$formalArgList]
- --if all start/inc/end compile as small integers, then loop
- --is compiled as a small integer loop
- final':= nil
- (start':= comp(start,$SmallInteger,e)) and
- (inc':= comp(inc,$NonNegativeInteger,start'.env)) and
- (not (optFinal is [final]) or
- (final':= comp(final,$SmallInteger,inc'.env))) =>
- indexmode:=
- comp(start,$NonNegativeInteger,e) =>
- $NonNegativeInteger
- $SmallInteger
- if null get(index,"mode",e) then [.,.,e]:=
- compMakeDeclaration([":",index,indexmode],$EmptyMode,
- (final' => final'.env; inc'.env)) or return nil
- e:= put(index,"value",[genSomeVariable(),indexmode,e],e)
- if final' then optFinal:= [final'.expr]
- [["ISTEP",index,start'.expr,inc'.expr,:optFinal],e]
- [start,.,e]:=
- comp(start,$Integer,e) or return
- stackMessage('"start value of index: %1b must be an integer",[start])
- [inc,.,e]:=
- comp(inc,$Integer,e) or return
- stackMessage('"index increment: %1b must be an integer",[inc])
- if optFinal is [final] then
- [final,.,e]:=
- comp(final,$Integer,e) or return
- stackMessage('"final value of index: %1b must be an integer",[final])
- optFinal:= [final]
- indexmode:=
- comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger
- $Integer
- if null get(index,"mode",e) then [.,.,e]:=
- compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil
- e:= put(index,"value",[genSomeVariable(),indexmode,e],e)
- [["STEP",index,start,inc,:optFinal],e]
- it is ["WHILE",p] =>
- [p',m,e]:=
- comp(p,$Boolean,e) or return
- stackMessage('"WHILE operand: %1b is not Boolean valued",[p])
- [["WHILE",p'],e]
- it is ["UNTIL",p] => ($until:= p; ['$until,e])
- it is ["|",x] =>
- u:=
- comp(x,$Boolean,e) or return
- stackMessage('"SUCHTHAT operand: %1b is not Boolean value",[x])
- [["|",u.expr],u.env]
- nil
-
---isAggregateMode(m,e) ==
--- m is [c,R] and MEMQ(c,'(Vector List)) => R
--- name:=
--- m is [fn,:.] => fn
--- m="$" => "Rep"
--- m
--- get(name,"value",e) is [c,R] and MEMQ(c,'(Vector List)) => R
-
-modeIsAggregateOf(ListOrVector,m,e) ==
- m is [ =ListOrVector,R] => [m,R]
---m = '$EmptyMode => [m,m] I don't think this is correct, breaks POLY +
- m is ["Union",:l] =>
- mList:= [pair for m' in l | (pair:= modeIsAggregateOf(ListOrVector,m',e))]
- 1=#mList => first mList
- name:=
- m is [fn,:.] => fn
- m="$" => "Rep"
- m
- get(name,"value",e) is [[ =ListOrVector,R],:.] => [m,R]
-
---% VECTOR ITERATORS
-
---the following 4 functions are not currently used
-
-compCollectV(form,m,e) ==
- fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],e) where
- fn(form,$exitModeStack,$leaveLevelStack,e) ==
- [repeatOrCollect,it,body]:= form
- [it',e]:= compIteratorV(it,e) or return nil
- m:= first $exitModeStack
- [mOver,mUnder]:= modeIsAggregateOf("Vector",m,e) or $EmptyMode
- [body',m',e']:= compOrCroak(body,mUnder,e) or return nil
- form':= ["COLLECTV",it',body']
- n:=
- it' is ["STEP",.,s,i,f] or it' is ["ISTEP",.,s,i,f] =>
- computeMaxIndex(s,f,i);
- return nil
- coerce([form',mOver,e'],m)
-
-compIteratorV(it,e) ==
- it is ["STEP",index,start,inc,final] =>
- (start':= comp(start,$Integer,e)) and
- (inc':= comp(inc,$NonNegativeInteger,start'.env)) and
- (final':= comp(final,$Integer,inc'.env)) =>
- indexmode:=
- comp(start,$NonNegativeInteger,e) => $NonNegativeInteger
- $Integer
- if null get(index,"mode",e) then [.,.,e]:=
- compMakeDeclaration([":",index,indexmode],$EmptyMode,final'.env) or
- return nil
- e:= put(index,"value",[genSomeVariable(),indexmode,e],e)
- [["ISTEP",index,start'.expr,inc'.expr,final'.expr],e]
- [start,.,e]:=
- comp(start,$Integer,e) or return
- stackMessage('"start value of index: %1b is not an integer",[start])
- [inc,.,e]:=
- comp(inc,$NonNegativeInteger,e) or return
- stackMessage('"index increment: %1b must be a non-negative integer",
- [inc])
- [final,.,e]:=
- comp(final,$Integer,e) or return
- stackMessage('"final value of index: %1b is not an integer",[final])
- indexmode:=
- comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger
- $Integer
- if null get(index,"mode",e) then [.,.,e]:=
- compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil
- e:= put(index,"value",[genSomeVariable(),indexmode,e],e)
- [["STEP",index,start,inc,final],e]
- nil
-
-computeMaxIndex(s,f,i) ==
- i^=1 => cannotDo()
- s=1 => f
- exprDifference(f,exprDifference(s,1))
-
-exprDifference(x,y) ==
- y=0 => x
- FIXP x and FIXP y => DIFFERENCE(x,y)
- ["DIFFERENCE",x,y]
-
diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot
index 79b4ec24..74d05485 100644
--- a/src/interp/lisplib.boot
+++ b/src/interp/lisplib.boot
@@ -506,7 +506,7 @@ getFunctorOpsAndAtts(form,modemap) ==
getSlotFromFunctor([name,:args],slot,[[.,target,:argMml],:.]) ==
slot = 1 => $lisplibOperationAlist
t := compMakeCategoryObject(target,$e) or
- systemErrorHere '"getSlotFromFunctor"
+ systemErrorHere "getSlotFromFunctor"
t.expr.slot
getSlot1 domainName ==
@@ -521,7 +521,7 @@ getSlot1 domainName ==
for a in $FormalMapVariableList for m in argMml repeat
$e:= put(a,'mode,m,$e)
t := compMakeCategoryObject(target,$e) or
- systemErrorHere '"getSlot1"
+ systemErrorHere ["getSlot1",domainName]
t.expr.1
sayKeyedMsg("S2IL0022",[namestring p,'"constructor modemap"])
NIL
@@ -575,7 +575,7 @@ findConstructorSlotNumber(domainForm,domain,op,sig) ==
FIXP b => a=constructorArglist.b
isSuperDomain(bustUnion b,bustUnion a,$CategoryFrame)
tail is [.,["ELT",.,n]] => n
- systemErrorHere '"findSlotNumber"
+ systemErrorHere ["findConstructorSlotNumber",domainForm]
bustUnion d ==
d is ["Union",domain,utype] and utype='"failed" => domain
diff --git a/src/interp/msgdb.boot b/src/interp/msgdb.boot
index 4f2b6b79..9e6556f8 100644
--- a/src/interp/msgdb.boot
+++ b/src/interp/msgdb.boot
@@ -430,8 +430,10 @@ popSatOutput(newmode) ==
sayString FORMAT(nil, '"What is: ~a", $saturnMode)
$saturnMode
-systemErrorHere functionName ==
- keyedSystemError("S2GE0017",[functionName])
+systemErrorHere what ==
+ if not atom what then
+ what := [first what, " with: ", :rest what]
+ keyedSystemError("S2GE0017",[what])
isKeyedMsgInDb(key,dbName) ==
$msgDatabaseName : fluid := pathname dbName
diff --git a/src/interp/nrungo.boot b/src/interp/nrungo.boot
index 51ab48dc..d2d5d9a5 100644
--- a/src/interp/nrungo.boot
+++ b/src/interp/nrungo.boot
@@ -61,7 +61,7 @@ isInstantiated [op,:argl] ==
NRTevalDomain form ==
form is ["setShellEntry",:.] => eval form
- form is ['SETELT,:.] => systemErrorHere "NRTevalDomain"
+ form is ['SETELT,:.] => systemErrorHere ["NRTevalDomain",form]
evalDomain form
--------------------> NEW DEFINITION (see interop.boot.pamphlet)
diff --git a/src/interp/parse.boot b/src/interp/parse.boot
index 3dacec05..eba9defb 100644
--- a/src/interp/parse.boot
+++ b/src/interp/parse.boot
@@ -93,12 +93,12 @@ parseLeftArrow u ==
parseIs: %ParseForm -> %Form
parseIs t ==
- t isnt ["is",a,b] => systemErrorHere "parseIs"
+ t isnt ["is",a,b] => systemErrorHere ["parseIs",t]
["is",parseTran a,transIs parseTran b]
parseIsnt: %ParseForm -> %Form
parseIsnt t ==
- t isnt ["isnt",a,b] => systemErrorHere "parseIsnt"
+ t isnt ["isnt",a,b] => systemErrorHere ["parseIsnt",t]
["isnt",parseTran a,transIs parseTran b]
@@ -130,7 +130,7 @@ transIs1 u ==
parseLET: %ParseForm -> %Form
parseLET t ==
- t isnt ["%LET",x,y] => systemErrorHere "parseLET"
+ t isnt ["%LET",x,y] => systemErrorHere ["parseLET",t]
p := ["%LET",parseTran x,parseTranCheckForRecord(y,opOf x)]
opOf x = "cons" => ["%LET",transIs p.1,p.2]
p
@@ -138,12 +138,12 @@ parseLET t ==
parseLETD: %ParseForm -> %Form
parseLETD t ==
- t isnt ["LETD",x,y] => systemErrorHere "parseLETD"
+ t isnt ["LETD",x,y] => systemErrorHere ["parseLETD",t]
["%Decl",parseTran x,parseTran y]
parseColon: %ParseForm -> %Form
parseColon u ==
- u isnt [":",:.] => systemErrorHere "parseColon"
+ u isnt [":",:.] => systemErrorHere ["parseColon",u]
u is [":",x] => [":",parseTran x]
u is [":",x,typ] => [":",parseTran x,parseTran typ]
u
@@ -151,43 +151,43 @@ parseColon u ==
-- ??? This parser is unused at the moment.
parseBigelt: %ParseForm -> %Form
parseBigelt t ==
- t isnt [.,typ,consForm] => systemErrorHere "parseBigelt"
+ t isnt [.,typ,consForm] => systemErrorHere ["parseBigelt",t]
[["elt",typ,"makeRecord"],:transUnCons consForm]
transUnCons: %ParseForm -> %Form
transUnCons u ==
- atom u => systemErrorHere '"transUnCons"
+ atom u => systemErrorHere ["transUnCons",u]
u is ["APPEND",x,y] =>
null y => x
- systemErrorHere '"transUnCons"
+ systemErrorHere ["transUnCons",u]
u is ["CONS",x,y] =>
atom y => [x,:y]
[x,:transUnCons y]
parseCoerce: %ParseForm -> %Form
parseCoerce t ==
- t isnt [.,x,typ] => systemErrorHere "parseCoerce"
+ t isnt [.,x,typ] => systemErrorHere ["parseCoerce",t]
["::",parseTran x,parseTran typ]
parseAtSign: %ParseForm -> %Form
parseAtSign t ==
- t isnt [.,x,typ] => systemErrorHere "parseAtSign"
+ t isnt [.,x,typ] => systemErrorHere ["parseAtSign",t]
["@",parseTran x,parseTran typ]
parsePretend: %ParseForm -> %Form
parsePretend t ==
- t isnt ["pretend",x,typ] => systemErrorHere "parsePretend"
+ t isnt ["pretend",x,typ] => systemErrorHere ["parsePretend",t]
["pretend",parseTran x,parseTran typ]
parseAtAt: %ParseForm -> %Form
parseAtAt t ==
- t isnt ["@@",x,typ] => systemErrorHere "parseAtAt"
+ t isnt ["@@",x,typ] => systemErrorHere ["parseAtAt",t]
["@@",parseTran x,parseTran typ]
parseHas: %ParseForm -> %Form
parseHas t ==
- t isnt ["has",x,y] => systemErrorHere "parseHas"
+ t isnt ["has",x,y] => systemErrorHere ["parseHas",t]
mkand [["has",x,u] for u in fn y] where
mkand x ==
x is [a] => a
@@ -206,7 +206,7 @@ parseHas t ==
parseDEF: %ParseForm -> %Form
parseDEF t ==
- t isnt ["DEF",$lhs,tList,specialList,body] => systemErrorHere "parseDEF"
+ t isnt ["DEF",$lhs,tList,specialList,body] => systemErrorHere ["parseDEF",t]
setDefOp $lhs
["DEF",parseLhs $lhs,parseTranList tList,parseTranList specialList,
parseTranCheckForRecord(body,opOf $lhs)]
@@ -220,7 +220,8 @@ parseLhs x ==
parseMDEF: %ParseForm -> %Form
parseMDEF t ==
- t isnt ["MDEF",$lhs,tList,specialList,body] => systemErrorHere "parseMDEF"
+ t isnt ["MDEF",$lhs,tList,specialList,body] =>
+ systemErrorHere ["parseMDEF",t]
["MDEF",parseTran $lhs,parseTranList tList,parseTranList specialList,
parseTranCheckForRecord(body,opOf $lhs)]
@@ -234,7 +235,7 @@ parseTranCheckForRecord(x,op) ==
parseCategory: %ParseForm -> %Form
parseCategory t ==
- t isnt ["CATEGORY",:x] => systemErrorHere "parseCategory"
+ t isnt ["CATEGORY",:x] => systemErrorHere ["parseCategory",t]
l:= parseTranList parseDropAssertions x
key:=
CONTAINED("$",l) => "domain"
@@ -252,7 +253,7 @@ parseDropAssertions x ==
parseGreaterThan: %ParseForm -> %Form
parseGreaterThan t ==
- t isnt [op,x,y] => systemErrorHere "parseGreaterThan"
+ t isnt [op,x,y] => systemErrorHere ["parseGreaterThan",t]
[substitute("<",">",op),parseTran y,parseTran x]
parseGreaterEqual: %ParseForm -> %Form
@@ -270,7 +271,7 @@ parseNotEqual u ==
parseAnd: %ParseForm -> %Form
parseAnd t ==
- t isnt ["and",:u] => systemErrorHere "parseAnd"
+ t isnt ["and",:u] => systemErrorHere ["parseAnd",t]
null u => "true"
null rest u => first u
parseIf ["IF",parseTran first u,parseAnd ["and",:rest u],"false"]
@@ -278,7 +279,7 @@ parseAnd t ==
parseOr: %ParseForm -> %Form
parseOr t ==
- t isnt ["or",:u] => systemErrorHere "parseOr"
+ t isnt ["or",:u] => systemErrorHere ["parseOr",t]
null u => "false"
null rest u => first u
(x:= parseTran first u) is ["not",y] =>
@@ -287,7 +288,7 @@ parseOr t ==
parseExit: %ParseForm -> %Form
parseExit t ==
- t isnt ["exit",a,:b] => systemErrorHere "parseExit"
+ t isnt ["exit",a,:b] => systemErrorHere ["parseExit",t]
-- note: I wanted to convert 1s to 0s here to facilitate indexing in
-- comp code; unfortunately, parseTran-ning is sometimes done more
-- than once so that the count can be decremented more than once
@@ -302,7 +303,7 @@ parseExit t ==
parseLeave: %ParseForm -> %Form
parseLeave t ==
- t isnt ["leave",a,:b] => systemErrorHere "parseLeave"
+ t isnt ["leave",a,:b] => systemErrorHere ["parseLeave",t]
a:= parseTran a
b:= parseTran b
b =>
@@ -314,7 +315,7 @@ parseLeave t ==
parseReturn: %ParseForm -> %Form
parseReturn t ==
- t isnt ["return",a,:b] => systemErrorHere "parseReturn"
+ t isnt ["return",a,:b] => systemErrorHere ["parseReturn",t]
a:= parseTran a
b:= parseTran b
b =>
@@ -323,7 +324,7 @@ parseReturn t ==
parseJoin: %ParseForm -> %Form
parseJoin t ==
- t isnt ["Join",:l] => systemErrorHere "parseJoin"
+ t isnt ["Join",:l] => systemErrorHere ["parseJoin",t]
["Join",:fn parseTranList l] where
fn l ==
null l => nil
@@ -332,7 +333,7 @@ parseJoin t ==
parseInBy: %ParseForm -> %Form
parseInBy t ==
- t isnt ["INBY",i,n,inc] => systemErrorHere "parseInBy"
+ t isnt ["INBY",i,n,inc] => systemErrorHere ["parseInBy",t]
(u:= parseIn ["IN",i,n]) isnt ["STEP",i,a,j,:r] =>
postError [" You cannot use",:bright '"by",
'"except for an explicitly indexed sequence."]
@@ -349,7 +350,7 @@ parseSegment p ==
parseIn: %ParseForm -> %Form
parseIn t ==
- t isnt ["IN",i,n] => systemErrorHere "parseIn"
+ t isnt ["IN",i,n] => systemErrorHere ["parseIn",t]
i:= parseTran i
n:= parseTran n
n is ["SEGMENT",a] => ["STEP",i,a,1]
@@ -389,13 +390,13 @@ makeSimplePredicateOrNil p ==
parseWhere: %List -> %Form
parseWhere t ==
- t isnt ["where",:l] => systemErrorHere "parseWhere"
+ t isnt ["where",:l] => systemErrorHere ["parseWhere",t]
["where",:mapInto(l, function parseTran)]
parseSeq: %List -> %Form
parseSeq t ==
- t isnt ["SEQ",:l] => systemErrorHere "parseSeq"
+ t isnt ["SEQ",:l] => systemErrorHere ["parseSeq",t]
l isnt [:.,["exit",:.]] =>
postError ['" Invalid ending to block: ",last l]
transSeq mapInto(l,function parseTran)
diff --git a/src/interp/postpar.boot b/src/interp/postpar.boot
index c045ffc7..80bac6d4 100644
--- a/src/interp/postpar.boot
+++ b/src/interp/postpar.boot
@@ -104,7 +104,7 @@ postBigFloat x ==
postAdd: %ParseTree -> %ParseForm
postAdd x ==
- x isnt ["add",a,:b] => systemErrorHere "postAdd"
+ x isnt ["add",a,:b] => systemErrorHere ["postAdd",x]
b=nil => postCapsule a
["add",postTran a,postCapsule first b]
@@ -135,17 +135,17 @@ postColon u ==
postAtSign: %ParseTree -> %ParseForm
postAtSign t ==
- t isnt ["@",x,y] => systemErrorHere "postAtSign"
+ t isnt ["@",x,y] => systemErrorHere ["postAtSign",t]
["@",postTran x,:postType y]
postPretend: %ParseTree -> %ParseForm
postPretend t ==
- t isnt ["pretend",x,y] => systemErrorHere "postPretend"
+ t isnt ["pretend",x,y] => systemErrorHere ["postPretend",t]
["pretend",postTran x,:postType y]
postAtAt: %ParseTree -> %ParseForm
postAtAt t ==
- t isnt ["@@",x,y] => systemErrorHere "postAtAt"
+ t isnt ["@@",x,y] => systemErrorHere ["postAtAt",t]
["@@",postTran x,:postType y]
postConstruct: %ParseTree -> %ParseForm
@@ -189,7 +189,7 @@ postAtom x ==
postBlock: %ParseTree -> %ParseForm
postBlock t ==
- t isnt ["%Block",:l,x] => systemErrorHere "postBlock"
+ t isnt ["%Block",:l,x] => systemErrorHere ["postBlock",t]
["SEQ",:postBlockItemList l,["exit",postTran x]]
postBlockItemList: %List -> %List
@@ -205,7 +205,7 @@ postBlockItem x ==
postCategory: %ParseTree -> %ParseForm
postCategory u ==
- u isnt ["CATEGORY",:l] => systemErrorHere "postCategory"
+ u isnt ["CATEGORY",:l] => systemErrorHere ["postCategory",u]
--RDJ: ugh_ please -- someone take away need for PROGN as soon as possible
null l => u
op :=
@@ -221,8 +221,7 @@ postComma u ==
postDef: %ParseTree -> %ParseForm
postDef t ==
- t isnt [defOp,lhs,rhs] => systemErrorHere "postDef"
---+
+ t isnt [defOp,lhs,rhs] => systemErrorHere ["postDef",t]
lhs is ["macro",name] => postMDef ["==>",name,rhs]
recordHeaderDocumentation nil
@@ -278,7 +277,7 @@ postMDef(t) ==
postElt: %ParseTree -> %ParseForm
postElt u ==
- u isnt [.,a,b] => systemErrorHere "postElt"
+ u isnt [.,a,b] => systemErrorHere ["postElt",u]
a:= postTran a
b is ["%Sequence",:.] => [["elt",a,"makeRecord"],:postTranList rest b]
["elt",a,postTran b]
@@ -286,7 +285,7 @@ postElt u ==
postExit: %ParseTree -> %ParseForm
postExit t ==
- t isnt ["=>",a,b] => systemErrorHere "postExit"
+ t isnt ["=>",a,b] => systemErrorHere ["postExit",t]
["IF",postTran a,["exit",postTran b],"%noBranch"]
@@ -297,7 +296,7 @@ postFlatten(x,op) ==
postForm: %ParseTree -> %ParseForm
postForm u ==
- u isnt [op,:argl] => systemErrorHere "postForm"
+ u isnt [op,:argl] => systemErrorHere ["postForm",u]
x:=
atom op =>
argl':= postTranList argl
@@ -324,12 +323,12 @@ postQuote [.,a] ==
postScriptsForm: (%ParseTree,%List) -> %ParseForm
postScriptsForm(t,argl) ==
- t isnt ["Scripts",op,a] => systemErrorHere "postScriptsForm"
+ t isnt ["Scripts",op,a] => systemErrorHere ["postScriptsForm",t]
[getScriptName(op,a,#argl),:postTranScripts a,:argl]
postScripts: %ParseTree -> %ParseForm
postScripts t ==
- t isnt ["Scripts",op,a] => systemErrorHere "postScripts"
+ t isnt ["Scripts",op,a] => systemErrorHere ["postScripts",t]
[getScriptName(op,a,0),:postTranScripts a]
getScriptName: (%Symbol,%ParseTree, %Short) -> %ParseForm
@@ -389,18 +388,18 @@ postOp x ==
postRepeat: %ParseTree -> %ParseForm
postRepeat t ==
- t isnt ["REPEAT",:m,x] => systemErrorHere "postRepeat"
+ t isnt ["REPEAT",:m,x] => systemErrorHere ["postRepeat",t]
["REPEAT",:postIteratorList m,postTran x]
postSEGMENT: %ParseTree -> %ParseForm
postSEGMENT t ==
- t isnt ["SEGMENT",a,b] => systemErrorHere "postSEGMENT"
+ t isnt ["SEGMENT",a,b] => systemErrorHere ["postSEGMENT",t]
key:= [a,'"..",:(b => [b]; nil)]
postError ['" Improper placement of segment",:bright key]
postCollect: %ParseTree -> %ParseForm
postCollect t ==
- t isnt [constructOp,:m,x] => systemErrorHere "postCollect"
+ t isnt [constructOp,:m,x] => systemErrorHere ["postCollect",t]
x is [["elt",D,"construct"],:y] =>
postCollect [["elt",D,"COLLECT"],:m,["construct",:y]]
itl:= postIteratorList m
@@ -419,7 +418,7 @@ postCollect t ==
postTupleCollect: %ParseTree -> %ParseForm
postTupleCollect t ==
- t isnt [constructOp,:m,x] => systemErrorHere "postTupleCollect"
+ t isnt [constructOp,:m,x] => systemErrorHere ["postTupleCollect",t]
postCollect [constructOp,:m,["construct",x]]
postIteratorList: %List -> %List
@@ -433,12 +432,12 @@ postIteratorList x ==
postin: %ParseTree -> %ParseForm
postin arg ==
- arg isnt ["in",i,seq] => systemErrorHere '"postin"
+ arg isnt ["in",i,seq] => systemErrorHere ["postin",arg]
["in",postTran i, postInSeq seq]
postIn: %ParseTree -> %ParseForm
postIn arg ==
- arg isnt ["IN",i,seq] => systemErrorHere '"postIn"
+ arg isnt ["IN",i,seq] => systemErrorHere ["postIn",arg]
["IN",postTran i,postInSeq seq]
postInSeq: %ParseTree -> %ParseForm
@@ -470,7 +469,7 @@ SEGMENT(a,b) ==
postReduce: %ParseTree -> %ParseForm
postReduce t ==
- t isnt ["%Reduce",op,expr] => systemErrorHere "postReduce"
+ t isnt ["%Reduce",op,expr] => systemErrorHere ["postReduce",t]
$InteractiveMode or expr is ["COLLECT",:.] =>
["REDUCE",op,0,postTran expr]
postReduce ["%Reduce",op,["COLLECT",["IN",g:= GENSYM(),expr],
@@ -487,12 +486,12 @@ postSemiColon u ==
postSequence: %ParseTree -> %ParseForm
postSequence t ==
- t isnt ["%Sequence",:l] => systemErrorHere "postSequence"
+ t isnt ["%Sequence",:l] => systemErrorHere ["postSequence",t]
['(elt $ makeRecord),:postTranList l]
postSignature: %ParseTree -> %ParseForm
postSignature t ==
- t isnt ["%Signature",op,sig] => systemErrorHere "postSignature"
+ t isnt ["%Signature",op,sig] => systemErrorHere ["postSignature",t]
sig is ["->",:.] =>
sig1:= postType sig
op:= postAtom (STRINGP op => INTERN op; op)
@@ -509,7 +508,7 @@ killColons x ==
postSlash: %ParseTree -> %ParseForm
postSlash t ==
- t isnt ['_/,a,b] => systemErrorHere "postSlash"
+ t isnt ['_/,a,b] => systemErrorHere ["postSlash",t]
STRINGP a => postTran ["%Reduce",INTERN a,b]
['_/,postTran a,postTran b]
@@ -536,7 +535,7 @@ post%Comma u ==
postWhere: %ParseTree -> %ParseForm
postWhere t ==
- t isnt ["where",a,b] => systemErrorHere "postWhere"
+ t isnt ["where",a,b] => systemErrorHere ["postWhere",t]
x:=
b is ["%Block",:c] => c
[b]
@@ -544,7 +543,7 @@ postWhere t ==
postWith: %ParseTree -> %ParseForm
postWith t ==
- t isnt ["with",a] => systemErrorHere "postWidth"
+ t isnt ["with",a] => systemErrorHere ["postWidth",t]
$insidePostCategoryIfTrue: local := true
a:= postTran a
a is [op,:.] and MEMQ(op,'(SIGNATURE ATTRIBUTE IF)) => ["CATEGORY",a]
@@ -599,7 +598,7 @@ postAlternatives alts ==
postMatch: %ParseTree -> %ParseForm
postMatch t ==
- t isnt ["%Match",expr,alts] => systemErrorHere "postMatch"
+ t isnt ["%Match",expr,alts] => systemErrorHere ["postMatch",t]
alts :=
alts is [";",:.] => ["%Block",:postFlattenLeft(alts,";")]
alts
diff --git a/src/interp/preparse.lisp b/src/interp/preparse.lisp
index 48a44d41..cee7a6e2 100644
--- a/src/interp/preparse.lisp
+++ b/src/interp/preparse.lisp
@@ -352,42 +352,54 @@
(defun PARSEPILES (LOCS LINES)
"Add parens and semis to lines to aid parsing."
- (mapl #'add-parens-and-semis-to-line (NCONC LINES '(" ")) (nconc locs '(nil)))
+ (mapl #'add-parens-and-semis-to-line
+ (NCONC LINES '(" "))
+ (nconc locs '(nil)))
LINES)
(defun add-parens-and-semis-to-line (slines slocs)
- "The line to be worked on is (CAR SLINES). It's indentation is (CAR SLOCS). There
-is a notion of current indentation. Then:
+ "The line to be worked on is (CAR SLINES).
+ It's indentation is (CAR SLOCS).
+ There is a notion of current indentation. Then:
-A. Add open paren to beginning of following line if following line's indentation
- is greater than current, and add close paren to end of last succeeding line
- with following line's indentation.
-B. Add semicolon to end of line if following line's indentation is the same.
-C. If the entire line consists of the single keyword then or else, leave it alone."
+ A. Add open paren to beginning of following line if following
+ line's indentation is greater than current, and add close paren
+ to end of last succeeding line with following line's indentation.
+ B. Add semicolon to end of line if following line's indentation is
+ the same.
+ C. If the entire line consists of the single keyword then or else,
+ leave it alone."
(let ((start-column (car slocs)))
(if (and start-column (> start-column 0))
- (let ((count 0) (i 0))
+ (let ((count 0)
+ (i 0))
(seq
(mapl #'(lambda (next-lines nlocs)
- (let ((next-line (car next-lines)) (next-column (car nlocs)))
+ (let ((next-line (car next-lines))
+ (next-column (car nlocs)))
(incf i)
(if next-column
- (progn (setq next-column (abs next-column))
- (if (< next-column start-column) (exit nil))
- (cond ((and (eq next-column start-column)
- (rplaca nlocs (- (car nlocs)))
- (not (infixtok next-line)))
- (setq next-lines (drop (1- i) slines))
- (rplaca next-lines (addclose (car next-lines) #\;))
- (setq count (1+ count))))))))
+ (progn
+ (setq next-column (abs next-column))
+ (if (< next-column start-column)
+ (exit nil))
+ (cond
+ ((and (eq next-column start-column)
+ (rplaca nlocs (- (car nlocs)))
+ (not (infixtok next-line)))
+ (setq next-lines (drop (1- i) slines))
+ (rplaca next-lines
+ (addclose (car next-lines) #\;))
+ (setq count (1+ count))))))))
(cdr slines) (cdr slocs)))
(if (> count 0)
- (progn (setf (char (car slines) (1- (nonblankloc (car slines))))
- #\( )
- (setq slines (drop (1- i) slines))
- (rplaca slines (addclose (car slines) #\) ))))))))
+ (progn
+ (setf (char (car slines) (1- (nonblankloc (car slines))))
+ #\( )
+ (setq slines (drop (1- i) slines))
+ (rplaca slines (addclose (car slines) #\) ))))))))
(defun INFIXTOK (S) (MEMBER (STRING2ID-N S 1) '(|then| |else|) :test #'eq))
diff --git a/src/interp/wi1.boot b/src/interp/wi1.boot
index 201a8a71..65ad705c 100644
--- a/src/interp/wi1.boot
+++ b/src/interp/wi1.boot
@@ -174,7 +174,6 @@ compTopLevel(x,m,e) ==
$NRTderivedTargetIfTrue: local := false
$killOptimizeIfTrue: local:= false
$forceAdd: local:= false
- $packagesUsed: local := []
-- The next line allows the new compiler to be tested interactively.
compFun := 'compOrCroak
if x is ["where",:.] then x := markWhereTran x
@@ -685,7 +684,7 @@ canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends
atom op => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr]
op is ["XLAM",args,bods] =>
and/[canReturn(u,level,exitCount,ValueFlag) for u in expr]
- systemErrorHere '"canReturn" --for the time being
+ systemErrorHere ["canReturn",expr] --for the time being
compList(l,m is ["List",mUnder],e) ==
markImport m
@@ -1073,7 +1072,6 @@ compNot([op,arg], pWas, m, e) ==
compDefine(form,m,e) ==
$macroIfTrue: local
- $packagesUsed: local
['DEF,.,originalSignature,.,body] := form
if not $insideFunctorIfTrue then
$originalBody := COPY body
diff --git a/src/interp/wi2.boot b/src/interp/wi2.boot
index 46075fdb..cc1d843b 100644
--- a/src/interp/wi2.boot
+++ b/src/interp/wi2.boot
@@ -78,7 +78,6 @@ compDefineFunctor1(df, m,$e,$prefix,$formalArgList) ==
--prevents CheckVector from printing out same message twice
$getDomainCode: local -- code for getting views
$insideFunctorIfTrue: local:= true
- $functorsUsed: local := nil --not currently used, finds dependent functors
$setelt: local := "setShellEntry"
$genSDVar: local:= 0
originale:= $e
@@ -190,7 +189,6 @@ compDefineFunctor1(df, m,$e,$prefix,$formalArgList) ==
reportOnFunctorCompilation()
-- 5. give operator a 'modemap property
--- if $functorsUsed then MAKEPROP(op',"NEEDS",$functorsUsed)
$insideFunctorIfTrue:= false
if $LISPLIB then
$lisplibKind:=
@@ -1118,8 +1116,6 @@ doItLet1 item ==
$functorLocalParameters:= [:$functorLocalParameters,lhs]
if (rhs' := rhsOfLetIsDomainForm code) then
if isFunctor rhs' then
- $functorsUsed:= insert(opOf rhs',$functorsUsed)
- $packagesUsed:= insert([opOf rhs'],$packagesUsed)
$globalImportDefAlist := pp [[lhs, :rhs'],:$globalImportDefAlist]
if lhs="Rep" then
$Representation:= (get("Rep",'value,$e)).expr
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-09 07:24:48 +0000