diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index c3802fa..0cacffb 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -3683,139 +3683,16 @@ An angry JHD - August 15th., 1984 \calls{compJoin}{convert} \usesdollar{compJoin}{Category} <>= -(DEFUN |compJoin,getParms| (|y| |e|) - (PROG (|ISTMP#1| |y'|) - (RETURN - (SEQ (IF (ATOM |y|) - (EXIT (SEQ (IF (|isDomainForm| |y| |e|) - (EXIT (LIST |y|))) - (EXIT NIL)))) - (IF (AND (PAIRP |y|) (EQ (QCAR |y|) 'LENGTH) - (PROGN - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |y'| (QCAR |ISTMP#1|)) 'T)))) - (EXIT (CONS |y| (CONS |y'| NIL)))) - (EXIT (LIST |y|)))))) - -;(DEFUN |compJoin| (G170354 |m| |e|) -; (PROG (|argl| |catList| |ISTMP#1| |pl| |ISTMP#2| |body| |parameters| -; |catList'| T$) -; (declare (special |$Category|)) -; (RETURN -; (SEQ (PROGN -; (COND ((EQ (CAR G170354) '|Join|) (CAR G170354))) -; (SPADLET |argl| (CDR G170354)) -; (SPADLET |catList| -; (PROG (G170374) -; (SPADLET G170374 NIL) -; (RETURN -; (DO ((G170379 |argl| (CDR G170379)) -; (|x| NIL)) -; ((OR (ATOM G170379) -; (PROGN -; (SETQ |x| (CAR G170379)) -; NIL)) -; (NREVERSE0 G170374)) -; (SEQ (EXIT (SETQ G170374 -; (CONS -; (CAR -; (OR -; (|compForMode| |x| -; |$Category| |e|) -; (RETURN '|failed|))) -; G170374)))))))) -; (COND -; ((BOOT-EQUAL |catList| '|failed|) -; (|stackSemanticError| -; (CONS '|cannot form Join of: | (CONS |argl| NIL)) -; NIL)) -; ('T -; (SPADLET |catList'| -; (PROG (G170396) -; (SPADLET G170396 NIL) -; (RETURN -; (DO ((G170408 |catList| (CDR G170408)) -; (|x| NIL)) -; ((OR (ATOM G170408) -; (PROGN -; (SETQ |x| (CAR G170408)) -; NIL)) -; (NREVERSE0 G170396)) -; (SEQ (EXIT -; (SETQ G170396 -; (CONS -; (COND -; ((|isCategoryForm| |x| |e|) -; (SPADLET |parameters| -; (|union| -; (PROG (G170414) -; (SPADLET G170414 NIL) -; (RETURN -; (DO -; ((G170419 (CDR |x|) -; (CDR G170419)) -; (|y| NIL)) -; ((OR (ATOM G170419) -; (PROGN -; (SETQ |y| -; (CAR G170419)) -; NIL)) -; G170414) -; (SEQ -; (EXIT -; (SETQ G170414 -; (APPEND G170414 -; (|compJoin,getParms| -; |y| |e|)))))))) -; |parameters|)) -; |x|) -; ((AND (PAIRP |x|) -; (EQ (QCAR |x|) -; '|DomainSubstitutionMacro|) -; (PROGN -; (SPADLET |ISTMP#1| -; (QCDR |x|)) -; (AND (PAIRP |ISTMP#1|) -; (PROGN -; (SPADLET |pl| -; (QCAR |ISTMP#1|)) -; (SPADLET |ISTMP#2| -; (QCDR |ISTMP#1|)) -; (AND (PAIRP |ISTMP#2|) -; (EQ (QCDR |ISTMP#2|) -; NIL) -; (PROGN -; (SPADLET |body| -; (QCAR |ISTMP#2|)) -; 'T)))))) -; (SPADLET |parameters| -; (|union| |pl| |parameters|)) -; |body|) -; ((AND (PAIRP |x|) -; (EQ (QCAR |x|) -; '|mkCategory|)) -; |x|) -; ((AND (ATOM |x|) -; (BOOT-EQUAL -; (|getmode| |x| |e|) -; |$Category|)) -; |x|) -; ('T -; (|stackSemanticError| -; (CONS -; '|invalid argument to Join: | -; (CONS |x| NIL)) -; NIL) -; |x|)) -; G170396)))))))) -; (SPADLET T$ -; (CONS (|wrapDomainSub| |parameters| -; (CONS '|Join| |catList'|)) -; (CONS |$Category| (CONS |e| NIL)))) -; (|convert| T$ |m|)))))))) - (defun |compJoin| (arg m e) + (labels ( + (getParms (y e) + (cond + ((atom y) + (when (|isDomainForm| y e) (list y))) + ((and (pairp y) (eq (qcar y) 'length) + (pairp (qcdr y)) (eq (qcdr (qcdr y)) nil)) + (list y (second y))) + (t (list y)))) ) (let (argl catList pl tmp2 tmp3 tmp4 tmp5 body parameters catListp td) (declare (special |$Category|)) (setq argl (cdr arg)) @@ -3836,7 +3713,7 @@ An angry JHD - August 15th., 1984 (setq parameters (|union| (dolist (y (cdr x) tmp5) - (setq tmp5 (append tmp5 (|compJoin,getParms| y e)))) + (setq tmp5 (append tmp5 (getParms y e)))) parameters)) x) ((and (pairp x) (eq (qcar x) '|DomainSubstitutionMacro|) @@ -3855,7 +3732,7 @@ An angry JHD - August 15th., 1984 tmp4)))) (setq td (list (|wrapDomainSub| parameters (cons '|Join| catListp)) |$Category| e)) - (|convert| td m))))) + (|convert| td m)))))) @ @@ -3911,6 +3788,236 @@ An angry JHD - August 15th., 1984 @ +\defplist{leave}{compLeave} +<>= +(eval-when (eval load) + (setf (get '|leave| 'special) '|compLeave|)) + +@ + +\defun{compLeave}{compLeave} +\calls{compLeave}{comp} +\calls{compLeave}{modifyModeStack} +\usesdollar{compLeave}{exitModeStack} +\usesdollar{compLeave}{leaveLevelStack} +<>= +(defun |compLeave| (arg m e) + (let (level x index u) + (declare (special |$exitModeStack| |$leaveLevelStack|)) + (setq level (second arg)) + (setq x (third arg)) + (setq index + (- (1- (|#| |$exitModeStack|)) (elt |$leaveLevelStack| (1- level)))) + (when (setq u (|comp| x (elt |$exitModeStack| index) e)) + (|modifyModeStack| (second u) index) + (list (list '|TAGGEDexit| index u) m e )))) + +@ + +\defplist{mdef}{compMacro} +<>= +(eval-when (eval load) + (setf (get 'mdef 'special) '|compMacro|)) + +@ + +\defun{compMacro}{compMacro} +\calls{compMacro}{qcar} +\calls{compMacro}{formatUnabbreviated} +\calls{compMacro}{sayBrightly} +\calls{compMacro}{put} +\calls{compMacro}{macroExpand} +\usesdollar{compMacro}{macroIfTrue} +\usesdollar{compMacro}{NoValueMode} +\usesdollar{compMacro}{EmptyMode} +<>= +(defun |compMacro| (form m e) + (let (|$macroIfTrue| lhs signature specialCases rhs prhs) + (declare (special |$macroIfTrue| |$NoValueMode| |$EmptyMode|)) + (setq |$macroIfTrue| t) + (setq lhs (second form)) + (setq signature (third form)) + (setq specialCases (fourth form)) + (setq rhs (fifth form)) + (setq prhs + (cond + ((and (pairp rhs) (eq (qcar rhs) 'category)) + (list "-- the constructor category")) + ((and (pairp rhs) (eq (qcar rhs) '|Join|)) + (list "-- the constructor category")) + ((and (pairp rhs) (eq (qcar rhs) 'capsule)) + (list "-- the constructor capsule")) + ((and (pairp rhs) (eq (qcar rhs) '|add|)) + (list "-- the constructor capsule")) + (t (|formatUnabbreviated| rhs)))) + (|sayBrightly| + (cons " processing macro definition" + (cons '|%b| + (append (|formatUnabbreviated| lhs) + (cons " ==> " + (append prhs (list '|%d|))))))) + (when (or (equal m |$EmptyMode|) (equal m |$NoValueMode|)) + (list '|/throwAway| |$NoValueMode| + (|put| (CAR lhs) '|macro| (|macroExpand| rhs e) e))))) + +@ + +\defplist{pretend}{compPretend} +<>= +(eval-when (eval load) + (setf (get '|pretend| 'special) '|compPretend|)) + +@ + +\defun{compPretend}{compPretend} +\calls{compPretend}{addDomain} +\calls{compPretend}{comp} +\calls{compPretend}{opOf} +\calls{compPretend}{nequal} +\calls{compPretend}{stackSemanticError} +\calls{compPretend}{stackWarning} +\usesdollar{compPretend}{newCompilerUnionFlag} +\usesdollar{compPretend}{EmptyMode} +<>= +(defun |compPretend| (arg m e) + (let (x tt warningMessage td tp) + (declare (special |$newCompilerUnionFlag| |$EmptyMode|)) + (setq x (second arg)) + (setq tt (third arg)) + (setq e (|addDomain| tt e)) + (when (setq td (or (|comp| x tt e) (|comp| x |$EmptyMode| e))) + (when (equal (second td) tt) + (setq warningMessage (list '|pretend| tt '| -- should replace by @|))) + (cond + ((and |$newCompilerUnionFlag| + (eq (|opOf| (second td)) '|Union|) + (nequal (|opOf| m) '|Union|)) + (|stackSemanticError| + (list '|cannot pretend | x '| of mode | (second td) '| to mode | m) + nil)) + (t + (setq td (list (first td) tt (third td))) + (when (setq tp (|coerce| td m)) + (when warningMessage (|stackWarning| warningMessage)) + tp)))))) + +@ + +\defplist{quote}{compQuote} +<>= +(eval-when (eval load) + (setf (get 'quote 'special) '|compQuote|)) + +@ + +\defun{compQuote}{compQuote} +<>= +(defun |compQuote| (expr m e) + (list expr m e)) + +@ + +\defplist{reduce}{compReduce} +<>= +(eval-when (eval load) + (setf (get 'reduce 'special) '|compReduce|)) + +@ + +\defun{compReduce}{compReduce} +\calls{compReduce}{compReduce1} +\usesdollar{compReduce}{formalArgList} +<>= +(defun |compReduce| (form m e) + (declare (special |$formalArgList|)) + (|compReduce1| form m e |$formalArgList|)) + +@ + +\defun{compReduce1}{compReduce1} +\calls{compReduce1}{systemError} +\calls{compReduce1}{nreverse0} +\calls{compReduce1}{compIterator} +\calls{compReduce1}{comp} +\calls{compReduce1}{parseTran} +\calls{compReduce1}{getIdentity} +\calls{compReduce1}{msubst} +\usesdollar{compReduce1}{sideEffectsList} +\usesdollar{compReduce1}{until} +\usesdollar{compReduce1}{initList} +\usesdollar{compReduce1}{Boolean} +\usesdollar{compReduce1}{e} +\usesdollar{compReduce1}{endTestList} +<>= +(defun |compReduce1| (form m e |$formalArgList|) + (declare (special |$formalArgList|)) + (let (|$sideEffectsList| |$until| |$initList| |$endTestList| collectForm + collectOp body op itl acc afterFirst bodyVal part1 part2 part3 id + identityCode untilCode finalCode tmp1 tmp2) + (declare (special |$sideEffectsList| |$until| |$initList| |$Boolean| |$e| + |$endTestList|)) + (setq op (second form)) + (setq collectForm (fourth form)) + (setq collectOp (first collectForm)) + (setq tmp1 (reverse (cdr collectForm))) + (setq body (first tmp1)) + (setq itl (nreverse (cdr tmp1))) + (when (stringp op) (setq op (intern op))) + (cond + ((null (member collectOp '(collect collectv collectvec))) + (|systemError| (list '|illegal reduction form:| form))) + (t + (setq |$sideEffectsList| nil) + (setq |$until| nil) + (setq |$initList| nil) + (setq |$endTestList| nil) + (setq |$e| e) + (setq itl + (dolist (x itl (nreverse0 tmp2)) + (setq tmp1 (or (|compIterator| x |$e|) (return '|failed|))) + (setq |$e| (second tmp1)) + (push (elt tmp1 0) tmp2))) + (unless (eq itl '|failed|) + (setq e |$e|) + (setq acc (gensym)) + (setq afterFirst (gensym)) + (setq bodyVal (gensym)) + (when (setq tmp1 (|comp| (list 'let bodyVal body ) m e)) + (setq part1 (first tmp1)) + (setq m (second tmp1)) + (setq e (third tmp1)) + (when (setq tmp1 (|comp| (list 'let acc bodyVal) m e)) + (setq part2 (first tmp1)) + (setq e (third tmp1)) + (when (setq tmp1 + (|comp| (list 'let acc (|parseTran| (list op acc bodyVal))) m e)) + (setq part3 (first tmp1)) + (setq e (third tmp1)) + (when (setq identityCode + (if (setq id (|getIdentity| op e)) + (car (|comp| id m e)) + (list '|IdentityError| (mkq op)))) + (setq finalCode + (cons 'progn + (cons (list 'let afterFirst nil) + (cons + (cons 'repeat + (append itl + (list + (list 'progn part1 + (list 'if afterFirst part3 + (list 'progn part2 (list 'let afterFirst (mkq t)))) nil)))) + (list (list 'if afterFirst acc identityCode )))))) + (when |$until| + (setq tmp1 (|comp| |$until| |$Boolean| e)) + (setq untilCode (first tmp1)) + (setq e (third tmp1)) + (setq finalCode + (msubst (list 'until untilCode) '|$until| finalCode))) + (list finalCode m e )))))))))) + +@ + \defplist{seq}{compSeq} <>= (eval-when (eval load) @@ -11193,23 +11300,29 @@ if \verb|$InteractiveMode| then use a null outputstream <> <> <> -<> -<> -<> -<> <> <> <> <> <> <> +<> +<> +<> +<> +<> <> +<> <> <> <> <> <> <> +<> +<> +<> +<> <> <> <> diff --git a/changelog b/changelog index ae5d7f7..bfb4620 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,8 @@ +20101128 tpd src/axiom-website/patches.html 20101128.01.tpd.patch +20101128 tpd src/interp/postprop.lisp treeshake compiler +20101128 tpd src/interp/iterator.lisp treeshake compiler +20101128 tpd src/interp/compiler.lisp treeshake compiler +20101128 tpd books/bookvol9 treeshake compiler 20101127 tpd src/axiom-website/patches.html 20101127.02.tpd.patch 20101127 tpd src/interp/define.lisp treeshake compiler 20101127 tpd books/bookvol9 treeshake compiler diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index bf3c747..bff33f9 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3280,5 +3280,7 @@ books/bookvol9 treeshake compiler
books/bookvol4 add debugging technique
20101127.02.tpd.patch books/bookvol9 treeshake compiler
+20101128.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/compiler.lisp.pamphlet b/src/interp/compiler.lisp.pamphlet index b1f1ef2..5bab77d 100644 --- a/src/interp/compiler.lisp.pamphlet +++ b/src/interp/compiler.lisp.pamphlet @@ -1554,106 +1554,6 @@ Compile setelt NIL))))))))))))) @ -\subsection{compQuote} -Compile quote -<<*>>= -;compQuote(expr,m,e) == [expr,m,e] - -(DEFUN |compQuote| (|expr| |m| |e|) - (CONS |expr| (CONS |m| (CONS |e| NIL)))) - -@ - -\subsection{compMacro} -The compMacro function does macro expansion during spad file compiles. -If a macro occurs twice in the same file the macro expands infinitely -causing a stack overflow. The reason for the infinite recursion is that -the left hand side of the macro definition is expanded. Thus defining -a macro: -\begin{verbatim} -name ==> 1 -\end{verbatim} -will expand properly the first time. The second time it turns into: -\begin{verbatim} -1 ==> 1 -\end{verbatim} -The original code read: -\begin{verbatim} -compMacro(form,m,e) == - $macroIfTrue: local:= true - ["MDEF",lhs,signature,specialCases,rhs]:= form - rhs := - rhs is ['CATEGORY,:.] => ['"-- the constructor category"] - rhs is ['Join,:.] => ['"-- the constructor category"] - rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] - rhs is ['add,:.] => ['"-- the constructor capsule"] - formatUnabbreviated rhs - sayBrightly ['" processing macro definition",'%b, - :formatUnabbreviated lhs,'" ==> ",:rhs,'%d] - ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) - m=$EmptyMode or m=$NoValueMode => - ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] - -\end{verbatim} -Juergen Weiss proposed the following fixed code. This does not expand -the left hand side of the macro. -<<*>>= -;compMacro(form,m,e) == -; $macroIfTrue: local:= true -; ["MDEF",lhs,signature,specialCases,rhs]:= form -; prhs := -; rhs is ['CATEGORY,:.] => ['"-- the constructor category"] -; rhs is ['Join,:.] => ['"-- the constructor category"] -; rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] -; rhs is ['add,:.] => ['"-- the constructor capsule"] -; formatUnabbreviated rhs -; sayBrightly ['" processing macro definition",'%b, -; :formatUnabbreviated lhs,'" ==> ",:prhs,'%d] -; m=$EmptyMode or m=$NoValueMode => -; ["/throwAway",$NoValueMode,put(first lhs,"macro",macroExpand(rhs,e),e)] - -(DEFUN |compMacro| (|form| |m| |e|) - (PROG (|$macroIfTrue| |lhs| |signature| |specialCases| |rhs| |prhs|) - (DECLARE (SPECIAL |$macroIfTrue| |$NoValueMode| |$EmptyMode|)) - (RETURN - (PROGN - (SPADLET |$macroIfTrue| 'T) - (COND ((EQ (CAR |form|) 'MDEF) (CAR |form|))) - (SPADLET |lhs| (CADR |form|)) - (SPADLET |signature| (CADDR |form|)) - (SPADLET |specialCases| (CADDDR |form|)) - (SPADLET |rhs| (CAR (CDDDDR |form|))) - (SPADLET |prhs| - (COND - ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) 'CATEGORY)) - (CONS "-- the constructor category" - NIL)) - ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) '|Join|)) - (CONS "-- the constructor category" - NIL)) - ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) 'CAPSULE)) - (CONS "-- the constructor capsule" - NIL)) - ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) '|add|)) - (CONS "-- the constructor capsule" - NIL)) - ('T (|formatUnabbreviated| |rhs|)))) - (|sayBrightly| - (CONS " processing macro definition" - (CONS '|%b| - (APPEND (|formatUnabbreviated| |lhs|) - (CONS " ==> " - (APPEND |prhs| (CONS '|%d| NIL))))))) - (COND - ((OR (BOOT-EQUAL |m| |$EmptyMode|) - (BOOT-EQUAL |m| |$NoValueMode|)) - (CONS '|/throwAway| - (CONS |$NoValueMode| - (CONS (|put| (CAR |lhs|) '|macro| - (|macroExpand| |rhs| |e|) |e|) - NIL))))))))) - -@ \subsection{replaceExitEtc} <<*>>= ;replaceExitEtc(x,tag,opFlag,opMode) == @@ -1770,39 +1670,6 @@ Compile suchthat (CONS |x'| (CONS |m'| (CONS |e| NIL))))))) @ -\subsection{compLeave} -Compile leave -<<*>>= -;compLeave(["leave",level,x],m,e) == -; index:= #$exitModeStack-1-$leaveLevelStack.(level-1) -; [x',m',e']:= u:= comp(x,$exitModeStack.index,e) or return nil -; modifyModeStack(m',index) -; [["TAGGEDexit",index,u],m,e] - -(DEFUN |compLeave| (G169045 |m| |e|) - (PROG (|level| |x| |index| |u| |x'| |m'| |e'|) - (declare (special |$exitModeStack| |$leaveLevelStack|)) - (RETURN - (PROGN - (COND ((EQ (CAR G169045) '|leave|) (CAR G169045))) - (SPADLET |level| (CADR G169045)) - (SPADLET |x| (CADDR G169045)) - (SPADLET |index| - (SPADDIFFERENCE - (SPADDIFFERENCE (|#| |$exitModeStack|) 1) - (ELT |$leaveLevelStack| - (SPADDIFFERENCE |level| 1)))) - (SPADLET |u| - (OR (|comp| |x| (ELT |$exitModeStack| |index|) |e|) - (RETURN NIL))) - (SPADLET |x'| (CAR |u|)) - (SPADLET |m'| (CADR |u|)) - (SPADLET |e'| (CADDR |u|)) - (|modifyModeStack| |m'| |index|) - (CONS (CONS '|TAGGEDexit| (CONS |index| (CONS |u| NIL))) - (CONS |m| (CONS |e| NIL))))))) - -@ \subsection{compReturn} Compile return <<*>>= @@ -2521,58 +2388,6 @@ Compile return NIL))))) @ -\subsection{compPretend} -<<*>>= -;compPretend(["pretend",x,t],m,e) == -; e:= addDomain(t,e) -; T:= comp(x,t,e) or comp(x,$EmptyMode,e) or return nil -; if T.mode=t then warningMessage:= ["pretend",t," -- should replace by @"] -; $newCompilerUnionFlag and opOf(T.mode) = 'Union and opOf(m) ^= 'Union => -; stackSemanticError(["cannot pretend ",x," of mode ",T.mode," to mode ",m],nil) -; T:= [T.expr,t,T.env] -; T':= coerce(T,m) => (if warningMessage then stackWarning warningMessage; T') - -(DEFUN |compPretend| (G170169 |m| |e|) - (PROG (|x| |t| |warningMessage| T$ |T'|) - (declare (special |$newCompilerUnionFlag| |$EmptyMode|)) - (RETURN - (PROGN - (COND ((EQ (CAR G170169) '|pretend|) (CAR G170169))) - (SPADLET |x| (CADR G170169)) - (SPADLET |t| (CADDR G170169)) - (SPADLET |e| (|addDomain| |t| |e|)) - (SPADLET T$ - (OR (|comp| |x| |t| |e|) (|comp| |x| |$EmptyMode| |e|) - (RETURN NIL))) - (COND - ((BOOT-EQUAL (CADR T$) |t|) - (SPADLET |warningMessage| - (CONS '|pretend| - (CONS |t| - (CONS '| -- should replace by @| NIL)))))) - (COND - ((AND |$newCompilerUnionFlag| - (BOOT-EQUAL (|opOf| (CADR T$)) '|Union|) - (NEQUAL (|opOf| |m|) '|Union|)) - (|stackSemanticError| - (CONS '|cannot pretend | - (CONS |x| - (CONS '| of mode | - (CONS (CADR T$) - (CONS '| to mode | - (CONS |m| NIL)))))) - NIL)) - ('T - (SPADLET T$ - (CONS (CAR T$) (CONS |t| (CONS (CADDR T$) NIL)))) - (COND - ((SPADLET |T'| (|coerce| T$ |m|)) - (PROGN - (COND - (|warningMessage| (|stackWarning| |warningMessage|))) - |T'|))))))))) - -@ \section{Functions for coercion by the compiler} \subsection{coerce} The function coerce is used by the old compiler for coercions. diff --git a/src/interp/iterator.lisp.pamphlet b/src/interp/iterator.lisp.pamphlet index 6bd0ed7..ae3d6b7 100644 --- a/src/interp/iterator.lisp.pamphlet +++ b/src/interp/iterator.lisp.pamphlet @@ -12,189 +12,6 @@ <<*>>= (IN-PACKAGE "BOOT" ) -;--% ITERATORS -; -;compReduce(form,m,e) == -; compReduce1(form,m,e,$formalArgList) - -(DEFUN |compReduce| (|form| |m| |e|) - (declare (special |$formalArgList|)) - (|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| |$Boolean| |$e| - |$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 (member |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 diff --git a/src/interp/postprop.lisp.pamphlet b/src/interp/postprop.lisp.pamphlet index 6d9ea2c..105bdcc 100644 --- a/src/interp/postprop.lisp.pamphlet +++ b/src/interp/postprop.lisp.pamphlet @@ -74,13 +74,13 @@ ; (IF |compIf|) ; (|import| |compImport|) ; (|is| |compIs|) - (|Join| |compJoin|) +; (|Join| |compJoin|) ; (|+->| |compLambda|) - (|leave| |compLeave|) - (MDEF |compMacro|) - (|pretend| |compPretend|) - (QUOTE |compQuote|) - (REDUCE |compReduce|) +; (|leave| |compLeave|) +; (MDEF |compMacro|) +; (|pretend| |compPretend|) +; (QUOTE |compQuote|) +; (REDUCE |compReduce|) (COLLECT |compRepeatOrCollect|) (REPEAT |compRepeatOrCollect|) (|return| |compReturn|)