diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index f488f0d..9a3cf30 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -6097,6 +6097,108 @@ $\rightarrow$ \end{chunk} +\defun{getTargetFromRhs}{getTargetFromRhs} +\calls{getTargetFromRhs}{stackSemanticError} +\calls{getTargetFromRhs}{getTargetFromRhs} +\calls{getTargetFromRhs}{compOrCroak} +\begin{chunk}{defun getTargetFromRhs} +(defun |getTargetFromRhs| (lhs rhs env) + (declare (special |$EmptyMode|)) + (cond + ((and (pairp rhs) (eq (qcar rhs) 'capsule)) + (|stackSemanticError| + (list "target category of " lhs + " cannot be determined from definition") + nil)) + ((and (pairp rhs) (eq (qcar rhs) '|SubDomain|) (pairp (qcdr rhs))) + (|getTargetFromRhs| lhs (second rhs) env)) + ((and (pairp rhs) (eq (qcar rhs) '|add|) + (pairp (qcdr rhs)) (pairp (qcdr (qcdr rhs))) + (eq (qcdr (qcdr (qcdr rhs))) nil) + (pairp (qcar (qcdr (qcdr rhs)))) + (eq (qcar (qcar (qcdr (qcdr rhs)))) 'capsule)) + (|getTargetFromRhs| lhs (second rhs) env)) + ((and (pairp rhs) (eq (qcar rhs) '|Record|)) + (cons '|RecordCategory| (rest rhs))) + ((and (pairp rhs) (eq (qcar rhs) '|Union|)) + (cons '|UnionCategory| (rest rhs))) + ((and (pairp rhs) (eq (qcar rhs) '|List|)) + (cons '|ListCategory| (rest rhs))) + ((and (pairp rhs) (eq (qcar rhs) '|Vector|)) + (cons '|VectorCategory| (rest rhs))) + (t + (second (|compOrCroak| rhs |$EmptyMode| env))))) + +\end{chunk} + +\defun{giveFormalParametersValues}{giveFormalParametersValues} +\calls{giveFormalParametersValues}{put} +\calls{giveFormalParametersValues}{get} +\begin{chunk}{defun giveFormalParametersValues} +(defun |giveFormalParametersValues| (argl env) + (dolist (x argl) + (setq env + (|put| x '|value| + (list (|genSomeVariable|) (|get| x '|mode| env) nil) env))) + env) + +\end{chunk} + +\defun{macroExpandInPlace}{macroExpandInPlace} +\calls{macroExpandInPlace}{macroExpand} +\begin{chunk}{defun macroExpandInPlace} +(defun |macroExpandInPlace| (form env) + (let (y) + (setq y (|macroExpand| form env)) + (if (or (atom form) (atom y)) + y + (progn + (rplaca form (car y)) + (rplacd form (cdr y)) + form + )))) + +\end{chunk} + +\defun{macroExpand}{macroExpand} +\calls{macroExpand}{macroExpand} +\calls{macroExpand}{macroExpandList} +\begin{chunk}{defun macroExpand} +(defun |macroExpand| (form env) + (let (u) + (cond + ((atom form) + (if (setq u (|get| form '|macro| env)) + (|macroExpand| u env) + form)) + ((and (pairp form) (eq (qcar form) 'def) + (pairp (qcdr form)) + (pairp (qcdr (qcdr form))) + (pairp (qcdr (qcdr (qcdr form)))) + (pairp (qcdr (qcdr (qcdr (qcdr form))))) + (eq (qcdr (qcdr (qcdr (qcdr (qcdr form))))) nil)) + (list 'def (|macroExpand| (second form) env) + (|macroExpandList| (third form) env) + (|macroExpandList| (fourth form) env) + (|macroExpand| (fifth form) env))) + (t (|macroExpandList| form env))))) + +\end{chunk} + +\defun{macroExpandList}{macroExpandList} +\calls{macroExpandList}{macroExpand} +\calls{macroExpandList}{getdatabase} +\begin{chunk}{defun macroExpandList} +(defun |macroExpandList| (lst env) + (let (tmp) + (if (and (pairp lst) (eq (qcdr lst) nil) + (identp (qcar lst)) (getdatabase (qcar lst) 'niladic) + (setq tmp (|get| (qcar lst) '|macro| env))) + (|macroExpand| tmp env) + (loop for x in lst collect (|macroExpand| x env))))) + +\end{chunk} + \section{Indirect called comp routines} In the {\bf compExpression} function there is the code: \begin{verbatim} @@ -15319,8 +15421,10 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun get-a-line} \getchunk{defun getScriptName} +\getchunk{defun getTargetFromRhs} \getchunk{defun get-token} \getchunk{defun getToken} +\getchunk{defun giveFormalParametersValues} \getchunk{defun hackforis} \getchunk{defun hackforis1} @@ -15347,7 +15451,9 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun line-print} \getchunk{defun line-new-line} -\getchunk{defun postMakeCons} +\getchunk{defun macroExpand} +\getchunk{defun macroExpandInPlace} +\getchunk{defun macroExpandList} \getchunk{defun makeSimplePredicateOrNil} \getchunk{defun make-string-adjustable} \getchunk{defun make-symbol-of} @@ -15527,6 +15633,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun postInSeq} \getchunk{defun postIteratorList} \getchunk{defun postJoin} +\getchunk{defun postMakeCons} \getchunk{defun postMapping} \getchunk{defun postMDef} \getchunk{defun postOp} diff --git a/changelog b/changelog index c9833aa..830251b 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20110516 tpd src/axiom-website/patches.html 20110516.01.tpd.patch +20110516 tpd src/interp/define.lisp treeshake compiler +20110516 tpd books/bookvol9 treeshake compiler 20110515 tpd src/axiom-website/patches.html 20110515.01.tpd.patch 20110515 tpd src/interp/define.lisp treeshake compiler 20110515 tpd books/bookvol9 treeshake compiler diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 8c41447..b85195a 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3476,5 +3476,7 @@ books/bookvol* set textlength 400
books/bookvol9 normalize argument names to top level functions
20110515.01.tpd.patch books/bookvol9 treeshake compiler
+20110516.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/define.lisp.pamphlet b/src/interp/define.lisp.pamphlet index 433445f..d1537eb 100644 --- a/src/interp/define.lisp.pamphlet +++ b/src/interp/define.lisp.pamphlet @@ -15,175 +15,6 @@ ;--% FUNCTIONS WHICH MUNCH ON == STATEMENTS ; -;getTargetFromRhs(lhs,rhs,e) == -; --undeclared target mode obtained from rhs expression -; rhs is ['CAPSULE,:.] => -; stackSemanticError(['"target category of ",lhs, -; '" cannot be determined from definition"],nil) -; rhs is ['SubDomain,D,:.] => getTargetFromRhs(lhs,D,e) -; rhs is ['add,D,['CAPSULE,:.]] => getTargetFromRhs(lhs,D,e) -; rhs is ['Record,:l] => ['RecordCategory,:l] -; rhs is ['Union,:l] => ['UnionCategory,:l] -; rhs is ['List,:l] => ['ListCategory,:l] -; rhs is ['Vector,:l] => ['VectorCategory,:l] -; [.,target,.]:= compOrCroak(rhs,$EmptyMode,e) -; target - -(DEFUN |getTargetFromRhs| (|lhs| |rhs| |e|) - (PROG (|ISTMP#1| D |ISTMP#2| |ISTMP#3| |l| |LETTMP#1| |target|) - (declare (special |$EmptyMode|)) - (RETURN - (COND - ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) 'CAPSULE)) - (|stackSemanticError| - (CONS "target category of " - (CONS |lhs| - (CONS " cannot be determined from definition" - NIL))) - NIL)) - ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) '|SubDomain|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |rhs|)) - (AND (PAIRP |ISTMP#1|) - (PROGN (SPADLET D (QCAR |ISTMP#1|)) 'T)))) - (|getTargetFromRhs| |lhs| D |e|)) - ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) '|add|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |rhs|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET D (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCAR |ISTMP#3|) 'CAPSULE)))))))) - (|getTargetFromRhs| |lhs| D |e|)) - ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) '|Record|) - (PROGN (SPADLET |l| (QCDR |rhs|)) 'T)) - (CONS '|RecordCategory| |l|)) - ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) '|Union|) - (PROGN (SPADLET |l| (QCDR |rhs|)) 'T)) - (CONS '|UnionCategory| |l|)) - ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) '|List|) - (PROGN (SPADLET |l| (QCDR |rhs|)) 'T)) - (CONS '|ListCategory| |l|)) - ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) '|Vector|) - (PROGN (SPADLET |l| (QCDR |rhs|)) 'T)) - (CONS '|VectorCategory| |l|)) - ('T (SPADLET |LETTMP#1| (|compOrCroak| |rhs| |$EmptyMode| |e|)) - (SPADLET |target| (CADR |LETTMP#1|)) |target|))))) - -;giveFormalParametersValues(argl,e) == -; for x in argl repeat -; e:= put(x,'value,[genSomeVariable(),get(x,'mode,e),nil],e) -; e - -(DEFUN |giveFormalParametersValues| (|argl| |e|) - (SEQ (PROGN - (DO ((G166259 |argl| (CDR G166259)) (|x| NIL)) - ((OR (ATOM G166259) - (PROGN (SETQ |x| (CAR G166259)) NIL)) - NIL) - (SEQ (EXIT (SPADLET |e| - (|put| |x| '|value| - (CONS (|genSomeVariable|) - (CONS (|get| |x| '|mode| |e|) - (CONS NIL NIL))) - |e|))))) - |e|))) - -;macroExpandInPlace(x,e) == -; y:= macroExpand(x,e) -; atom x or atom y => y -; RPLACA(x,first y) -; RPLACD(x,rest y) -; x - -(DEFUN |macroExpandInPlace| (|x| |e|) - (PROG (|y|) - (RETURN - (PROGN - (SPADLET |y| (|macroExpand| |x| |e|)) - (COND - ((OR (ATOM |x|) (ATOM |y|)) |y|) - ('T (RPLACA |x| (CAR |y|)) (RPLACD |x| (CDR |y|)) |x|)))))) - -;macroExpand(x,e) == --not worked out yet -; atom x => (u:= get(x,'macro,e) => macroExpand(u,e); x) -; x is ['DEF,lhs,sig,spCases,rhs] => -; ['DEF,macroExpand(lhs,e),macroExpandList(sig,e),macroExpandList(spCases,e), -; macroExpand(rhs,e)] -; macroExpandList(x,e) - -(DEFUN |macroExpand| (|x| |e|) - (PROG (|u| |ISTMP#1| |lhs| |ISTMP#2| |sig| |ISTMP#3| |spCases| - |ISTMP#4| |rhs|) - (RETURN - (COND - ((ATOM |x|) - (COND - ((SPADLET |u| (|get| |x| '|macro| |e|)) - (|macroExpand| |u| |e|)) - ('T |x|))) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'DEF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |lhs| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |sig| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |spCases| - (QCAR |ISTMP#3|)) - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (EQ (QCDR |ISTMP#4|) NIL) - (PROGN - (SPADLET |rhs| - (QCAR |ISTMP#4|)) - 'T)))))))))) - (CONS 'DEF - (CONS (|macroExpand| |lhs| |e|) - (CONS (|macroExpandList| |sig| |e|) - (CONS (|macroExpandList| |spCases| |e|) - (CONS (|macroExpand| |rhs| |e|) NIL)))))) - ('T (|macroExpandList| |x| |e|)))))) - -;macroExpandList(l,e) == -; -- macros should override niladic props -; (l is [name]) and IDENTP name and GETDATABASE(name, 'NILADIC) and -; (u := get(name, 'macro, e)) => macroExpand(u,e) -; [macroExpand(x,e) for x in l] - -(DEFUN |macroExpandList| (|l| |e|) - (PROG (|name| |u|) - (RETURN - (SEQ (COND - ((AND (PAIRP |l|) (EQ (QCDR |l|) NIL) - (PROGN (SPADLET |name| (QCAR |l|)) 'T) - (IDENTP |name|) (GETDATABASE |name| 'NILADIC) - (SPADLET |u| (|get| |name| '|macro| |e|))) - (|macroExpand| |u| |e|)) - ('T - (PROG (G166351) - (SPADLET G166351 NIL) - (RETURN - (DO ((G166356 |l| (CDR G166356)) (|x| NIL)) - ((OR (ATOM G166356) - (PROGN (SETQ |x| (CAR G166356)) NIL)) - (NREVERSE0 G166351)) - (SEQ (EXIT (SETQ G166351 - (CONS (|macroExpand| |x| |e|) - G166351))))))))))))) - ;compDefineCategory1(df is ['DEF,form,sig,sc,body],m,e,prefix,fal) == ; categoryCapsule := ;--+