diff --git a/changelog b/changelog index c3cfcda..2162a17 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090827 tpd src/axiom-website/patches.html 20090827.08.tpd.patch +20090827 tpd src/interp/Makefile move iterator.boot to iterator.lisp +20090827 tpd src/interp/iterator.lisp added, rewritten from iterator.boot +20090827 tpd src/interp/iterator.boot removed, rewritten to iterator.lisp 20090827 tpd src/axiom-website/patches.html 20090827.07.tpd.patch 20090827 tpd src/interp/Makefile move info.boot to info.lisp 20090827 tpd src/interp/info.lisp added, rewritten from info.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index d623c70..8684b11 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1924,5 +1924,7 @@ define.lisp rewrite from boot to lisp
functor.lisp rewrite from boot to lisp
20090827.07.tpd.patch info.lisp rewrite from boot to lisp
+20090827.08.tpd.patch +iterator.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index c744ae3..9c2fa38 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -3188,53 +3188,27 @@ ${MID}/info.lisp: ${IN}/info.lisp.pamphlet @ -\subsection{iterator.boot} -<>= -${AUTO}/iterator.${O}: ${OUT}/iterator.${O} - @ echo 331 making ${AUTO}/iterator.${O} from ${OUT}/iterator.${O} - @ cp ${OUT}/iterator.${O} ${AUTO} - -@ +\subsection{iterator.lisp} <>= -${OUT}/iterator.${O}: ${MID}/iterator.clisp - @ echo 332 making ${OUT}/iterator.${O} from ${MID}/iterator.clisp - @ (cd ${MID} ; \ +${OUT}/iterator.${O}: ${MID}/iterator.lisp + @ echo 136 making ${OUT}/iterator.${O} from ${MID}/iterator.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/iterator.clisp"' \ + echo '(progn (compile-file "${MID}/iterator.lisp"' \ ':output-file "${OUT}/iterator.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/iterator.clisp"' \ + echo '(progn (compile-file "${MID}/iterator.lisp"' \ ':output-file "${OUT}/iterator.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/iterator.clisp: ${IN}/iterator.boot.pamphlet - @ echo 333 making ${MID}/iterator.clisp \ - from ${IN}/iterator.boot.pamphlet +<>= +${MID}/iterator.lisp: ${IN}/iterator.lisp.pamphlet + @ echo 137 making ${MID}/iterator.lisp from \ + ${IN}/iterator.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/iterator.boot.pamphlet >iterator.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "iterator.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "iterator.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm iterator.boot ) - -@ -<>= -${DOC}/iterator.boot.dvi: ${IN}/iterator.boot.pamphlet - @echo 334 making ${DOC}/iterator.boot.dvi \ - from ${IN}/iterator.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/iterator.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} iterator.boot ; \ - rm -f ${DOC}/iterator.boot.pamphlet ; \ - rm -f ${DOC}/iterator.boot.tex ; \ - rm -f ${DOC}/iterator.boot ) + ${TANGLE} ${IN}/iterator.lisp.pamphlet >iterator.lisp ) @ @@ -5518,10 +5492,8 @@ clean: <> <> -<> <> -<> -<> +<> <> <> diff --git a/src/interp/iterator.boot.pamphlet b/src/interp/iterator.boot.pamphlet deleted file mode 100644 index 235a4c4..0000000 --- a/src/interp/iterator.boot.pamphlet +++ /dev/null @@ -1,315 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp iterator.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- 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. - -@ -<<*>>= -<> - ---% 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 - $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,e] - -getIdentity(x,e) == - GET(x,"THETA") is [y] => y - -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 - [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']:= - -- (m1:= listOrVectorElementMode targetMode) and comp(body,m1,e) or - 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' - coerceExit([form',m'',e'],targetMode) - ---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: ",m," must be a list of some mode"] - 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: ",m," must be a list of other modes"] - 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: ",start," must be an integer"] - [inc,.,e]:= - comp(inc,$Integer,e) or return - stackMessage ["index increment:",inc," must be an integer"] - if optFinal is [final] then - [final,.,e]:= - comp(final,$Integer,e) or return - stackMessage ["final value of index: ",final," must be an integer"] - 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: ",p," is not Boolean valued"] - [["WHILE",p'],e] - it is ["UNTIL",p] => ($until:= p; ['$until,e]) - it is ["|",x] => - u:= - comp(x,$Boolean,e) or return - stackMessage ["SUCHTHAT operand: ",x," is not Boolean value"] - [["|",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: ",start," is not an integer"] --- [inc,.,e]:= --- comp(inc,$NonNegativeInteger,e) or return --- stackMessage ["index increment: ",inc," must be a non-negative integer"] --- [final,.,e]:= --- comp(final,$Integer,e) or return --- stackMessage ["final value of index: ",final," is not an integer"] --- 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] - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/iterator.lisp.pamphlet b/src/interp/iterator.lisp.pamphlet new file mode 100644 index 0000000..d6bd49c --- /dev/null +++ b/src/interp/iterator.lisp.pamphlet @@ -0,0 +1,915 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp iterator.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= +(IN-PACKAGE "BOOT" ) + +;--% ITERATORS +; +;compReduce(form,m,e) == +; compReduce1(form,m,e,$formalArgList) + +(DEFUN |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 +; $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,e] + +(DEFUN |compReduce1| (|form| |m| |e| |$formalArgList|) + (DECLARE (SPECIAL |$formalArgList|)) + (PROG (|$sideEffectsList| |$until| |$initList| |$endTestList| + |collectForm| |collectOp| |body| |op| |itl| |acc| + |afterFirst| |bodyVal| |part1| |part2| |part3| |id| + |identityCode| |LETTMP#1| |untilCode| |finalCode|) + (DECLARE (SPECIAL |$sideEffectsList| |$until| |$initList| + |$endTestList|)) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR |form|) 'REDUCE) (CAR |form|))) + (SPADLET |op| (CADR |form|)) + (SPADLET |collectForm| (CADDDR |form|)) + (SPADLET |collectOp| (CAR |collectForm|)) + (SPADLET |LETTMP#1| (REVERSE (CDR |collectForm|))) + (SPADLET |body| (CAR |LETTMP#1|)) + (SPADLET |itl| (NREVERSE (CDR |LETTMP#1|))) + (COND ((STRINGP |op|) (SPADLET |op| (INTERN |op|)))) + (COND + ((NULL (MEMQ |collectOp| '(COLLECT COLLECTV COLLECTVEC))) + (|systemError| + (CONS '|illegal reduction form:| (CONS |form| NIL)))) + ('T (SPADLET |$sideEffectsList| NIL) + (SPADLET |$until| NIL) (SPADLET |$initList| NIL) + (SPADLET |$endTestList| NIL) (SPADLET |$e| |e|) + (SPADLET |itl| + (PROG (G166146) + (SPADLET G166146 NIL) + (RETURN + (DO ((G166154 |itl| (CDR G166154)) + (|x| NIL)) + ((OR (ATOM G166154) + (PROGN + (SETQ |x| (CAR G166154)) + NIL)) + (NREVERSE0 G166146)) + (SEQ (EXIT + (SETQ G166146 + (CONS + (ELT + (PROGN + (SPADLET |LETTMP#1| + (OR + (|compIterator| |x| |$e|) + (RETURN '|failed|))) + (SPADLET |$e| + (CADR |LETTMP#1|)) + |LETTMP#1|) + 0) + G166146)))))))) + (COND + ((BOOT-EQUAL |itl| '|failed|) (RETURN NIL)) + ('T (SPADLET |e| |$e|) (SPADLET |acc| (GENSYM)) + (SPADLET |afterFirst| (GENSYM)) + (SPADLET |bodyVal| (GENSYM)) + (SPADLET |LETTMP#1| + (OR (|comp| (CONS 'LET + (CONS |bodyVal| + (CONS |body| NIL))) + |m| |e|) + (RETURN NIL))) + (SPADLET |part1| (CAR |LETTMP#1|)) + (SPADLET |m| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (SPADLET |LETTMP#1| + (OR (|comp| (CONS 'LET + (CONS |acc| + (CONS |bodyVal| NIL))) + |m| |e|) + (RETURN NIL))) + (SPADLET |part2| (CAR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (SPADLET |LETTMP#1| + (OR (|comp| (CONS 'LET + (CONS |acc| + (CONS + (|parseTran| + (CONS |op| + (CONS |acc| + (CONS |bodyVal| NIL)))) + NIL))) + |m| |e|) + (RETURN NIL))) + (SPADLET |part3| (CAR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (SPADLET |identityCode| + (COND + ((SPADLET |id| (|getIdentity| |op| |e|)) + (CAR (OR (|comp| |id| |m| |e|) + (RETURN NIL)))) + ('T + (CONS '|IdentityError| + (CONS (MKQ |op|) NIL))))) + (SPADLET |finalCode| + (CONS 'PROGN + (CONS (CONS 'LET + (CONS |afterFirst| + (CONS NIL NIL))) + (CONS + (CONS 'REPEAT + (APPEND |itl| + (CONS + (CONS 'PROGN + (CONS |part1| + (CONS + (CONS 'IF + (CONS |afterFirst| + (CONS |part3| + (CONS + (CONS 'PROGN + (CONS |part2| + (CONS + (CONS 'LET + (CONS + |afterFirst| + (CONS (MKQ 'T) + NIL))) + NIL))) + NIL)))) + NIL))) + NIL))) + (CONS + (CONS 'IF + (CONS |afterFirst| + (CONS |acc| + (CONS |identityCode| NIL)))) + NIL))))) + (COND + (|$until| + (SPADLET |LETTMP#1| + (|comp| |$until| |$Boolean| |e|)) + (SPADLET |untilCode| (CAR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (SPADLET |finalCode| + (MSUBST (CONS 'UNTIL + (CONS |untilCode| NIL)) + '|$until| |finalCode|)))) + (CONS |finalCode| (CONS |m| (CONS |e| NIL)))))))))))) + +;getIdentity(x,e) == +; GET(x,"THETA") is [y] => y + +(DEFUN |getIdentity| (|x| |e|) + (PROG (|ISTMP#1| |y|) + (RETURN + (SEQ (COND + ((PROGN + (SPADLET |ISTMP#1| (GETL |x| 'THETA)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) 'T))) + (EXIT |y|))))))) + +;numberize x == +; x=$Zero => 0 +; x=$One => 1 +; atom x => x +; [numberize first x,:numberize rest x] + +(DEFUN |numberize| (|x|) + (COND + ((BOOT-EQUAL |x| |$Zero|) 0) + ((BOOT-EQUAL |x| |$One|) 1) + ((ATOM |x|) |x|) + ('T (CONS (|numberize| (CAR |x|)) (|numberize| (CDR |x|)))))) + +;compRepeatOrCollect(form,m,e) == +; fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList +; ,e) where +; fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) == +; $until: local := nil +; [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']:= +; -- (m1:= listOrVectorElementMode targetMode) and comp(body,m1,e) or +; 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' +; coerceExit([form',m'',e'],targetMode) + +(DEFUN |compRepeatOrCollect,fn| + (|form| |$exitModeStack| |$leaveLevelStack| |$formalArgList| + |e|) + (DECLARE (SPECIAL |$exitModeStack| |$leaveLevelStack| + |$formalArgList|)) + (PROG (|$until| |body| |itl| |x'| |targetMode| |repeatOrCollect| + |bodyMode| |body'| |m'| |LETTMP#1| |untilCode| |e'| |itl'| + |form'| |u| |m''|) + (DECLARE (SPECIAL |$until|)) + (RETURN + (SEQ (SPADLET |$until| NIL) + (PROGN + (SPADLET |repeatOrCollect| (CAR |form|)) + (SPADLET |LETTMP#1| (REVERSE (CDR |form|))) + (SPADLET |body| (CAR |LETTMP#1|)) + (SPADLET |itl| (NREVERSE (CDR |LETTMP#1|))) + |form|) + (SPADLET |itl'| + (PROG (G166269) + (SPADLET G166269 NIL) + (RETURN + (DO ((G166278 |itl| (CDR G166278)) + (|x| NIL)) + ((OR (ATOM G166278) + (PROGN + (SETQ |x| (CAR G166278)) + NIL)) + (NREVERSE0 G166269)) + (SEQ (EXIT (SETQ G166269 + (CONS + (SEQ + (PROGN + (SPADLET |LETTMP#1| + (OR (|compIterator| |x| |e|) + (RETURN '|failed|))) + (SPADLET |x'| + (CAR |LETTMP#1|)) + (SPADLET |e| + (CADR |LETTMP#1|)) + |LETTMP#1|) + (EXIT |x'|)) + G166269)))))))) + (IF (BOOT-EQUAL |itl'| '|failed|) (EXIT NIL)) + (SPADLET |targetMode| (CAR |$exitModeStack|)) + (SPADLET |bodyMode| + (SEQ (IF (BOOT-EQUAL |repeatOrCollect| 'COLLECT) + (EXIT (SEQ + (IF + (BOOT-EQUAL |targetMode| + '|$EmptyMode|) + (EXIT '|$EmptyMode|)) + (IF + (SPADLET |u| + (|modeIsAggregateOf| '|List| + |targetMode| |e|)) + (EXIT (CADR |u|))) + (IF + (SPADLET |u| + (|modeIsAggregateOf| + '|PrimitiveArray| |targetMode| + |e|)) + (EXIT + (SEQ + (SPADLET |repeatOrCollect| + 'COLLECTV) + (EXIT (CADR |u|))))) + (IF + (SPADLET |u| + (|modeIsAggregateOf| '|Vector| + |targetMode| |e|)) + (EXIT + (SEQ + (SPADLET |repeatOrCollect| + 'COLLECTVEC) + (EXIT (CADR |u|))))) + (|stackMessage| + (MAKESTRING + "Invalid collect bodytype")) + (EXIT (RETURN NIL))))) + (EXIT |$NoValueMode|))) + (PROGN + (SPADLET |LETTMP#1| + (OR (|compOrCroak| |body| |bodyMode| |e|) + (RETURN NIL))) + (SPADLET |body'| (CAR |LETTMP#1|)) + (SPADLET |m'| (CADR |LETTMP#1|)) + (SPADLET |e'| (CADDR |LETTMP#1|)) + |LETTMP#1|) + (IF |$until| + (SEQ (PROGN + (SPADLET |LETTMP#1| + (|comp| |$until| |$Boolean| |e'|)) + (SPADLET |untilCode| (CAR |LETTMP#1|)) + (SPADLET |e'| (CADDR |LETTMP#1|)) + |LETTMP#1|) + (EXIT (SPADLET |itl'| + (MSUBST + (CONS 'UNTIL + (CONS |untilCode| NIL)) + '|$until| |itl'|)))) + NIL) + (SPADLET |form'| + (CONS |repeatOrCollect| + (APPEND |itl'| (CONS |body'| NIL)))) + (SPADLET |m''| + (SEQ (IF (BOOT-EQUAL |repeatOrCollect| 'COLLECT) + (EXIT (SEQ + (IF + (SPADLET |u| + (|modeIsAggregateOf| '|List| + |targetMode| |e|)) + (EXIT (CAR |u|))) + (EXIT + (CONS '|List| (CONS |m'| NIL)))))) + (IF (BOOT-EQUAL |repeatOrCollect| 'COLLECTV) + (EXIT (SEQ + (IF + (SPADLET |u| + (|modeIsAggregateOf| + '|PrimitiveArray| |targetMode| + |e|)) + (EXIT (CAR |u|))) + (EXIT + (CONS '|PrimitiveArray| + (CONS |m'| NIL)))))) + (IF (BOOT-EQUAL |repeatOrCollect| 'COLLECTVEC) + (EXIT (SEQ + (IF + (SPADLET |u| + (|modeIsAggregateOf| '|Vector| + |targetMode| |e|)) + (EXIT (CAR |u|))) + (EXIT + (CONS '|Vector| (CONS |m'| NIL)))))) + (EXIT |m'|))) + (EXIT (|coerceExit| + (CONS |form'| (CONS |m''| (CONS |e'| NIL))) + |targetMode|)))))) + +(DEFUN |compRepeatOrCollect| (|form| |m| |e|) + (|compRepeatOrCollect,fn| |form| (CONS |m| |$exitModeStack|) + (CONS (|#| |$exitModeStack|) |$leaveLevelStack|) |$formalArgList| + |e|)) + +;--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 + +(DEFUN |listOrVectorElementMode| (|x|) + (PROG (|a| |ISTMP#1| |b|) + (RETURN + (SEQ (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |a| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |b| (QCAR |ISTMP#1|)) 'T))) + (|member| |a| '(|PrimitiveArray| |Vector| |List|))) + (EXIT |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: ",m," must be a list of some mode"] +; 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: ",m," must be a list of other modes"] +; 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: ",start," must be an integer"] +; [inc,.,e]:= +; comp(inc,$Integer,e) or return +; stackMessage ["index increment:",inc," must be an integer"] +; if optFinal is [final] then +; [final,.,e]:= +; comp(final,$Integer,e) or return +; stackMessage ["final value of index: ",final," must be an integer"] +; 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: ",p," is not Boolean valued"] +; [["WHILE",p'],e] +; it is ["UNTIL",p] => ($until:= p; ['$until,e]) +; it is ["|",x] => +; u:= +; comp(x,$Boolean,e) or return +; stackMessage ["SUCHTHAT operand: ",x," is not Boolean value"] +; [["|",u.expr],u.env] +; nil + +(DEFUN |compIterator| (|it| |e|) + (PROG (|y| |y'| |mOver| |mUnder| |y''| |m''| |index| |ISTMP#2| + |ISTMP#3| |start'| |inc'| |final'| |start| |inc| |final| + |optFinal| |indexmode| |LETTMP#1| |p'| |m| |p| |ISTMP#1| + |x| |u|) + (RETURN + (COND + ((AND (PAIRP |it|) (EQ (QCAR |it|) 'IN) + (PROGN + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) 'T)))))) + (SPADLET |LETTMP#1| + (OR (|comp| |y| |$EmptyMode| |e|) (RETURN NIL))) + (SPADLET |y'| (CAR |LETTMP#1|)) + (SPADLET |m| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (SPADLET |$formalArgList| (CONS |x| |$formalArgList|)) + (SPADLET |LETTMP#1| + (OR (|modeIsAggregateOf| '|List| |m| |e|) + (RETURN + (|stackMessage| + (CONS '|mode: | + (CONS |m| + (CONS + '| must be a list of some mode| + NIL))))))) + (SPADLET |mOver| (CAR |LETTMP#1|)) + (SPADLET |mUnder| (CADR |LETTMP#1|)) + (COND + ((NULL (|get| |x| '|mode| |e|)) + (SPADLET |LETTMP#1| + (OR (|compMakeDeclaration| + (CONS '|:| (CONS |x| (CONS |mUnder| NIL))) + |$EmptyMode| |e|) + (RETURN NIL))) + (SPADLET |e| (CADDR |LETTMP#1|)) |LETTMP#1|)) + (SPADLET |e| + (|put| |x| '|value| + (CONS (|genSomeVariable|) + (CONS |mUnder| (CONS |e| NIL))) + |e|)) + (SPADLET |LETTMP#1| + (OR (|coerce| (CONS |y'| (CONS |m| (CONS |e| NIL))) + |mOver|) + (RETURN NIL))) + (SPADLET |y''| (CAR |LETTMP#1|)) + (SPADLET |m''| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (CONS (CONS 'IN (CONS |x| (CONS |y''| NIL))) (CONS |e| NIL))) + ((AND (PAIRP |it|) (EQ (QCAR |it|) 'ON) + (PROGN + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) 'T)))))) + (SPADLET |$formalArgList| (CONS |x| |$formalArgList|)) + (SPADLET |LETTMP#1| + (OR (|comp| |y| |$EmptyMode| |e|) (RETURN NIL))) + (SPADLET |y'| (CAR |LETTMP#1|)) + (SPADLET |m| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (SPADLET |LETTMP#1| + (OR (|modeIsAggregateOf| '|List| |m| |e|) + (RETURN + (|stackMessage| + (CONS '|mode: | + (CONS |m| + (CONS + '| must be a list of other modes| + NIL))))))) + (SPADLET |mOver| (CAR |LETTMP#1|)) + (SPADLET |mUnder| (CADR |LETTMP#1|)) + (COND + ((NULL (|get| |x| '|mode| |e|)) + (SPADLET |LETTMP#1| + (OR (|compMakeDeclaration| + (CONS '|:| (CONS |x| (CONS |m| NIL))) + |$EmptyMode| |e|) + (RETURN NIL))) + (SPADLET |e| (CADDR |LETTMP#1|)) |LETTMP#1|)) + (SPADLET |e| + (|put| |x| '|value| + (CONS (|genSomeVariable|) + (CONS |m| (CONS |e| NIL))) + |e|)) + (SPADLET |LETTMP#1| + (OR (|coerce| (CONS |y'| (CONS |m| (CONS |e| NIL))) + |mOver|) + (RETURN NIL))) + (SPADLET |y''| (CAR |LETTMP#1|)) + (SPADLET |m''| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (CONS (CONS 'ON (CONS |x| (CONS |y''| NIL))) (CONS |e| NIL))) + ((AND (PAIRP |it|) (EQ (QCAR |it|) 'STEP) + (PROGN + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |index| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |start| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |inc| (QCAR |ISTMP#3|)) + (SPADLET |optFinal| + (QCDR |ISTMP#3|)) + 'T)))))))) + (SPADLET |$formalArgList| (CONS |index| |$formalArgList|)) + (SPADLET |final'| NIL) + (COND + ((AND (SPADLET |start'| + (|comp| |start| |$SmallInteger| |e|)) + (SPADLET |inc'| + (|comp| |inc| |$NonNegativeInteger| + (CADDR |start'|))) + (OR (NULL (AND (PAIRP |optFinal|) + (EQ (QCDR |optFinal|) NIL) + (PROGN + (SPADLET |final| (QCAR |optFinal|)) + 'T))) + (SPADLET |final'| + (|comp| |final| |$SmallInteger| + (CADDR |inc'|))))) + (SPADLET |indexmode| + (COND + ((|comp| |start| |$NonNegativeInteger| |e|) + |$NonNegativeInteger|) + ('T |$SmallInteger|))) + (COND + ((NULL (|get| |index| '|mode| |e|)) + (SPADLET |LETTMP#1| + (OR (|compMakeDeclaration| + (CONS '|:| + (CONS |index| + (CONS |indexmode| NIL))) + |$EmptyMode| + (COND + (|final'| (CADDR |final'|)) + ('T (CADDR |inc'|)))) + (RETURN NIL))) + (SPADLET |e| (CADDR |LETTMP#1|)) |LETTMP#1|)) + (SPADLET |e| + (|put| |index| '|value| + (CONS (|genSomeVariable|) + (CONS |indexmode| (CONS |e| NIL))) + |e|)) + (COND + (|final'| (SPADLET |optFinal| (CONS (CAR |final'|) NIL)))) + (CONS (CONS 'ISTEP + (CONS |index| + (CONS (CAR |start'|) + (CONS (CAR |inc'|) |optFinal|)))) + (CONS |e| NIL))) + ('T + (SPADLET |LETTMP#1| + (OR (|comp| |start| |$Integer| |e|) + (RETURN + (|stackMessage| + (CONS '|start value of index: | + (CONS |start| + (CONS '| must be an integer| NIL))))))) + (SPADLET |start| (CAR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (SPADLET |LETTMP#1| + (OR (|comp| |inc| |$Integer| |e|) + (RETURN + (|stackMessage| + (CONS '|index increment:| + (CONS |inc| + (CONS '| must be an integer| NIL))))))) + (SPADLET |inc| (CAR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (COND + ((AND (PAIRP |optFinal|) (EQ (QCDR |optFinal|) NIL) + (PROGN (SPADLET |final| (QCAR |optFinal|)) 'T)) + (SPADLET |LETTMP#1| + (OR (|comp| |final| |$Integer| |e|) + (RETURN + (|stackMessage| + (CONS '|final value of index: | + (CONS |final| + (CONS '| must be an integer| + NIL))))))) + (SPADLET |final| (CAR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (SPADLET |optFinal| (CONS |final| NIL)))) + (SPADLET |indexmode| + (COND + ((|comp| (CADDR |it|) |$NonNegativeInteger| |e|) + |$NonNegativeInteger|) + ('T |$Integer|))) + (COND + ((NULL (|get| |index| '|mode| |e|)) + (SPADLET |LETTMP#1| + (OR (|compMakeDeclaration| + (CONS '|:| + (CONS |index| + (CONS |indexmode| NIL))) + |$EmptyMode| |e|) + (RETURN NIL))) + (SPADLET |e| (CADDR |LETTMP#1|)) |LETTMP#1|)) + (SPADLET |e| + (|put| |index| '|value| + (CONS (|genSomeVariable|) + (CONS |indexmode| (CONS |e| NIL))) + |e|)) + (CONS (CONS 'STEP + (CONS |index| + (CONS |start| (CONS |inc| |optFinal|)))) + (CONS |e| NIL))))) + ((AND (PAIRP |it|) (EQ (QCAR |it|) 'WHILE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |p| (QCAR |ISTMP#1|)) 'T)))) + (SPADLET |LETTMP#1| + (OR (|comp| |p| |$Boolean| |e|) + (RETURN + (|stackMessage| + (CONS '|WHILE operand: | + (CONS |p| + (CONS '| is not Boolean valued| + NIL))))))) + (SPADLET |p'| (CAR |LETTMP#1|)) + (SPADLET |m| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (CONS (CONS 'WHILE (CONS |p'| NIL)) (CONS |e| NIL))) + ((AND (PAIRP |it|) (EQ (QCAR |it|) 'UNTIL) + (PROGN + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |p| (QCAR |ISTMP#1|)) 'T)))) + (SPADLET |$until| |p|) (CONS '|$until| (CONS |e| NIL))) + ((AND (PAIRP |it|) (EQ (QCAR |it|) '|\||) + (PROGN + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |x| (QCAR |ISTMP#1|)) 'T)))) + (SPADLET |u| + (OR (|comp| |x| |$Boolean| |e|) + (RETURN + (|stackMessage| + (CONS '|SUCHTHAT operand: | + (CONS |x| + (CONS '| is not Boolean value| + NIL))))))) + (CONS (CONS '|\|| (CONS (CAR |u|) NIL)) + (CONS (CADDR |u|) NIL))) + ('T 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: ",start," is not an integer"] +;-- [inc,.,e]:= +;-- comp(inc,$NonNegativeInteger,e) or return +;-- stackMessage ["index increment: ",inc," must be a non-negative integer"] +;-- [final,.,e]:= +;-- comp(final,$Integer,e) or return +;-- stackMessage ["final value of index: ",final," is not an integer"] +;-- 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] +; + +(DEFUN |modeIsAggregateOf| (|ListOrVector| |m| |e|) + (PROG (|l| |pair| |mList| |fn| |name| |ISTMP#1| |ISTMP#2| |ISTMP#3| + R) + (RETURN + (SEQ (COND + ((AND (PAIRP |m|) (EQUAL (QCAR |m|) |ListOrVector|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |m|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET R (QCAR |ISTMP#1|)) 'T)))) + (CONS |m| (CONS R NIL))) + ((AND (PAIRP |m|) (EQ (QCAR |m|) '|Union|) + (PROGN (SPADLET |l| (QCDR |m|)) 'T)) + (SPADLET |mList| + (PROG (G166653) + (SPADLET G166653 NIL) + (RETURN + (DO ((G166659 |l| (CDR G166659)) + (|m'| NIL)) + ((OR (ATOM G166659) + (PROGN + (SETQ |m'| (CAR G166659)) + NIL)) + (NREVERSE0 G166653)) + (SEQ (EXIT (COND + ((SPADLET |pair| + (|modeIsAggregateOf| + |ListOrVector| |m'| |e|)) + (SETQ G166653 + (CONS |pair| G166653)))))))))) + (COND ((EQL 1 (|#| |mList|)) (CAR |mList|)))) + ('T + (SPADLET |name| + (COND + ((AND (PAIRP |m|) + (PROGN (SPADLET |fn| (QCAR |m|)) 'T)) + |fn|) + ((BOOT-EQUAL |m| '$) '|Rep|) + ('T |m|))) + (COND + ((PROGN + (SPADLET |ISTMP#1| (|get| |name| '|value| |e|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQUAL (QCAR |ISTMP#2|) |ListOrVector|) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET R (QCAR |ISTMP#3|)) + 'T))))))) + (CONS |m| (CONS R NIL)))))))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}