diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index 8bb8134..f2affc9 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -2057,7 +2057,7 @@ nothing (see boot2Lisp) yet still allow function call (lisp2BootAndComp). \calls{defLET1}{identp} \calls{defLET1}{defLetForm} \calls{defLET1}{contained} -\calls{defLET1}{defLet2} +\calls{defLET1}{defLET2} \calls{defLET1}{mkprogn} \calls{defLET1}{defLET1} \calls{defLET1}{strconc} @@ -2105,6 +2105,102 @@ nothing (see boot2Lisp) yet still allow function call (lisp2BootAndComp). @ +\defun{defLET2}{defLET2} +\calls{defLET2}{identp} +\calls{defLET2}{defLetForm} +\calls{defLET2}{qcar} +\calls{defLET2}{qcdr} +\calls{defLET2}{defLET2} +\calls{defLET2}{addCARorCDR} +\calls{defLET2}{defISReverse} +\calls{defLET2}{strconc} +\calls{defLET2}{stringimage} +\calls{defLET2}{defIS1} +\calls{defLET2}{defIS} +\usesdollar{defLET2}{inDefIS} +\usesdollar{defLET2}{let} +\usesdollar{defLET2}{letGenVarCounter} +<>= +(defun |defLET2| (lhs rhs) + (let (id a b l1 var2 patrev rev g l2 tmp2 tmp3 val1 tmp1 var1 isPred) + (declare (special |$inDefIS| $let |$letGenVarCounter|)) + (cond + ((identp lhs) (|defLetForm| lhs rhs)) + ((null lhs) nil) + ((and (pairp lhs) (eq (qcar lhs) 'fluid) + (pairp (qcdr lhs)) (eq (qcdr (qcdr lhs)) nil)) + (|defLetForm| lhs rhs)) + ((and (pairp lhs) (equal (qcar lhs) $let) + (pairp (qcdr lhs)) (pairp (qcdr (qcdr lhs))) + (eq (qcdr (qcdr (qcdr lhs))))) + (setq a (|defLET2| (qcar (qcdr lhs)) rhs)) + (setq b (qcar (qcdr (qcdr lhs)))) + (cond + ((null (setq b (|defLET2| b rhs))) a) + ((atom b) (list a b)) + ((pairp (qcar b)) (cons a b)) + (t (list a b)))) + ((and (pairp lhs) (eq (qcar lhs) 'cons) + (pairp (qcdr lhs)) (pairp (qcdr (qcdr lhs))) + (eq (qcdr (qcdr (qcdr lhs))) nil)) + (setq var1 (qcar (qcdr lhs))) + (setq var2 (qcar (qcdr (qcdr lhs)))) + (if (or (eq var1 (intern "." "BOOT")) + (and (pairp var1) (eqcar var1 'quote))) + (|defLET2| var2 (|addCARorCDR| 'cdr rhs)) + (progn + (setq l1 (|defLET2| var1 (|addCARorCDR| 'car rhs))) + (if (member var2 '(nil |.|)) + l1 + (progn + (when (and (pairp l1) (atom (car l1))) (setq l1 (cons l1 nil))) + (if (identp var2) + (append l1 (cons (|defLetForm| var2 (|addCARorCDR| 'cdr rhs)) nil)) + (progn + (setq l2 (|defLET2| var2 (|addCARorCDR| 'cdr rhs))) + (when (and (pairp l2) (atom (car l2))) (setq l2 (cons l2 nil))) + (append l1 l2)))))))) + ((and (pairp lhs) (eq (qcar lhs) 'append) + (pairp (qcdr lhs)) (pairp (qcdr (qcdr lhs))) + (eq (qcdr (qcdr (qcdr lhs))) nil)) + (setq var1 (qcar (qcdr lhs))) + (setq var2 (qcar (qcdr (qcdr lhs)))) + (setq patrev (|defISReverse| var2 var1)) + (setq rev (list 'reverse rhs)) + (setq g (intern (strconc "LETTMP#" (stringimage |$letGenVarCounter|)))) + (setq |$letGenVarCounter| (1+ |$letGenVarCounter|)) + (setq l2 (|defLET2| patrev g)) + (when (and (pairp l2) (atom (car l2))) (setq l2 (cons l2 nil))) + (cond + ((eq var1 (intern "." "BOOT")) + (cons (list $LET g rev) l2)) + ((and (pairp (|last| l2)) (equal (qcar (|last| l2)) $let) + (pairp (qcdr (|last| l2))) + (equal (qcar (qcdr (|last| l2))) var1) + (pairp (qcdr (qcdr (|last| l2)))) + (eq (qcdr (qcdr (qcdr (|last| l2)))) nil)) + (setq val1 (qcar (qcdr (qcdr (|last| l2))))) + (cons + (list $let g rev) + (append + (reverse (cdr (reverse l2))) + (list (|defLetForm| var1 (list 'nreverse val1)))))) + (t + (cons + (list $let g rev) + (append l2 (list (|defLetForm| var1 (list 'nreverse var1)))))))) + ((and (pairp lhs) (eq (qcar lhs) 'equal) + (pairp (qcdr lhs)) (eq (qcdr (qcdr lhs)) nil)) + (setq var1 (qcar (qcdr lhs))) + (list 'cond (list (list 'equal var1 rhs) var1))) + (t + (setq isPred + (if |$inDefIS| + (|defIS1| rhs lhs) + (|defIS| rhs lhs))) + (list 'cond (list isPred rhs)))))) + +@ \defun{defLetForm}{defLetForm} \usesdollar{defLetForm}{let} <>= @@ -5242,6 +5338,7 @@ if \verb|$InteractiveMode| then use a null outputstream <> <> <> +<> <> <> <> diff --git a/changelog b/changelog index a957695..0296832 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20101013 tpd src/axiom-website/patches.html 20101013.01.tpd.patch +20101013 tpd src/interp/g-boot.lisp treeshake compiler +20101013 tpd books/bookvol9 treeshake compiler 20101012 tpd src/axiom-website/patches.html 20101012.01.tpd.patch 20101012 tpd src/interp/parsing.lisp treeshake compiler 20101012 tpd src/interp/g-boot.lisp treeshake compiler diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index b56e9f7..986c3e1 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3206,5 +3206,7 @@ books/bookvol9 treeshake compiler
books/bookvol9 treeshake compiler
20101012.01.tpd.patch books/bookvol9 treeshake compiler
+20101013.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/g-boot.lisp.pamphlet b/src/interp/g-boot.lisp.pamphlet index b6d5e49..de14611 100644 --- a/src/interp/g-boot.lisp.pamphlet +++ b/src/interp/g-boot.lisp.pamphlet @@ -992,183 +992,6 @@ |body|) ('T |e|)))))) -;--% LET -; -;defLET2(lhs,rhs) == -; IDENTP lhs => defLetForm(lhs,rhs) -; NULL lhs => NIL -; lhs is ['FLUID,id] => defLetForm(lhs,rhs) -; lhs is [=$LET,a,b] => -; a := defLET2(a,rhs) -; null (b := defLET2(b,rhs)) => a -; ATOM b => [a,b] -; PAIRP QCAR b => CONS(a,b) -; [a,b] -; lhs is ['CONS,var1,var2] => -; var1 = "." or (PAIRP(var1) and EQCAR(var1,'QUOTE)) => -; defLET2(var2,addCARorCDR('CDR,rhs)) -; l1 := defLET2(var1,addCARorCDR('CAR,rhs)) -; MEMQ(var2,'(NIL _.)) => l1 -; if PAIRP l1 and ATOM CAR l1 then l1 := cons(l1,nil) -; IDENTP var2 => -; [:l1,defLetForm(var2,addCARorCDR('CDR,rhs))] -; l2 := defLET2(var2,addCARorCDR('CDR,rhs)) -; if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) -; APPEND(l1,l2) -; lhs is ['APPEND,var1,var2] => -; patrev := defISReverse(var2,var1) -; rev := ['REVERSE,rhs] -; g := INTERN STRCONC('"LETTMP#",STRINGIMAGE $letGenVarCounter) -; $letGenVarCounter := $letGenVarCounter + 1 -; l2 := defLET2(patrev,g) -; if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) -; var1 = "." => [[$LET,g,rev],:l2] -; last l2 is [=$LET, =var1, val1] => -; [[$LET,g,rev],:REVERSE CDR REVERSE l2, -; defLetForm(var1,['NREVERSE,val1])] -; [[$LET,g,rev],:l2,defLetForm(var1,['NREVERSE,var1])] -; lhs is ['EQUAL,var1] => -; ['COND,[['EQUAL,var1,rhs],var1]] -; -- let the IS code take over from here -; isPred := -; $inDefIS => defIS1(rhs,lhs) -; defIS(rhs,lhs) -; ['COND,[isPred,rhs]] - -;;; *** |defLET2| REDEFINED - -(DEFUN |defLET2| (|lhs| |rhs|) - (PROG (|id| |a| |b| |l1| |var2| |patrev| |rev| |g| |l2| |ISTMP#2| - |ISTMP#3| |val1| |ISTMP#1| |var1| |isPred|) - (DECLARE (SPECIAL |$inDefIS| $LET |$letGenVarCounter|)) - (RETURN - (COND - ((IDENTP |lhs|) (|defLetForm| |lhs| |rhs|)) - ((NULL |lhs|) NIL) - ((AND (PAIRP |lhs|) (EQ (QCAR |lhs|) 'FLUID) - (PROGN - (SPADLET |ISTMP#1| (QCDR |lhs|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |id| (QCAR |ISTMP#1|)) 'T)))) - (|defLetForm| |lhs| |rhs|)) - ((AND (PAIRP |lhs|) (EQUAL (QCAR |lhs|) $LET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |lhs|)) - (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 |b| (QCAR |ISTMP#2|)) 'T)))))) - (SPADLET |a| (|defLET2| |a| |rhs|)) - (COND - ((NULL (SPADLET |b| (|defLET2| |b| |rhs|))) |a|) - ((ATOM |b|) (CONS |a| (CONS |b| NIL))) - ((PAIRP (QCAR |b|)) (CONS |a| |b|)) - ('T (CONS |a| (CONS |b| NIL))))) - ((AND (PAIRP |lhs|) (EQ (QCAR |lhs|) 'CONS) - (PROGN - (SPADLET |ISTMP#1| (QCDR |lhs|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |var1| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |var2| (QCAR |ISTMP#2|)) - 'T)))))) - (COND - ((OR (BOOT-EQUAL |var1| (INTERN "." "BOOT")) - (AND (PAIRP |var1|) (EQCAR |var1| 'QUOTE))) - (|defLET2| |var2| (|addCARorCDR| 'CDR |rhs|))) - ('T - (SPADLET |l1| - (|defLET2| |var1| (|addCARorCDR| 'CAR |rhs|))) - (COND - ((member |var2| '(NIL |.|)) |l1|) - ('T - (COND - ((AND (PAIRP |l1|) (ATOM (CAR |l1|))) - (SPADLET |l1| (CONS |l1| NIL)))) - (COND - ((IDENTP |var2|) - (APPEND |l1| - (CONS (|defLetForm| |var2| - (|addCARorCDR| 'CDR |rhs|)) - NIL))) - ('T - (SPADLET |l2| - (|defLET2| |var2| - (|addCARorCDR| 'CDR |rhs|))) - (COND - ((AND (PAIRP |l2|) (ATOM (CAR |l2|))) - (SPADLET |l2| (CONS |l2| NIL)))) - (APPEND |l1| |l2|)))))))) - ((AND (PAIRP |lhs|) (EQ (QCAR |lhs|) 'APPEND) - (PROGN - (SPADLET |ISTMP#1| (QCDR |lhs|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |var1| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |var2| (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |patrev| (|defISReverse| |var2| |var1|)) - (SPADLET |rev| (CONS 'REVERSE (CONS |rhs| NIL))) - (SPADLET |g| - (INTERN (STRCONC "LETTMP#" - (STRINGIMAGE |$letGenVarCounter|)))) - (SPADLET |$letGenVarCounter| (PLUS |$letGenVarCounter| 1)) - (SPADLET |l2| (|defLET2| |patrev| |g|)) - (COND - ((AND (PAIRP |l2|) (ATOM (CAR |l2|))) - (SPADLET |l2| (CONS |l2| NIL)))) - (COND - ((BOOT-EQUAL |var1| (INTERN "." "BOOT")) - (CONS (CONS $LET (CONS |g| (CONS |rev| NIL))) |l2|)) - ((PROGN - (SPADLET |ISTMP#1| (|last| |l2|)) - (AND (PAIRP |ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) $LET) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQUAL (QCAR |ISTMP#2|) |var1|) - (PROGN - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |val1| (QCAR |ISTMP#3|)) - 'T))))))) - (CONS (CONS $LET (CONS |g| (CONS |rev| NIL))) - (APPEND (REVERSE (CDR (REVERSE |l2|))) - (CONS (|defLetForm| |var1| - (CONS 'NREVERSE (CONS |val1| NIL))) - NIL)))) - ('T - (CONS (CONS $LET (CONS |g| (CONS |rev| NIL))) - (APPEND |l2| - (CONS (|defLetForm| |var1| - (CONS 'NREVERSE (CONS |var1| NIL))) - NIL)))))) - ((AND (PAIRP |lhs|) (EQ (QCAR |lhs|) 'EQUAL) - (PROGN - (SPADLET |ISTMP#1| (QCDR |lhs|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |var1| (QCAR |ISTMP#1|)) 'T)))) - (CONS 'COND - (CONS (CONS (CONS 'EQUAL (CONS |var1| (CONS |rhs| NIL))) - (CONS |var1| NIL)) - NIL))) - ('T - (SPADLET |isPred| - (COND - (|$inDefIS| (|defIS1| |rhs| |lhs|)) - ('T (|defIS| |rhs| |lhs|)))) - (CONS 'COND (CONS (CONS |isPred| (CONS |rhs| NIL)) NIL))))))) - ;addCARorCDR(acc,expr) == ; NULL PAIRP expr => [acc,expr] ; acc = 'CAR and EQCAR(expr,'REVERSE) =>