diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index 28dd3f0..c3802fa 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -1258,7 +1258,9 @@ leave it alone." (setq slines (drop (1- i) slines)) (rplaca slines (addclose (car slines) #\) ))))))) -@\defun{preparseReadLine}{preparseReadLine} +@ + +\defun{preparseReadLine}{preparseReadLine} \calls{preparseReadLine}{dcq} \calls{preparseReadLine}{preparseReadLine1} \calls{preparseReadLine}{initial-substring} @@ -2823,7 +2825,7 @@ An angry JHD - August 15th., 1984 \usesdollar{compCase1}{EmptyMode} <>= (defun |compCase1| (x m e) - (let (xp mp ep map tmp3 tmp5 tmp6 u fn onepair) + (let (xp mp ep map tmp3 tmp5 tmp6 u fn) (declare (special |$Boolean| |$EmptyMode|)) (when (setq tmp3 (|comp| x |$EmptyMode| e)) (setq xp (first tmp3)) @@ -2908,7 +2910,7 @@ An angry JHD - August 15th., 1984 \calls{compCategory}{systemErrorHere} <>= (defun |compCategory| (x m e) - (let ($top_level |$sigList| |$atList| tmp1 domainOrPackage z rep) + (let ($top_level |$sigList| |$atList| domainOrPackage z rep) (declare (special $top_level |$sigList| |$atList|)) (setq $top_level t) (cond @@ -2961,7 +2963,7 @@ An angry JHD - August 15th., 1984 (setq z (qcdr (qcar (qcdr tmp1)))) (when (setq td - (dolist (z m1 tmp4) (setq tmp4 (or tmp4 (|compCoerce1| x m1 e))))) + (dolist (m1 z tmp4) (setq tmp4 (or tmp4 (|compCoerce1| x m1 e))))) (|coerce| (list (car td) mp (third td)) m)))))) @ @@ -3203,7 +3205,7 @@ An angry JHD - August 15th., 1984 \usesdollar{compCons1}{EmptyMode} <>= (defun |compCons1| (arg m e) - (let (mx y my yt mp mr ytp tmp1 x tmp2 td) + (let (mx y my yt mp mr ytp tmp1 x td) (declare (special |$EmptyMode|)) (setq x (second arg)) (setq y (third arg)) @@ -3455,7 +3457,7 @@ An angry JHD - August 15th., 1984 \usesdollar{compElt}{Zero} <>= (defun |compElt| (form m e) - (let (tmp1 aDomain tmp2 anOp mmList n modemap sig pred val) + (let (aDomain anOp mmList n modemap sig pred val) (declare (special |$One| |$Zero|)) (setq anOp (third form)) (setq aDomain (second form)) @@ -3622,9 +3624,9 @@ An angry JHD - August 15th., 1984 <>= (defun |compImport| (arg m e) (declare (ignore m)) - (declare (special |$NoValueMode|)) - (dolist (dom (cdr arg)) (setq e (|addDomain| dom e))) - (list '|/throwAway| |$NoValueMode| e)) + (declare (special |$NoValueMode|)) + (dolist (dom (cdr arg)) (setq e (|addDomain| dom e))) + (list '|/throwAway| |$NoValueMode| e)) @ @@ -3659,6 +3661,204 @@ An angry JHD - August 15th., 1984 @ +\defplist{Join}{compJoin} +<>= +(eval-when (eval load) + (setf (get '|Join| 'special) '|compJoin|)) + +@ + +\defun{compJoin}{compJoin} +\calls{compJoin}{nreverse0} +\calls{compJoin}{compForMode} +\calls{compJoin}{stackSemanticError} +\calls{compJoin}{nreverse0} +\calls{compJoin}{isCategoryForm} +\calls{compJoin}{union} +\calls{compJoin}{compJoin,getParms} +\calls{compJoin}{pairp} +\calls{compJoin}{qcar} +\calls{compJoin}{qcdr} +\calls{compJoin}{wrapDomainSub} +\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) + (let (argl catList pl tmp2 tmp3 tmp4 tmp5 body parameters catListp td) + (declare (special |$Category|)) + (setq argl (cdr arg)) + (setq catList + (dolist (x argl (nreverse0 tmp3)) + (push (car (or (|compForMode| x |$Category| e) (return '|failed|))) + tmp3))) + (cond + ((eq catList '|failed|) + (|stackSemanticError| (list '|cannot form Join of: | argl) nil)) + (t + (setq catListp + (dolist (x catList (nreverse0 tmp4)) + (setq tmp4 + (cons + (cond + ((|isCategoryForm| x e) + (setq parameters + (|union| + (dolist (y (cdr x) tmp5) + (setq tmp5 (append tmp5 (|compJoin,getParms| y e)))) + parameters)) + x) + ((and (pairp x) (eq (qcar x) '|DomainSubstitutionMacro|) + (pairp (qcdr x)) (pairp (qcdr (qcdr x))) + (eq (qcdr (qcdr (qcdr x))) nil)) + (setq pl (second x)) + (setq body (third x)) + (setq parameters (|union| pl parameters)) body) + ((and (pairp x) (eq (qcar x) '|mkCategory|)) + x) + ((and (atom x) (equal (|getmode| x e) |$Category|)) + x) + (t + (|stackSemanticError| (list '|invalid argument to Join: | x) nil) + x)) + tmp4)))) + (setq td (list (|wrapDomainSub| parameters (cons '|Join| catListp)) + |$Category| e)) + (|convert| td m))))) + +@ + \defplist{+->}{compLambda} <>= (eval-when (eval load) @@ -6060,6 +6260,8 @@ It is pretty much just a translation of DEF-IS-REV (arglp (def-stringtoquote argl))) (comp (sublis $opassoc `((,$op (lam ,arglp ,$body)))))))) +@ + \defun{hackforis}{hackforis} \calls{hackforis}{hackforis1} <>= @@ -10993,6 +11195,7 @@ if \verb|$InteractiveMode| then use a null outputstream <> <> <> +<> <> <> <> diff --git a/changelog b/changelog index 5f5033c..ae5d7f7 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +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 20101127 tpd src/axiom-website/patches.html 20101127.01.tpd.patch 20101127 tpd books/bookvol4 add debugging technique 20101126 tpd src/axiom-website/patches.html 20101126.01.tpd.patch diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 3708f26..bf3c747 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3278,5 +3278,7 @@ books/bookvol9 treeshake compiler
books/bookvol9 treeshake compiler
20101127.01.tpd.patch books/bookvol4 add debugging technique
+20101127.02.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/define.lisp.pamphlet b/src/interp/define.lisp.pamphlet index d8f72a0..d077ed5 100644 --- a/src/interp/define.lisp.pamphlet +++ b/src/interp/define.lisp.pamphlet @@ -5572,163 +5572,6 @@ Since we can't be sure we take the least disruptive course of action. (|convert| T$ |m|)) ('T NIL)))))) -;compJoin(["Join",:argl],m,e) == -; catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl] -; catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil) -; catList':= -; [extract for x in catList] where -; extract() == -; isCategoryForm(x,e) => -; parameters:= -; UNION("append"/[getParms(y,e) for y in rest x],parameters) -; where getParms(y,e) == -; atom y => -; isDomainForm(y,e) => LIST y -; nil -; y is ['LENGTH,y'] => [y,y'] -; LIST y -; x -; x is ["DomainSubstitutionMacro",pl,body] => -; (parameters:= UNION(pl,parameters); body) -; x is ["mkCategory",:.] => x -; atom x and getmode(x,e)=$Category => x -; stackSemanticError(["invalid argument to Join: ",x],nil) -; x -; T:= [wrapDomainSub(parameters,["Join",:catList']),$Category,e] -; convert(T,m) - -(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|)))))))) - ;compForMode(x,m,e) == ; $compForModeIfTrue: local:= true ; comp(x,m,e)