diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index f2affc9..75be099 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -2201,6 +2201,7 @@ nothing (see boot2Lisp) yet still allow function call (lisp2BootAndComp). (list 'cond (list isPred rhs)))))) @ + \defun{defLetForm}{defLetForm} \usesdollar{defLetForm}{let} <>= @@ -2210,6 +2211,174 @@ nothing (see boot2Lisp) yet still allow function call (lisp2BootAndComp). @ +\defun{addCARorCDR}{addCARorCDR} +\calls{addCARorCDR}{eqcar} +\calls{addCARorCDR}{qcdr} +\calls{addCARorCDR}{qcar} +<>= +(defun |addCARorCDR| (acc expr) + (let (funs p funsA funsR) + (cond + ((null (pairp expr)) (list acc expr)) + ((and (eq acc 'car) (eqcar expr 'reverse)) (cons '|last| (qcdr expr))) + (t + (setq funs + '(car cdr caar cdar cadr cddr caaar cadar caadr caddr + cdaar cddar cdadr cdddr)) + (setq p (position (qcar expr) funs)) + (if (null p) + (list acc expr) + (progn + (setq funsA + '(caar cadr caaar cadar caadr caddr caaaar caadar caaadr caaddr + cadaar caddar cadadr cadddr)) + (setq funsR + '(cdar cddr cdaar cddar cdadr cdddr cdaaar cdadar cdaadr cdaddr + cddaar cdddar cddadr cddddr)) + (if (eq acc 'car) + (cons (elt funsA p) (qcdr expr)) + (cons (elt funsR p) (qcdr expr))))))))) + +@ + +\subsection{IS} +\defun{defIS}{defIS} +\calls{defIS}{deftran} +\calls{defIS}{defIS1} +\usesdollar{defIS}{isGenVarCounter} +\usesdollar{defIS}{inDefIS} +<>= +(defun |defIS| (lhs rhs) + (let (|$isGenVarCounter| |$inDefIS|) + (declare (special |$isGenVarCounter| |$inDefIS|)) + (setq |$isGenVarCounter| 1) + (setq |$inDefIS| t) + (|defIS1| (deftran lhs) rhs))) + +@ + +\defun{defIS1}{defIS1} +\calls{defIS1}{defLetForm} +\calls{defIS1}{defLET1} +\calls{defIS1}{defLET} +\calls{defIS1}{defIS1} +\calls{defIS1}{mkprogn} +\calls{defIS1}{strconc} +\calls{defIS1}{stringimage} +\calls{defIS1}{qcar} +\calls{defIS1}{qcdr} +\calls{defIS1}{defISReverse} +\calls{defIS1}{say} +\calls{defIS1}{def-is} +\usesdollar{defIS1}{let} +\usesdollar{defIS1}{isGenVarCounter} +\usesdollar{defIS1}{inDefLET} +<>= +(defun |defIS1| (lhs rhs) + (let (d l a1 b1 c cls a b patrev g rev l2) + (declare (special $let |$isGenVarCounter| |$inDefLET|)) + (cond + ((null rhs) (list 'null lhs)) + ((stringp rhs) (list 'eq lhs (list 'quote (intern rhs)))) + ((numberp rhs) (list 'equal lhs rhs)) + ((atom rhs) (list 'progn (|defLetForm| rhs lhs) 't)) + ((and (pairp rhs) (eq (qcar rhs) 'quote) + (pairp (qcdr rhs)) (eq (qcdr (qcdr rhs)) nil)) + (if (identp (qcar (qcdr rhs))) + (list 'eq lhs rhs) + (list 'equal lhs rhs))) + ((and (pairp rhs) (equal (qcar rhs) $let) + (pairp (qcdr rhs)) (pairp (qcdr (qcdr rhs))) + (eq (qcdr (qcdr (qcdr rhs))) nil)) + (setq c (qcar (qcdr rhs))) + (setq d (qcar (qcdr (qcdr rhs)))) + (setq l + (if |$inDefLET| + (|defLET1| c lhs) + (|defLET| c lhs))) + (list 'and (|defIS1| lhs d) (mkprogn (list l t)))) + ((and (pairp rhs) (eq (qcar rhs) 'equal) + (pairp (qcdr rhs)) (eq (qcdr (qcdr rhs)) nil)) + (setq a (qcar (qcdr rhs))) + (list 'equal lhs a )) + ((pairp lhs) + (setq g (intern (strconc "ISTMP#" (stringimage |$isGenVarCounter|)))) + (setq |$isGenVarCounter| (1+ |$isGenVarCounter|)) + (mkprogn (list (list $let g lhs) (|defIS1| g rhs)))) + ((and (pairp rhs) (eq (qcar rhs) 'cons) (pairp (qcdr rhs)) + (pairp (qcdr (qcdr rhs))) (eq (qcdr (qcdr (qcdr rhs))) nil)) + (setq a (qcar (qcdr rhs))) + (setq b (qcar (qcdr (qcdr rhs)))) + (cond + ((eq a (intern "." "BOOT")) + (if (null b) + (list 'and (list 'pairp lhs) (list 'eq (list 'qcdr lhs) nil)) + (list 'and (list 'pairp lhs) (|defIS1| (list 'qcdr lhs) b)))) + ((null b) + (list 'and (list 'pairp lhs) + (list 'eq (list 'qcdr lhs) nil) + (|defIS1| (list 'qcar lhs) a))) + ((eq b (intern "." "BOOT")) + (list 'and (list 'pairp lhs) (|defIS1| (list 'qcar lhs) a))) + (t + (setq a1 (|defIS1| (list 'qcar lhs) a)) + (setq b1 (|defIS1| (list 'qcdr lhs) b)) + (cond + ((and (pairp a1) (eq (qcar a1) 'progn) + (pairp (qcdr a1)) (pairp (qcdr (qcdr a1))) + (eq (qcdr (qcdr (qcdr a1))) nil) + (equal (qcar (qcdr (qcdr a1))) t) + (pairp b1) (eq (qcar b1) 'progn)) + (setq c (qcar (qcdr a1))) + (setq cls (qcdr b1)) + (list 'and (list 'pairp lhs) (mkprogn (cons c cls)))) + (t + (list 'and (list 'pairp lhs) a1 b1)))))) + ((and (pairp rhs) (eq (qcar rhs) 'append) (pairp (qcdr rhs)) + (pairp (qcdr (qcdr rhs))) (eq (qcdr (qcdr (qcdr rhs))) nil)) + (setq a (qcar (qcdr rhs))) + (setq b (qcar (qcdr (qcdr rhs)))) + (setq patrev (|defISReverse| b a)) + (setq g (intern (strconc "ISTMP#" (stringimage |$isGenVarCounter|)))) + (setq |$isGenVarCounter| (1+ |$isGenVarCounter|)) + (setq rev + (list 'and + (list 'pairp lhs) + (list 'progn (list $let g (list 'reverse lhs)) t))) + (setq l2 (|defIS1| g patrev)) + (when (and (pairp l2) (atom (car l2))) (setq l2 (list l2))) + (cond + ((eq a (intern "." "BOOT")) + (cons 'and (cons rev l2))) + (t + (cons 'and + (cons rev + (append l2 + (list + (list 'progn (list (|defLetForm| a (list 'nreverse a )) t))))))))) + (t + (say "WARNING (defIS1): possibly bad IS code being generated") + (def-is (list lhs rhs)))))) + +@ +\defun{defISReverse}{defISReverse} +This reverses forms coming from APPENDs in patterns. +It is pretty much just a translation of DEF-IS-REV +\calls{defISReverse}{defISReverse} +\calls{defISReverse}{errhuh} +<>= +(defun |defISReverse| (x a) + (let (y) + (if (and (pairp x) (eq (qcar x) 'cons)) + (if (null (caddr x)) + (list 'cons (cadr x) a) + (progn + (setq y (|defISReverse| (caddr x) nil)) + (rplac (caddr y) (list 'cons (cadr x) a)) + y)) + (errhuh)))) + +@ ;unTuple x == ; x is ['Tuple,:y] => y @@ -5285,6 +5454,7 @@ if \verb|$InteractiveMode| then use a null outputstream <> +<> <> <> <> @@ -5335,6 +5505,9 @@ if \verb|$InteractiveMode| then use a null outputstream <> <> <> +<> +<> +<> <> <> <> diff --git a/changelog b/changelog index 0296832..7aeb153 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20101013 tpd src/axiom-website/patches.html 20101013.02.tpd.patch +20101013 tpd src/interp/g-boot.lisp treeshake compiler +20101013 tpd books/bookvol9 treeshake compiler 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 diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 986c3e1..3901bed 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3208,5 +3208,7 @@ books/bookvol9 treeshake compiler
books/bookvol9 treeshake compiler
20101013.01.tpd.patch books/bookvol9 treeshake compiler
+20101013.02.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/g-boot.lisp.pamphlet b/src/interp/g-boot.lisp.pamphlet index de14611..44aeded 100644 --- a/src/interp/g-boot.lisp.pamphlet +++ b/src/interp/g-boot.lisp.pamphlet @@ -992,313 +992,6 @@ |body|) ('T |e|)))))) -;addCARorCDR(acc,expr) == -; NULL PAIRP expr => [acc,expr] -; acc = 'CAR and EQCAR(expr,'REVERSE) => -; cons('last,QCDR expr) -; funs := '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR -; CDAAR CDDAR CDADR CDDDR) -; p := position(QCAR expr,funs) -; p = -1 => [acc,expr] -; funsA := '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR CAAADR -; CAADDR CADAAR CADDAR CADADR CADDDR) -; funsR := '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR CDAADR -; CDADDR CDDAAR CDDDAR CDDADR CDDDDR) -; if acc = 'CAR then CONS(funsA.p,QCDR expr) -; else CONS(funsR.p,QCDR expr) - -;;; *** |addCARorCDR| REDEFINED - -(DEFUN |addCARorCDR| (|acc| |expr|) - (PROG (|funs| |p| |funsA| |funsR|) - (RETURN - (COND - ((NULL (PAIRP |expr|)) (CONS |acc| (CONS |expr| NIL))) - ((AND (BOOT-EQUAL |acc| 'CAR) (EQCAR |expr| 'REVERSE)) - (CONS '|last| (QCDR |expr|))) - ('T - (SPADLET |funs| - '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR - CDAAR CDDAR CDADR CDDDR)) - (SPADLET |p| (|position| (QCAR |expr|) |funs|)) - (COND - ((BOOT-EQUAL |p| (SPADDIFFERENCE 1)) - (CONS |acc| (CONS |expr| NIL))) - ('T - (SPADLET |funsA| - '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR - CAAADR CAADDR CADAAR CADDAR CADADR CADDDR)) - (SPADLET |funsR| - '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR - CDAADR CDADDR CDDAAR CDDDAR CDDADR CDDDDR)) - (COND - ((BOOT-EQUAL |acc| 'CAR) - (CONS (ELT |funsA| |p|) (QCDR |expr|))) - ('T (CONS (ELT |funsR| |p|) (QCDR |expr|))))))))))) - -;--% IS -; -;defISReverse(x,a) == -; -- reverses forms coming from APPENDs in patterns -; -- pretty much just a translation of DEF-IS-REV -; x is ['CONS,:.] => -; NULL CADDR x => ['CONS,CADR x, a] -; y := defISReverse(CADDR x, NIL) -; RPLAC(CADDR y,['CONS,CADR x,a]) -; y -; ERRHUH() - -;;; *** |defISReverse| REDEFINED - -(DEFUN |defISReverse| (|x| |a|) - (PROG (|y|) - (RETURN - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'CONS)) - (COND - ((NULL (CADDR |x|)) - (CONS 'CONS (CONS (CADR |x|) (CONS |a| NIL)))) - ('T (SPADLET |y| (|defISReverse| (CADDR |x|) NIL)) - (RPLAC (CADDR |y|) - (CONS 'CONS (CONS (CADR |x|) (CONS |a| NIL)))) - |y|))) - ('T (ERRHUH)))))) - -;defIS1(lhs,rhs) == -; NULL rhs => -; ['NULL,lhs] -; STRINGP rhs => -; ['EQ,lhs,['QUOTE,INTERN rhs]] -; NUMBERP rhs => -; ['EQUAL,lhs,rhs] -; ATOM rhs => -; ['PROGN,defLetForm(rhs,lhs),''T] -; rhs is ['QUOTE,a] => -; IDENTP a => ['EQ,lhs,rhs] -; ['EQUAL,lhs,rhs] -; rhs is [=$LET,c,d] => -; l := -; $inDefLET => defLET1(c,lhs) -; defLET(c,lhs) -; ['AND,defIS1(lhs,d),MKPROGN [l,''T]] -; rhs is ['EQUAL,a] => -; ['EQUAL,lhs,a] -; PAIRP lhs => -; g := INTERN STRCONC('"ISTMP#",STRINGIMAGE $isGenVarCounter) -; $isGenVarCounter := $isGenVarCounter + 1 -; MKPROGN [[$LET,g,lhs],defIS1(g,rhs)] -; rhs is ['CONS,a,b] => -; a = "." => -; NULL b => -; ['AND,['PAIRP,lhs], -; ['EQ,['QCDR,lhs],'NIL]] -; ['AND,['PAIRP,lhs], -; defIS1(['QCDR,lhs],b)] -; NULL b => -; ['AND,['PAIRP,lhs], -; ['EQ,['QCDR,lhs],'NIL],_ -; defIS1(['QCAR,lhs],a)] -; b = "." => -; ['AND,['PAIRP,lhs],defIS1(['QCAR,lhs],a)] -; a1 := defIS1(['QCAR,lhs],a) -; b1 := defIS1(['QCDR,lhs],b) -; a1 is ['PROGN,c,''T] and b1 is ['PROGN,:cls] => -; ['AND,['PAIRP,lhs],MKPROGN [c,:cls]] -; ['AND,['PAIRP,lhs],a1,b1] -; rhs is ['APPEND,a,b] => -; patrev := defISReverse(b,a) -; g := INTERN STRCONC('"ISTMP#",STRINGIMAGE $isGenVarCounter) -; $isGenVarCounter := $isGenVarCounter + 1 -; rev := ['AND,['PAIRP,lhs],['PROGN,[$LET,g,['REVERSE,lhs]],''T]] -; l2 := defIS1(g,patrev) -; if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) -; a = "." => ['AND,rev,:l2] -; ['AND,rev,:l2,['PROGN,defLetForm(a,['NREVERSE,a]),''T]] -; SAY '"WARNING (defIS1): possibly bad IS code being generated" -; DEF_-IS [lhs,rhs] - -;;; *** |defIS1| REDEFINED - -(DEFUN |defIS1| (|lhs| |rhs|) - (PROG (|d| |l| |a1| |b1| |c| |cls| |ISTMP#1| |a| |ISTMP#2| |b| - |patrev| |g| |rev| |l2|) - (DECLARE (SPECIAL $LET |$isGenVarCounter| |$inDefLET|)) - (RETURN - (COND - ((NULL |rhs|) (CONS 'NULL (CONS |lhs| NIL))) - ((STRINGP |rhs|) - (CONS 'EQ - (CONS |lhs| - (CONS (CONS 'QUOTE (CONS (INTERN |rhs|) NIL)) NIL)))) - ((NUMBERP |rhs|) (CONS 'EQUAL (CONS |lhs| (CONS |rhs| NIL)))) - ((ATOM |rhs|) - (CONS 'PROGN (CONS (|defLetForm| |rhs| |lhs|) (CONS ''T NIL)))) - ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) 'QUOTE) - (PROGN - (SPADLET |ISTMP#1| (QCDR |rhs|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T)))) - (COND - ((IDENTP |a|) (CONS 'EQ (CONS |lhs| (CONS |rhs| NIL)))) - ('T (CONS 'EQUAL (CONS |lhs| (CONS |rhs| NIL)))))) - ((AND (PAIRP |rhs|) (EQUAL (QCAR |rhs|) $LET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |rhs|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |c| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |d| (QCAR |ISTMP#2|)) 'T)))))) - (SPADLET |l| - (COND - (|$inDefLET| (|defLET1| |c| |lhs|)) - ('T (|defLET| |c| |lhs|)))) - (CONS 'AND - (CONS (|defIS1| |lhs| |d|) - (CONS (MKPROGN (CONS |l| (CONS ''T NIL))) NIL)))) - ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) 'EQUAL) - (PROGN - (SPADLET |ISTMP#1| (QCDR |rhs|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T)))) - (CONS 'EQUAL (CONS |lhs| (CONS |a| NIL)))) - ((PAIRP |lhs|) - (SPADLET |g| - (INTERN (STRCONC "ISTMP#" - (STRINGIMAGE |$isGenVarCounter|)))) - (SPADLET |$isGenVarCounter| (PLUS |$isGenVarCounter| 1)) - (MKPROGN (CONS (CONS $LET (CONS |g| (CONS |lhs| NIL))) - (CONS (|defIS1| |g| |rhs|) NIL)))) - ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) 'CONS) - (PROGN - (SPADLET |ISTMP#1| (QCDR |rhs|)) - (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)))))) - (COND - ((BOOT-EQUAL |a| (INTERN "." "BOOT")) - (COND - ((NULL |b|) - (CONS 'AND - (CONS (CONS 'PAIRP (CONS |lhs| NIL)) - (CONS (CONS 'EQ - (CONS - (CONS 'QCDR (CONS |lhs| NIL)) - (CONS 'NIL NIL))) - NIL)))) - ('T - (CONS 'AND - (CONS (CONS 'PAIRP (CONS |lhs| NIL)) - (CONS (|defIS1| - (CONS 'QCDR (CONS |lhs| NIL)) |b|) - NIL)))))) - ((NULL |b|) - (CONS 'AND - (CONS (CONS 'PAIRP (CONS |lhs| NIL)) - (CONS (CONS 'EQ - (CONS (CONS 'QCDR (CONS |lhs| NIL)) - (CONS 'NIL NIL))) - (CONS (|defIS1| - (CONS 'QCAR (CONS |lhs| NIL)) |a|) - NIL))))) - ((BOOT-EQUAL |b| (INTERN "." "BOOT")) - (CONS 'AND - (CONS (CONS 'PAIRP (CONS |lhs| NIL)) - (CONS (|defIS1| (CONS 'QCAR (CONS |lhs| NIL)) - |a|) - NIL)))) - ('T - (SPADLET |a1| (|defIS1| (CONS 'QCAR (CONS |lhs| NIL)) |a|)) - (SPADLET |b1| (|defIS1| (CONS 'QCDR (CONS |lhs| NIL)) |b|)) - (COND - ((AND (PAIRP |a1|) (EQ (QCAR |a1|) 'PROGN) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a1|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |c| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (EQUAL (QCAR |ISTMP#2|) ''T))))) - (PAIRP |b1|) (EQ (QCAR |b1|) 'PROGN) - (PROGN (SPADLET |cls| (QCDR |b1|)) 'T)) - (CONS 'AND - (CONS (CONS 'PAIRP (CONS |lhs| NIL)) - (CONS (MKPROGN (CONS |c| |cls|)) NIL)))) - ('T - (CONS 'AND - (CONS (CONS 'PAIRP (CONS |lhs| NIL)) - (CONS |a1| (CONS |b1| NIL))))))))) - ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) 'APPEND) - (PROGN - (SPADLET |ISTMP#1| (QCDR |rhs|)) - (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 |patrev| (|defISReverse| |b| |a|)) - (SPADLET |g| - (INTERN (STRCONC "ISTMP#" - (STRINGIMAGE |$isGenVarCounter|)))) - (SPADLET |$isGenVarCounter| (PLUS |$isGenVarCounter| 1)) - (SPADLET |rev| - (CONS 'AND - (CONS (CONS 'PAIRP (CONS |lhs| NIL)) - (CONS (CONS 'PROGN - (CONS - (CONS $LET - (CONS |g| - (CONS - (CONS 'REVERSE - (CONS |lhs| NIL)) - NIL))) - (CONS ''T NIL))) - NIL)))) - (SPADLET |l2| (|defIS1| |g| |patrev|)) - (COND - ((AND (PAIRP |l2|) (ATOM (CAR |l2|))) - (SPADLET |l2| (CONS |l2| NIL)))) - (COND - ((BOOT-EQUAL |a| (INTERN "." "BOOT")) - (CONS 'AND (CONS |rev| |l2|))) - ('T - (CONS 'AND - (CONS |rev| - (APPEND |l2| - (CONS (CONS 'PROGN - (CONS - (|defLetForm| |a| - (CONS 'NREVERSE - (CONS |a| NIL))) - (CONS ''T NIL))) - NIL))))))) - ('T - (SAY "WARNING (defIS1): possibly bad IS code being generated") - (DEF-IS (CONS |lhs| (CONS |rhs| NIL)))))))) - -;defIS(lhs,rhs) == -; $isGenVarCounter : local := 1 -; $inDefIS : local := true -; defIS1(DEFTRAN lhs,rhs) - -;;; *** |defIS| REDEFINED - -(DEFUN |defIS| (|lhs| |rhs|) - (PROG (|$isGenVarCounter| |$inDefIS|) - (DECLARE (SPECIAL |$isGenVarCounter| |$inDefIS|)) - (RETURN - (PROGN - (SPADLET |$isGenVarCounter| 1) - (SPADLET |$inDefIS| 'T) - (|defIS1| (DEFTRAN |lhs|) |rhs|))))) - ;--% OR and AND ; ;bootOR e ==