diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index a6cf930..03e9c5c 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -1351,6 +1351,181 @@ preferred to the underlying representation -- RDJ 9/12/83 @ +\defun{compColon}{compColon} +\begin{verbatim} +;compColon([":",f,t],m,e) == +; $insideExpressionIfTrue=true => compColonInside(f,m,e,t) +; --if inside an expression, ":" means to convert to m "on faith" +; $lhsOfColon: local:= f +; t:= +; atom t and (t':= ASSOC(t,getDomainsInScope e)) => t' +; isDomainForm(t,e) and not $insideCategoryIfTrue => +; (if not MEMBER(t,getDomainsInScope e) then e:= addDomain(t,e); t) +; isDomainForm(t,e) or isCategoryForm(t,e) => t +; t is ["Mapping",m',:r] => t +; unknownTypeError t +; t +; 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",:.]) => +; --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]] +; put(op,"mode",signature,e) +; put(f,"mode",t,e) +; if not $bootStrapMode and $insideFunctorIfTrue and +; makeCategoryForm(t,e) is [catform,e] then +; e:= put(f,"value",[genSomeVariable(),t,$noEnv],e) +; ["/throwAway",getmode(f,e),e] +\end{verbatim} +\calls{compColon}{compColonInside} +\calls{compColon}{assoc} +\calls{compColon}{getDomainsInScope} +\calls{compColon}{isDomainForm} +\calls{compColon}{member} +\calls{compColon}{addDomain} +\calls{compColon}{isDomainForm} +\calls{compColon}{isCategoryForm} +\calls{compColon}{unknownTypeError} +\calls{compColon}{compColon} +\calls{compColon}{eqsubstlist} +\calls{compColon}{take} +\calls{compColon}{length} +\calls{compColon}{nreverse0} +\calls{compColon}{getmode} +\calls{compColon}{systemErrorHere} +\calls{compColon}{put} +\calls{compColon}{makeCategoryForm} +\calls{compColon}{genSomeVariable} +\usesdollar{compColon}{lhsOfColon} +\usesdollar{compColon}{noEnv} +\usesdollar{compColon}{insideFunctorIfTrue} +\usesdollar{compColon}{bootStrapMode} +\usesdollar{compColon}{FormalMapVariableList} +\usesdollar{compColon}{insideCategoryIfTrue} +\usesdollar{compColon}{insideExpressionIfTrue} +<>= +(defun |compColon| (arg0 m e) + (let (|$lhsOfColon| argf argt tprime mprime r l tmp1 td op argl newTarget a + signature tmp2 catform tmp3 g2 g5) + (declare (special |$lhsOfColon| |$noEnv| |$insideFunctorIfTrue| + |$bootStrapMode| |$FormalMapVariableList| + |$insideCategoryIfTrue| |$insideExpressionIfTrue|)) + (setq argf (cadr arg0)) + (setq argt (caddr arg0)) + (if |$insideExpressionIfTrue| + (|compColonInside| argf m e argt) + (progn + (setq |$lhsOfColon| argf) + (setq argt + (cond + ((and (atom argt) + (setq tprime (|assoc| argt (|getDomainsInScope| e)))) + tprime) + ((and (|isDomainForm| argt e) (null |$insideCategoryIfTrue|)) + (unless (|member| argt (|getDomainsInScope| e)) + (setq e (|addDomain| argt e))) + argt) + ((or (|isDomainForm| argt e) (|isCategoryForm| argt e)) + argt) + ((and (pairp argt) (eq (qcar argt) '|Mapping|) + (progn + (setq tmp2 (qcdr argt)) + (and (pairp tmp2) + (progn + (setq mprime (qcar tmp2)) + (setq r (qcdr tmp2)) + t)))) + argt) + (t + (|unknownTypeError| argt) + argt))) + (cond + ((eq (car argf) 'listof) + (dolist (x (cdr argf) td) + (setq td (|compColon| (list '|:| x argt) m e)) + (setq e (caddr td)))) + (t + (setq e + (cond + ((and (pairp argf) + (progn + (setq op (qcar argf)) + (setq argl (qcdr argf)) + t) + (null (and (pairp argt) (eq (qcar argt) '|Mapping|)))) + (setq newTarget + (eqsubstlist (take (|#| argl) |$FormalMapVariableList|) + (dolist (x argl (nreverse0 g2)) + (setq g2 + (cons + (cond + ((and (pairp x) (eq (qcar x) '|:|) + (progn + (setq tmp2 (qcdr x)) + (and (pairp tmp2) + (progn + (setq a (qcar tmp2)) + (setq tmp3 (qcdr tmp2)) + (and (pairp tmp3) + (eq (qcdr tmp3) nil) + (progn + (setq m (qcar tmp3)) + t)))))) + a) + (t x)) + g2))) + argt)) + (setq signature + (cons '|Mapping| + (cons newTarget + (dolist (x argl (nreverse0 g5)) + (setq g5 + (cons + (cond + ((and (pairp x) (eq (qcar x) '|:|) + (progn + (setq tmp2 (qcdr x)) + (and (pairp tmp2) + (progn + (setq a (qcar tmp2)) + (setq tmp3 (qcdr tmp2)) + (and (pairp tmp3) + (eq (qcdr tmp3) nil) + (progn + (setq m (qcar tmp3)) + t)))))) + m) + (t + (or (|getmode| x e) + (|systemErrorHere| "compColonOld")))) + g5)))))) + (|put| op '|mode| signature e)) + (t (|put| argf '|mode| argt e)))) + (cond + ((and (null |$bootStrapMode|) |$insideFunctorIfTrue| + (progn + (setq tmp2 (|makeCategoryForm| argt e)) + (and (pairp tmp2) + (progn + (setq catform (qcar tmp2)) + (setq tmp3 (qcdr tmp2)) + (and (pairp tmp3) + (eq (qcdr tmp3) nil) + (progn + (setq e (qcar tmp3)) + t)))))) + (setq e + (|put| argf '|value| (list (|genSomeVariable|) argt |$noEnv|) + e)))) + (list '|/throwAway| (|getmode| argf e) e ))))))) + +@ \defun{compAtom}{compAtom} \begin{verbatim} ;compAtom(x,m,e) == @@ -2211,6 +2386,7 @@ if \verb|$InteractiveMode| then use a null outputstream <> <> <> +<> <> <> <> diff --git a/changelog b/changelog index cf4f2b3..4bf14ce 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20100910 tpd src/axiom-website/patches.html 20100910.01.tpd.patch +20100910 tpd src/interp/compiler.lisp treeshake compiler +20100910 tpd books/bookvol9 treeshake compiler 20100906 tpd src/axiom-website/patches.html 20100906.01.tpd.patch 20100906 tpd src/interp/compiler.lisp treeshake compiler 20100906 tpd books/bookvol9 treeshake compiler diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index be06631..a5eac0d 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3111,5 +3111,7 @@ books/bookvol5 mark pure common lisp routines
books/bookvol9 treeshake compiler
20100906.01.tpd.patch books/bookvol9 treeshake compiler
+20100910.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/compiler.lisp.pamphlet b/src/interp/compiler.lisp.pamphlet index 0c5f0db..fb72e44 100644 --- a/src/interp/compiler.lisp.pamphlet +++ b/src/interp/compiler.lisp.pamphlet @@ -3958,256 +3958,6 @@ An angry JHD - August 15th., 1984 (CONS |$Boolean| (CONS |e'| NIL)))))))) @ -\subsection{compColon} -<<*>>= -;compColon([":",f,t],m,e) == -; $insideExpressionIfTrue=true => compColonInside(f,m,e,t) -; --if inside an expression, ":" means to convert to m "on faith" -; $lhsOfColon: local:= f -; t:= -; atom t and (t':= ASSOC(t,getDomainsInScope e)) => t' -; isDomainForm(t,e) and not $insideCategoryIfTrue => -; (if not MEMBER(t,getDomainsInScope e) then e:= addDomain(t,e); t) -; isDomainForm(t,e) or isCategoryForm(t,e) => t -; t is ["Mapping",m',:r] => t -; unknownTypeError t -; t -; 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",:.]) => -; --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]] -; put(op,"mode",signature,e) -; put(f,"mode",t,e) -; if not $bootStrapMode and $insideFunctorIfTrue and -; makeCategoryForm(t,e) is [catform,e] then -; e:= put(f,"value",[genSomeVariable(),t,$noEnv],e) -; ["/throwAway",getmode(f,e),e] - -(DEFUN |compColon| (G170007 |m| |e|) - (PROG (|$lhsOfColon| |f| |t'| |m'| |r| |t| |l| |LETTMP#1| T$ |op| - |argl| |newTarget| |a| |signature| |ISTMP#1| |catform| |ISTMP#2|) - (DECLARE (SPECIAL |$lhsOfColon| |$noEnv| |$insideFunctorIfTrue| - |$bootStrapMode| |$FormalMapVariableList| - |$insideCategoryIfTrue| |$insideExpressionIfTrue|)) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR G170007) '|:|) (CAR G170007))) - (SPADLET |f| (CADR G170007)) - (SPADLET |t| (CADDR G170007)) - (COND - ((BOOT-EQUAL |$insideExpressionIfTrue| 'T) - (|compColonInside| |f| |m| |e| |t|)) - ('T (SPADLET |$lhsOfColon| |f|) - (SPADLET |t| - (COND - ((AND (ATOM |t|) - (SPADLET |t'| - (|assoc| |t| - (|getDomainsInScope| |e|)))) - |t'|) - ((AND (|isDomainForm| |t| |e|) - (NULL |$insideCategoryIfTrue|)) - (COND - ((NULL (|member| |t| - (|getDomainsInScope| |e|))) - (SPADLET |e| (|addDomain| |t| |e|)))) - |t|) - ((OR (|isDomainForm| |t| |e|) - (|isCategoryForm| |t| |e|)) - |t|) - ((AND (PAIRP |t|) (EQ (QCAR |t|) '|Mapping|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |t|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |m'| (QCAR |ISTMP#1|)) - (SPADLET |r| (QCDR |ISTMP#1|)) - 'T)))) - |t|) - ('T (|unknownTypeError| |t|) |t|))) - (COND - ((AND (PAIRP |f|) (EQ (QCAR |f|) 'LISTOF) - (PROGN (SPADLET |l| (QCDR |f|)) 'T)) - (DO ((G170058 |l| (CDR G170058)) (|x| NIL)) - ((OR (ATOM G170058) - (PROGN (SETQ |x| (CAR G170058)) NIL)) - NIL) - (SEQ (EXIT (SPADLET T$ - (PROGN - (SPADLET |LETTMP#1| - (|compColon| - (CONS '|:| - (CONS |x| (CONS |t| NIL))) - |m| |e|)) - (SPADLET |e| - (CADDR |LETTMP#1|)) - |LETTMP#1|))))) - T$) - ('T - (SPADLET |e| - (COND - ((AND (PAIRP |f|) - (PROGN - (SPADLET |op| (QCAR |f|)) - (SPADLET |argl| (QCDR |f|)) - 'T) - (NULL - (AND (PAIRP |t|) - (EQ (QCAR |t|) '|Mapping|)))) - (SPADLET |newTarget| - (EQSUBSTLIST - (TAKE (|#| |argl|) - |$FormalMapVariableList|) - (PROG (G170075) - (SPADLET G170075 NIL) - (RETURN - (DO - ((G170087 |argl| - (CDR G170087)) - (|x| NIL)) - ((OR (ATOM G170087) - (PROGN - (SETQ |x| - (CAR G170087)) - NIL)) - (NREVERSE0 G170075)) - (SEQ - (EXIT - (SETQ G170075 - (CONS - (COND - ((AND (PAIRP |x|) - (EQ (QCAR |x|) - '|:|) - (PROGN - (SPADLET - |ISTMP#1| - (QCDR |x|)) - (AND - (PAIRP - |ISTMP#1|) - (PROGN - (SPADLET - |a| - (QCAR - |ISTMP#1|)) - (SPADLET - |ISTMP#2| - (QCDR - |ISTMP#1|)) - (AND - (PAIRP - |ISTMP#2|) - (EQ - (QCDR - |ISTMP#2|) - NIL) - (PROGN - (SPADLET - |m| - (QCAR - |ISTMP#2|)) - 'T)))))) - |a|) - ('T |x|)) - G170075))))))) - |t|)) - (SPADLET |signature| - (CONS '|Mapping| - (CONS |newTarget| - (PROG (G170104) - (SPADLET G170104 NIL) - (RETURN - (DO - ((G170116 |argl| - (CDR G170116)) - (|x| NIL)) - ((OR (ATOM G170116) - (PROGN - (SETQ |x| - (CAR G170116)) - NIL)) - (NREVERSE0 G170104)) - (SEQ - (EXIT - (SETQ G170104 - (CONS - (COND - ((AND (PAIRP |x|) - (EQ (QCAR |x|) - '|:|) - (PROGN - (SPADLET - |ISTMP#1| - (QCDR |x|)) - (AND - (PAIRP - |ISTMP#1|) - (PROGN - (SPADLET - |a| - (QCAR - |ISTMP#1|)) - (SPADLET - |ISTMP#2| - (QCDR - |ISTMP#1|)) - (AND - (PAIRP - |ISTMP#2|) - (EQ - (QCDR - |ISTMP#2|) - NIL) - (PROGN - (SPADLET - |m| - (QCAR - |ISTMP#2|)) - 'T)))))) - |m|) - ('T - (OR - (|getmode| |x| - |e|) - (|systemErrorHere| - "compColonOld")))) - G170104)))))))))) - (|put| |op| '|mode| |signature| |e|)) - ('T (|put| |f| '|mode| |t| |e|)))) - (COND - ((AND (NULL |$bootStrapMode|) - |$insideFunctorIfTrue| - (PROGN - (SPADLET |ISTMP#1| - (|makeCategoryForm| |t| |e|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |catform| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |e| (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |e| - (|put| |f| '|value| - (CONS (|genSomeVariable|) - (CONS |t| (CONS |$noEnv| NIL))) - |e|)))) - (CONS '|/throwAway| - (CONS (|getmode| |f| |e|) (CONS |e| NIL)))))))))))) - -@ \subsection{unknownTypeError} <<*>>= ;unknownTypeError name ==