From a03f68879f697998e2a3f41029a2034dc76767e0 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Tue, 16 Dec 2008 16:22:08 +0000 Subject: r12470@gauss: gdr | 2008-12-14 17:43:50 -0600 Forgot to commit ChangeLog. r12471@gauss: gdr | 2008-12-14 19:11:21 -0600 Fix typo in PrimitiveRatRicDE. r12472@gauss: gdr | 2008-12-15 01:40:45 -0600 Reformat preparse.lisp. r12473@gauss: gdr | 2008-12-15 03:25:17 -0600 Tidy. r12474@gauss: gdr | 2008-12-15 21:33:54 -0600 Remove unused codes. r12475@gauss: gdr | 2008-12-15 21:57:22 -0600 . r12476@gauss: gdr | 2008-12-15 23:07:49 -0600 Tidy fatal diagnostics. r12477@gauss: gdr | 2008-12-15 23:50:02 -0600 Fold iterator.boot into compiler.boot. --- src/ChangeLog | 22 +++ src/algebra/riccati.spad.pamphlet | 2 +- src/interp/Makefile.in | 6 +- src/interp/Makefile.pamphlet | 6 +- src/interp/buildom.boot | 2 +- src/interp/clam.boot | 2 +- src/interp/compiler.boot | 290 +++++++++++++++++++++++++++++++++-- src/interp/define.boot | 29 +--- src/interp/format.boot | 2 +- src/interp/functor.boot | 20 ++- src/interp/g-opt.boot | 5 +- src/interp/i-funsel.boot | 2 +- src/interp/i-intern.boot | 4 +- src/interp/i-spec2.boot | 2 +- src/interp/i-syscmd.boot | 2 +- src/interp/i-toplev.boot | 2 +- src/interp/iterator.boot | 307 -------------------------------------- src/interp/lisplib.boot | 6 +- src/interp/msgdb.boot | 6 +- src/interp/nrungo.boot | 2 +- src/interp/parse.boot | 55 +++---- src/interp/postpar.boot | 51 ++++--- src/interp/preparse.lisp | 56 ++++--- src/interp/wi1.boot | 4 +- src/interp/wi2.boot | 4 - 25 files changed, 430 insertions(+), 459 deletions(-) delete mode 100644 src/interp/iterator.boot 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 + + * 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 * 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 -- cgit v1.2.3