diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index a28087d..88be9e0 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -3965,7 +3965,7 @@ The READLOOP calls preparseReadLine which returns a pair of the form ) (prog (($linelist linelist) $echolinestack num line i l psloc instring pcount comsym strsym oparsym cparsym n ncomsym - (sloc -1) continue (parenlev 0) ncomblock locs nums functor) + (sloc -1) continue (parenlev 0) ncomblock lines locs nums functor) (declare (special $linelist $echolinestack |$byConstructors| $skipme |$constructorsSeen| $preparse-last-line)) READLOOP @@ -9003,28 +9003,6 @@ of the symbol being parsed. The original list read: @ -\defun{def-let}{def-let} -\calls{def-let}{deftran} -\calls{def-let}{defLET} -<>= -(defun def-let (form rhs) - (let (f1 f2) - (unless (and (consp form) (eq (qcar form) '\:)) - (setq form (macroexpand form))) - (cond - ((and (consp form) (eq (qcar form) '\:)) - (setq f1 (deftran form)) - (setq f2 (deftran (list 'spadlet (second form) rhs))) - (if (and (eq (car f2) 'spadlet) (equal (second f2) (second form))) - (list 'spadlet (second f1) (third f2)) - (list 'progn f1 f2))) - ((and (consp form) (eq (qcar form) 'elt)) - (deftran (list 'setelt (second form) (third form) rhs))) - (t - (|defLET| form (deftran rhs)))))) - -@ - \defun{defLET}{defLET} \calls{defLET}{defLET1} \usesdollar{defLET}{letGenVarCounter} @@ -9202,24 +9180,6 @@ of the symbol being parsed. The original list read: (defparameter $defstack nil) @ -\defun{def-where}{def-where} -\calls{def-where}{def-whereclauselist} -\calls{def-where}{def-inner} -\calls{def-where}{sublis} -\calls{def-where}{mkprogn} -\calls{def-where}{deftran} -\usesdollar{def-where}{defstack} -\usesdollar{def-where}{opassoc} -<>= -(defun def-where (args) - (let ((x (car args)) (y (cdr args)) $defstack) - (declare (special $defstack $opassoc)) - (let ((u (def-whereclauselist y))) - (mapc #'(lambda (X) (def-inner (first x) nil (sublis $opassoc (second x)))) - $defstack) - (mkprogn (nconc u (list (deftran x))))))) - -@ \defun{def-whereclauselist}{def-whereclauselist} \calls{def-whereclauselist}{def-whereclause} @@ -9467,54 +9427,12 @@ of the symbol being parsed. The original list read: @ -\subsection{IS} -\defun{def-is}{def-is} -\calls{def-is}{def-is2} -\usesdollar{def-is}{is-gensymlist} -\uses{def-is}{Initial-Gensym} -<>= -(defun def-is (x) - (let (($is-gensymlist Initial-Gensym)) - (declare (special is-gensymlist Initial-Gensym)) - (def-is2 (first X) (second x)))) - -@ - \defdollar{is-eqlist} <>= (defparameter $is-eqlist nil) @ -\defun{def-is2}{def-is2} -\calls{def-is2}{eqcar} -\calls{def-is2}{moan} -\calls{def-is2}{def-is-eqlist} -\calls{def-is2}{def-is-remdup} -\calls{def-is2}{mkpf} -\calls{def-is2}{subst} -\calls{def-is2}{dcq} -\calls{def-is2}{listofatoms} -\calls{def-is2}{/tracelet-print} -\usesdollar{def-is2}{is-eqlist} -\usesdollar{def-is2}{is-spill-list} -<>= -(defun def-is2 (form struct) - (let ($is-eqlist $is-spill-list (form (deftran form))) - (when (eqcar struct '|@Tuple|) - (moan "you must use square brackets around right arg. to" '%b "is" '%d)) - (let* ((x (def-is-eqlist (def-is-remdup struct))) - (code (if (identp x) - (mkpf (subst form x $is-eqlist) 'and) - (mkpf `((dcq ,x ,form) . ,$is-eqlist) 'and)))) - (let ((code (mkpf `(,code . ,$is-spill-list) 'and))) - (if $traceletflag - (let ((l (remove-if #'gensymp (listofatoms x)))) - `(prog1 ,code ,@(mapcar #'(lambda (y) `(/tracelet-print ,y ,y)) L))) - code))))) - -@ - \defun{defIS}{defIS} \calls{defIS}{deftran} \calls{defIS}{defIS1} @@ -9670,16 +9588,6 @@ It is pretty much just a translation of DEF-IS-REV @ -\defun{def-collect}{def-collect} -\calls{def-collect}{def-it} -\calls{def-collect}{deftran} -\calls{def-collect}{hackforis} -<>= -(defun def-collect (l) - (def-it 'collect (mapcar #'deftran (hackforis l)))) - -@ - \defun{def-it}{def-it} \calls{def-it}{def-in2on} \calls{def-it}{deftran} @@ -9712,16 +9620,6 @@ It is pretty much just a translation of DEF-IS-REV @ -\defun{def-repeat}{def-repeat} -\calls{def-repeat}{def-it} -\calls{def-repeat}{deftran} -\calls{def-repeat}{hackforis} -<>= -(defun def-repeat (l) - (def-it 'repeat (mapcar #'deftran (hackforis l)))) - -@ - \defun{def-string}{def-string} \calls{def-string}{deftran} \uses{def-string}{*package*} @@ -9819,22 +9717,22 @@ It is pretty much just a translation of DEF-IS-REV \section{The def-tran table} \begin{verbatim} - |:| |DEF-:| - |::| |DEF-::| - ELT DEF-ELT - SETELT DEF-SETELT - LET DEF-LET - COLLECT DEF-COLLECT - LESSP DEF-LESSP - |<| DEF-LESSP - REPEAT DEF-REPEAT - CATEGORY DEF-CATEGORY - EQUAL DEF-EQUAL - |is| DEF-IS - SEQ DEF-SEQ - |isnt| DEF-ISNT - |where| DEF-WHERE - + |:| |DEF-:| + |::| |DEF-::| + CATEGORY DEF-CATEGORY + COLLECT DEF-COLLECT + ELT DEF-ELT + EQUAL DEF-EQUAL + |is| DEF-IS + |isnt| DEF-ISNT + LESSP DEF-LESSP + |<| DEF-LESSP + SPADLET DEF-LET + LET DEF-LET + REPEAT DEF-REPEAT + SEQ DEF-SEQ + SETELT DEF-SETELT + |where| DEF-WHERE \end{verbatim} \defun{deftran}{deftran} @@ -9873,6 +9771,41 @@ nothing (see boot2Lisp) yet still allow function call (lisp2BootAndComp). @ +\defplist{def-:}{def-:} +<>= +(eval-when (eval load) + (setf (get '|:| 'def-tran) '|DEF-:|)) + +@ + +\defun{def-:}{def-:} +\calls{def-:}{dcq} +<>= +(defun |DEF-:| (x &aux y) + (dcq (x y) x) + `(spadlet + ,(if (or (eq y '|fluid|) + (and (identp x) (char= #\$ (elt (pname x) 0)))) + `(fluid ,x) x) + nil)) + +@ + +\defplist{def-::}{def-::} +<>= +(eval-when (eval load) + (setf (get '|::| 'def-tran) '|DEF-::|)) + +@ + +\defmacro{def-::} +<>= +(defmacro |def-::| (x) + (let ((expr (first x)) (type (second x))) + (if (equal type '(|Triple|)) expr (errhuh)))) + +@ + \defplist{category}{def-category} <>= (eval-when (eval load) @@ -9895,6 +9828,23 @@ nothing (see boot2Lisp) yet still allow function call (lisp2BootAndComp). @ +\defplist{collect}{def-collect} +<>= +(eval-when (eval load) + (setf (get 'collect 'def-tran) 'def-collect)) + +@ + +\defun{def-collect}{def-collect} +\calls{def-collect}{def-it} +\calls{def-collect}{deftran} +\calls{def-collect}{hackforis} +<>= +(defun def-collect (l) + (def-it 'collect (mapcar #'deftran (hackforis l)))) + +@ + \defplist{elt}{def-elt} <>= (eval-when (eval load) @@ -9914,6 +9864,144 @@ nothing (see boot2Lisp) yet still allow function call (lisp2BootAndComp). @ +\defplist{equal}{def-equal} +<>= +(eval-when (eval load) + (setf (get 'equal 'def-tran) 'def-equal)) + +@ + +\defun{def-equal}{def-equal} +\usesdollar{def-equal}{boot} +<>= +(defun def-equal (x) + (declare (special $boot)) + (cond + ((not (cdr x)) (cons 'equal x)) + ((or (member '(|One|) X) (member '(|Zero|) X) + (integerp (first x)) (integerp (second x))) (cons 'eql x)) + ((not (first x)) (list 'null (second x))) + ((not (second x)) (list 'null (first x))) + ($boot (cons 'boot-equal x)) + ((cons 'equal x)))) + +@ + +\defplist{lessp}{def-lessp} +<>= +(eval-when (eval load) + (setf (get 'lessp 'def-tran) 'def-lessp)) + +@ + +\defplist{$<$}{def-lessp} +<>= +(eval-when (eval load) + (setf (get '|<| 'def-tran) 'def-lessp)) + +@ + +\defun{def-lessp}{def-lessp} +<>= +(defun def-lessp (x) + (labels ( + (smint-able (x) + (or (typep x 'fixnum) + (and (pairp x) + (member (car x) '(|One| |Zero| length \# qcsize qvsize qlength))))) + ) + (cond + ((null (cdr x)) (cons '< x)) + ((eq (cadr x) 0) (list 'minusp (car x))) + ((and (smint-able (car x)) (smint-able (cadr x))) (cons 'qslessp x)) + ('t (list '> (cadr x) (car x)))))) + +@ + +\defplist{spadlet}{def-let} +<>= +(eval-when (eval load) + (setf (get 'spadlet 'def-tran) 'def-let)) + +@ + +\defplist{let}{def-let} +<>= +(eval-when (eval load) + (setf (get 'let 'def-tran) 'def-let)) + +@ + +\defun{def-let}{def-let} +\calls{def-let}{deftran} +\calls{def-let}{defLET} +<>= +(defun def-let (form rhs) + (let (f1 f2) + (unless (and (consp form) (eq (qcar form) '\:)) + (setq form (macroexpand form))) + (cond + ((and (consp form) (eq (qcar form) '\:)) + (setq f1 (deftran form)) + (setq f2 (deftran (list 'spadlet (second form) rhs))) + (if (and (eq (car f2) 'spadlet) (equal (second f2) (second form))) + (list 'spadlet (second f1) (third f2)) + (list 'progn f1 f2))) + ((and (consp form) (eq (qcar form) 'elt)) + (deftran (list 'setelt (second form) (third form) rhs))) + (t + (|defLET| form (deftran rhs)))))) + +@ + +\defplist{is}{def-is} +<>= +(eval-when (eval load) + (setf (get '|is| 'def-tran) 'def-is)) + +@ + +\defun{def-is}{def-is} +\calls{def-is}{def-is2} +\usesdollar{def-is}{is-gensymlist} +\uses{def-is}{Initial-Gensym} +<>= +(defun def-is (x) + (let (($is-gensymlist Initial-Gensym)) + (declare (special is-gensymlist Initial-Gensym)) + (def-is2 (first X) (second x)))) + +@ + +\defun{def-is2}{def-is2} +\calls{def-is2}{eqcar} +\calls{def-is2}{moan} +\calls{def-is2}{def-is-eqlist} +\calls{def-is2}{def-is-remdup} +\calls{def-is2}{mkpf} +\calls{def-is2}{subst} +\calls{def-is2}{dcq} +\calls{def-is2}{listofatoms} +\calls{def-is2}{/tracelet-print} +\usesdollar{def-is2}{is-eqlist} +\usesdollar{def-is2}{is-spill-list} +<>= +(defun def-is2 (form struct) + (let ($is-eqlist $is-spill-list (form (deftran form))) + (when (eqcar struct '|@Tuple|) + (moan "you must use square brackets around right arg. to" '%b "is" '%d)) + (let* ((x (def-is-eqlist (def-is-remdup struct))) + (code (if (identp x) + (mkpf (subst form x $is-eqlist) 'and) + (mkpf `((dcq ,x ,form) . ,$is-eqlist) 'and)))) + (let ((code (mkpf `(,code . ,$is-spill-list) 'and))) + (if $traceletflag + (let ((l (remove-if #'gensymp (listofatoms x)))) + `(prog1 ,code ,@(mapcar #'(lambda (y) `(/tracelet-print ,y ,y)) L))) + code))))) + +@ + \defplist{isnt}{def-isnt} <>= (eval-when (eval load) @@ -9929,6 +10017,23 @@ nothing (see boot2Lisp) yet still allow function call (lisp2BootAndComp). @ +\defplist{repeat}{def-repeat} +<>= +(eval-when (eval load) + (setf (get 'repeat 'def-tran) 'def-repeat)) + +@ + +\defun{def-repeat}{def-repeat} +\calls{def-repeat}{def-it} +\calls{def-repeat}{deftran} +\calls{def-repeat}{hackforis} +<>= +(defun def-repeat (l) + (def-it 'repeat (mapcar #'deftran (hackforis l)))) + +@ + \defplist{setelt}{def-setelt} <>= (eval-when (eval load) @@ -9949,6 +10054,52 @@ nothing (see boot2Lisp) yet still allow function call (lisp2BootAndComp). @ +\defplist{seq}{def-seq} +<>= +(eval-when (eval load) + (setf (get 'seq 'def-tran) 'def-seq)) + +@ + +\defun{def-seq}{def-seq} +\calls{def-seq}{eqcar} +<>= +(defun def-seq (u) + (labels ( + (seqoptimize (u) + (if (and (eqcar (cadr u) 'exit) (eqcar (cadadr u) 'seq)) + (cadadr u) + u))) + (seqoptimize (cons 'seq u)))) + +@ + +\defplist{where}{def-where} +<>= +(eval-when (eval load) + (setf (get '|where| 'def-tran) 'def-where)) + +@ + +\defun{def-where}{def-where} +\calls{def-where}{def-whereclauselist} +\calls{def-where}{def-inner} +\calls{def-where}{sublis} +\calls{def-where}{mkprogn} +\calls{def-where}{deftran} +\usesdollar{def-where}{defstack} +\usesdollar{def-where}{opassoc} +<>= +(defun def-where (args) + (let ((x (car args)) (y (cdr args)) $defstack) + (declare (special $defstack $opassoc)) + (let ((u (def-whereclauselist y))) + (mapc #'(lambda (X) (def-inner (first x) nil (sublis $opassoc (second x)))) + $defstack) + (mkprogn (nconc u (list (deftran x))))))) + +@ + \chapter{PARSE forms} \section{The original meta specification} This package provides routines to support the Metalanguage @@ -14962,13 +15113,12 @@ if \verb|$InteractiveMode| then use a null outputstream <> <> <> -<> <> +<> <> <> - <> <> <> @@ -15068,11 +15218,14 @@ if \verb|$InteractiveMode| then use a null outputstream <> <> <> +<> <> <> <> <> <> +<> +<> <> <> <> @@ -15099,6 +15252,7 @@ if \verb|$InteractiveMode| then use a null outputstream <> <> <> +<> <> <> <> diff --git a/changelog b/changelog index f1651e2..4c19af4 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20101220 tpd src/axiom-website/patches.html 20101220.02.tpd.patch +20101220 tpd src/interp/vmlisp.lisp treeshake compiler +20101220 tpd src/interp/parsing.lisp treeshake compiler +20101220 tpd books/bookvol9 treeshake compiler 20101220 tpd src/axiom-website/patches.html 20101220.01.tpd.patch 20101220 tpd src/interp/vmlisp.lisp treeshake compiler 20101220 tpd src/interp/parsing.lisp treeshake compiler diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index a5d8cf1..0c2d26c 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3329,5 +3329,7 @@ src/interp/vmlisp.lisp cleaning vmlisp
src/interp/vmlisp.lisp cleaning vmlisp
20101220.01.tpd.patch books/bookvol9 treeshake compiler
+20101220.02.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/parsing.lisp.pamphlet b/src/interp/parsing.lisp.pamphlet index 6adfa66..572bc56 100644 --- a/src/interp/parsing.lisp.pamphlet +++ b/src/interp/parsing.lisp.pamphlet @@ -969,37 +969,6 @@ foo defined inside of fum gets renamed as fum,foo.") ; We are making shallow binding cells for these functions as well -(mapcar #'(lambda (x) (MAKEPROP (FIRST X) 'DEF-TRAN (SECOND X))) - '((\: DEF-\:) (\:\: DEF-\:\:) (ELT DEF-ELT) - (SETELT DEF-SETELT) (SPADLET DEF-LET) - (SEQ DEF-SEQ) (COLLECT DEF-COLLECT) - (REPEAT DEF-REPEAT) (TRACE-LET DEF-TRACE-LET) - (CATEGORY DEF-CATEGORY) (EQUAL DEF-EQUAL) - (|is| DEF-IS) (|isnt| DEF-ISNT) (|where| DEF-WHERE))) - -(defun DEF-EQUAL (X) - (COND ((NOT (CDR X)) (CONS 'EQUAL X)) - ((OR (MEMBER '(|One|) X) (MEMBER '(|Zero|) X) - (integerp (FIRST X)) (integerp (SECOND X))) (CONS 'EQL X)) - ; ((AND (EQCAR (FIRST X) 'QUOTE) (IDENTP (CADAR X))) (CONS 'EQ X)) - ((NOT (FIRST X)) (LIST 'NULL (SECOND X))) - ((NOT (SECOND X)) (LIST 'NULL (FIRST X))) - ; ((AND (EQCAR (SECOND X) 'QUOTE) (IDENTP (CADADR X))) (CONS 'EQ X)) - ($BOOT (CONS 'BOOT-EQUAL X)) - ((CONS 'EQUAL X)))) - -(defun DEF-LESSP (x) - (cond ((null (cdr x)) (cons '< x)) - ((eq (cadr x) 0) (list 'minusp (car x))) - ((and (smint-able (car x)) (smint-able (cadr x))) - (cons 'qslessp x)) - ('t (list '> (CADR x) (CAR x))))) - -(defun smint-able (x) - (or (typep x 'fixnum) - (and (pairp x) (member (car x) - '(|One| |Zero| LENGTH \# QCSIZE QVSIZE QLENGTH))))) - (defun B-MDEF (FORM SIGNATURE $BODY) (declare (ignore SIGNATURE)) (let* ($OpAssoc @@ -1036,19 +1005,6 @@ foo defined inside of fum gets renamed as fum,foo.") (|atom| ATOM) (|nil| NIL) (|null| NULL) (GET GETL) (T T$))) -(defun DEF-SEQ (U) (SEQOPT (CONS 'SEQ U))) - -(defun |DEF-:| (X &aux Y) - (DCQ (x y) x) - `(SPADLET ,(if (or (eq y '|fluid|) - (and (identp x) (char= #\$ (ELT (PNAME X) 0)))) - `(FLUID ,X) X) - NIL)) - -(defmacro |DEF-::| (X) - (let ((expr (first x)) (type (second x))) - (if (EQUAL TYPE '(|Triple|)) EXPR (ERRHUH)))) - (defun DEF-select (L) (cond ((IDENTP (FIRST L)) (DEF-select1 (FIRST L) (SECOND L))) ((LET* ((G (GENSYM)) diff --git a/src/interp/vmlisp.lisp.pamphlet b/src/interp/vmlisp.lisp.pamphlet index f33a73b..7635cb7 100644 --- a/src/interp/vmlisp.lisp.pamphlet +++ b/src/interp/vmlisp.lisp.pamphlet @@ -2736,12 +2736,18 @@ for primitive domains. Also used by putInLocalDomainReferences and optCal.") "Needed by spadCompileOrSetq" 1) (defun -REPEAT (BD SPL) + (labels ( + (seqoptimize (u) + (if (and (eqcar (cadr u) 'exit) (eqcar (cadadr u) 'seq)) + (cadadr u) + u))) (let (u g g1 inc final xcl xv il rsl tll funPLUS funGT fun? funIdent funPLUSform funGTform) (DO ((X SPL (CDR X))) ((ATOM X) (LIST 'spadDO (NREVERSE IL) (LIST (MKPF (NREVERSE XCL) 'OR) XV) - (SEQOPT (CONS 'SEQ (NCONC (NREVERSE RSL) (LIST (LIST 'EXIT BD))))))) + (seqoptimize + (CONS 'SEQ (NCONC (NREVERSE RSL) (LIST (LIST 'EXIT BD))))))) (COND ((ATOM (CAR X)) (FAIL))) (COND ((AND (EQ (CAAR X) 'STEP) (|member| (CADDAR X) '(2 1 0 (|One|) (|Zero|))) @@ -2844,13 +2850,7 @@ for primitive domains. Also used by putInLocalDomainReferences and optCal.") (UNTIL (SETQ G (GENSYM)) (PUSH (LIST G NIL (CAR U)) IL) (PUSH G XCL)) (WHILE (PUSH (LIST 'NULL (CAR U)) XCL)) (SUCHTHAT (SETQ BD (LIST 'SUCHTHATCLAUSE BD (CAR U)))) - (EXIT (SETQ XV (CAR U))) (FAIL))))) - - -(defun SEQOPT (U) - (if (AND (EQCAR U 'SEQ) (EQCAR (CADR U) 'EXIT) (EQCAR (CADADR U) 'SEQ)) - (CADADR U) - U)) + (EXIT (SETQ XV (CAR U))) (FAIL)))))) (defmacro SUCHTHATCLAUSE (&rest L) (LIST 'COND (LIST (CADR L) (CAR L)))) @@ -6251,25 +6251,6 @@ o there is some code at the end of SPECEVAL BOOT that puts "up" ;; from DEF LISP -(REPEAT (IN X '( - (|:| |DEF-:|) - (|::| |DEF-::|) -; (ELT DEF-ELT) -; (SETELT DEF-SETELT) - (LET DEF-LET) - (COLLECT DEF-COLLECT) - (LESSP DEF-LESSP) - (|<| DEF-LESSP) - (REPEAT DEF-REPEAT) -;;(|TRACE,LET| DEF-TRACE-LET) -; (CATEGORY DEF-CATEGORY) - (EQUAL DEF-EQUAL) - (|is| DEF-IS) - (SEQ DEF-SEQ) - (|isnt| DEF-ISNT) - (|where| DEF-WHERE) -)) (PROGN (MAKEPROP (CAR X) '|DEF-TRAN| (CADR X)) (CADR X))) - ;; following was in INIT LISP (REPEAT (IN X '(