diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index 7a7c6c4..cc11a37 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -2416,6 +2416,214 @@ of the symbol being parsed. The original list read: @ +\defplist{pretend}{postPretend} +<>= +(eval-when (eval load) + (setf (get '|pretend| '|postTran|) '|postPretend|)) + +@ + +\defun{postPretend}{postPretend} +\calls{postPretend}{postTran} +\calls{postPretend}{postType} +<>= +(defun |postPretend| (arg) + (cons '|pretend| (cons (|postTran| (second arg)) (|postType| (third arg))))) + +@ + +\defplist{quote}{postQUOTE} +<>= +(eval-when (eval load) + (setf (get 'quote '|postTran|) '|postQuote|)) + +@ + +\defun{postQUOTE}{postQUOTE} +<>= +(defun |postQUOTE| (arg) arg) + +@ + +\defplist{reduce}{postReduce} +<>= +(eval-when (eval load) + (setf (get '|Reduce| '|postTran|) '|postReduce|)) + +@ + +\defun{postReduce}{postReduce} +\calls{postReduce}{postTran} +\calls{postReduce}{postReduce} +\usesdollar{postReduce}{InteractiveMode} +<>= +(defun |postReduce| (arg) + (let (op expr g) + (setq op (second arg)) + (setq expr (third arg)) + (if (or |$InteractiveMode| (and (pairp expr) (eq (qcar expr) 'collect))) + (list 'reduce op 0 (|postTran| expr)) + (|postReduce| + (list '|Reduce| op + (list 'collect + (list 'in (setq g (gensym)) expr) + (list '|construct| g))))))) + +@ + +\defplist{repeat}{postRepeat} +<>= +(eval-when (eval load) + (setf (get 'repeat '|postTran|) '|postRepeat|)) + +@ + +\defun{postRepeat}{postRepeat} +\calls{postRepeat}{postIteratorList} +\calls{postRepeat}{postTran} +<>= +(defun |postRepeat| (arg) + (let (tmp1 x m) + (setq tmp1 (reverse (cdr arg))) + (setq x (car tmp1)) + (setq m (nreverse (cdr tmp1))) + (cons 'repeat (append (|postIteratorList| m) (list (|postTran| x)))))) + +@ + +\defplist{Scripts}{postScripts} +<>= +(eval-when (eval load) + (setf (get '|Scripts| '|postTran|) '|postScripts|)) + +@ + +\defun{postScripts}{postScripts} +\calls{postScripts}{getScriptName} +\calls{postScripts}{postTranScripts} +<>= +(defun |postScripts| (arg) + (cons (|getScriptName| (second arg) (third arg) 0) + (|postTranScripts| (third arg)))) + +@ + +\defplist{;}{postSemiColon} +<>= +(eval-when (eval load) + (setf (get '|;| '|postTran|) '|postSemiColon|)) + +@ + +\defun{postSemiColon}{postSemiColon} +\calls{postSemiColon}{postBlock} +\calls{postSemiColon}{postFlattenLeft} +<>= +(defun |postSemiColon| (u) + (|postBlock| (cons '|Block| (|postFlattenLeft| u '|;|)))) + +@ + + +\defplist{Signature}{postSignature} +<>= +(eval-when (eval load) + (setf (get '|Signature| '|postTran|) '|postSignature|)) + +@ + +\defun{postSignature}{postSignature} +\calls{postSignature}{pairp} +\calls{postSignature}{postType} +\calls{postSignature}{removeSuperfluousMapping} +\calls{postSignature}{killColons} +<>= +(defun |postSignature| (arg) + (let (sig sig1 op) + (setq op (second arg)) + (setq sig (third arg)) + (when (and (pairp sig) (eq (qcar sig) '->)) + (setq sig1 (|postType| sig)) + (setq op (|postAtom| (if (stringp op) (setq op (intern op)) op))) + (cons 'signature + (cons op (|removeSuperfluousMapping| (|killColons| sig1))))))) + +@ + +\defplist{/}{postSlash} +<>= +(eval-when (eval load) + (setf (get '/ '|postTran|) '|postSlash|)) + +@ + +\defun{postSlash}{postSlash} +\calls{postSlash}{postTran} +<>= +(defun |postSlash| (arg) + (if (stringp (second arg)) + (|postTran| (list '|Reduce| (intern (second arg)) (third arg) )) + (list '/ (|postTran| (second arg)) (|postTran| (third arg))))) + +@ + +\defplist{@Tuple}{postTuple} +<>= +(eval-when (eval load) + (setf (get '|@Tuple| '|postTran|) '|postTuple|)) + +@ + +\defun{postTuple}{postTuple} +\calls{postTuple}{postTranList} +<>= +(defun |postTuple| (arg) + (cond + ((and (pairp arg) (eq (qcdr arg) nil) (eq (qcar arg) '|@Tuple|)) + arg) + ((and (pairp arg) (eq (qcar arg) '|@Tuple|) (pairp (qcdr arg))) + (cons '|@Tuple| (|postTranList| (cdr arg)))))) + +@ + +\defplist{TupleCollect}{postTupleCollect} +<>= +(eval-when (eval load) + (setf (get '|TupleCollect| '|postTran|) '|postTupleCollect|)) + +@ + +\defun{postTupleCollect}{postTupleCollect} +\calls{postTupleCollect}{postCollect} +<>= +(defun |postTupleCollect| (arg) + (let (constructOp tmp1 x m) + (setq constructOp (car arg)) + (setq tmp1 (reverse (cdr arg))) + (setq x (car tmp1)) + (setq m (nreverse (cdr tmp1))) + (|postCollect| (cons constructOp (append m (list (list '|construct| x))))))) + +@ + +\defplist{where}{postWhere} +<>= +(eval-when (eval load) + (setf (get '|where| '|postTran|) '|postWhere|)) + +@ + +\defun{postWhere}{postWhere} +\calls{postWhere}{postTran} +\calls{postWhere}{postTranList} +<>= +(defun |postWhere| (arg) + (let (b x) + (setq b (third arg)) + (setq x (if (and (pairp b) (eq (qcar b) '|Block|)) (qcdr b) (list b))) + (cons '|where| (cons (|postTran| (second arg)) (|postTranList| x))))) + +@ \defplist{with}{postWith} <>= @@ -9082,12 +9290,23 @@ if \verb|$InteractiveMode| then use a null outputstream <> <> <> +<> +<> +<> +<> +<> <> +<> +<> +<> <> <> <> <> <> +<> +<> +<> <> <> <> diff --git a/changelog b/changelog index 91cb9aa..9ef1ade 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20101108 tpd src/axiom-website/patches.html 20101108.01.tpd.patch +20101108 tpd src/interp/vmlisp.lisp treeshake compiler +20101108 tpd src/interp/parsing.lisp treeshake compiler +20101108 tpd books/bookvol9 treeshake compiler 20101101 tpd src/axiom-website/patches.html 20101101.01.tpd.patch 20101101 tpd src/interp/vmlisp.lisp treeshake compiler 20101101 tpd src/interp/parsing.lisp treeshake compiler diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index d8a9d48..a86749c 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3256,6 +3256,8 @@ books/bookvol9 treeshake compiler
books/bookvol9 treeshake compiler
20101101.01.tpd.patch books/bookvol9 treeshake compiler
+20101108.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/parsing.lisp.pamphlet b/src/interp/parsing.lisp.pamphlet index 51356ea..faaf26c 100644 --- a/src/interp/parsing.lisp.pamphlet +++ b/src/interp/parsing.lisp.pamphlet @@ -2353,16 +2353,6 @@ parse ;;; *** |postCapsule| REDEFINED (DEFUN |postCapsule| (|x|) (PROG (|op|) (RETURN (COND ((NULL (AND (PAIRP |x|) (PROGN (SPADLET |op| (QCAR |x|)) (QUOTE T)))) (|checkWarningIndentation|)) ((OR (integerp |op|) (BOOT-EQUAL |op| (QUOTE ==))) (CONS (QUOTE CAPSULE) (CONS (|postBlockItem| |x|) NIL))) ((BOOT-EQUAL |op| (QUOTE |;|)) (CONS (QUOTE CAPSULE) (|postBlockItemList| (|postFlatten| |x| (QUOTE |;|))))) ((BOOT-EQUAL |op| (QUOTE |if|)) (CONS (QUOTE CAPSULE) (CONS (|postBlockItem| |x|) NIL))) ((QUOTE T) (|checkWarningIndentation|)))))) -;postQUOTE x == x - -;;; *** |postQUOTE| REDEFINED - -(DEFUN |postQUOTE| (|x|) |x|) -;postPretend ['pretend,x,y] == ['pretend,postTran x,:postType y] - -;;; *** |postPretend| REDEFINED - -(DEFUN |postPretend| (#0=#:G166336) (PROG (|x| |y|) (RETURN (PROGN (SPADLET |x| (CADR #0#)) (SPADLET |y| (CADDR #0#)) (CONS (QUOTE |pretend|) (CONS (|postTran| |x|) (|postType| |y|))))))) ;postMakeCons l == ; null l => 'nil ; l is [[":",a],:l'] => @@ -2449,19 +2439,7 @@ parse ;;; *** |postQuote| REDEFINED -(DEFUN |postQuote| (#0=#:G167035) (PROG (|a|) (RETURN (PROGN (SPADLET |a| (CADR #0#)) (CONS (QUOTE QUOTE) (CONS |a| NIL)))))) -;postScripts ['Scripts,op,a] == -; [getScriptName(op,a,0),:postTranScripts a] - -;;; *** |postScripts| REDEFINED - -(DEFUN |postScripts| (#0=#:G167060) (PROG (|op| |a|) (RETURN (PROGN (SPADLET |op| (CADR #0#)) (SPADLET |a| (CADDR #0#)) (CONS (|getScriptName| |op| |a| 0) (|postTranScripts| |a|)))))) - -;postRepeat ['REPEAT,:m,x] == ['REPEAT,:postIteratorList m,postTran x] - -;;; *** |postRepeat| REDEFINED - -(DEFUN |postRepeat| (#0=#:G167247) (PROG (|LETTMP#1| |x| |m|) (RETURN (PROGN (SPADLET |LETTMP#1| (REVERSE (CDR #0#))) (SPADLET |x| (CAR |LETTMP#1|)) (SPADLET |m| (NREVERSE (CDR |LETTMP#1|))) (CONS (QUOTE REPEAT) (APPEND (|postIteratorList| |m|) (CONS (|postTran| |x|) NIL))))))) +;(DEFUN |postQuote| (#0=#:G167035) (PROG (|a|) (RETURN (PROGN (SPADLET |a| (CADR #0#)) (CONS (QUOTE QUOTE) (CONS |a| NIL)))))) ;postSEGMENT ['SEGMENT,a,b] == ; key:= [a,'"..",:(b => [b]; nil)] ; postError ['" Improper placement of segment",:bright key] @@ -2486,12 +2464,6 @@ parse ; ['REDUCE,'append,0,[op,:itl,newBody]] ; [op,:itl,y] -;postTupleCollect [constructOp,:m,x] == -; postCollect [constructOp,:m,['construct,x]] - -;;; *** |postTupleCollect| REDEFINED - -(DEFUN |postTupleCollect| (#0=#:G167402) (PROG (|constructOp| |LETTMP#1| |x| |m|) (RETURN (PROGN (SPADLET |constructOp| (CAR #0#)) (SPADLET |LETTMP#1| (REVERSE (CDR #0#))) (SPADLET |x| (CAR |LETTMP#1|)) (SPADLET |m| (NREVERSE (CDR |LETTMP#1|))) (|postCollect| (CONS |constructOp| (APPEND |m| (CONS (CONS (QUOTE |construct|) (CONS |x| NIL)) NIL)))))))) ;postIteratorList x == ; x is [p,:l] => ; (p:= postTran p) is ['IN,y,u] => @@ -2536,15 +2508,6 @@ parse ;;; *** SEGMENT REDEFINED (DEFUN SEGMENT (|a| |b|) (PROG NIL (RETURN (SEQ (PROG (#0=#:G167597) (SPADLET #0# NIL) (RETURN (DO ((|i| |a| (+ |i| 1))) ((> |i| |b|) (NREVERSE0 #0#)) (SEQ (EXIT (SETQ #0# (CONS |i| #0#))))))))))) -;postReduce ['Reduce,op,expr] == -; $InteractiveMode or expr is ['COLLECT,:.] => -; ['REDUCE,op,0,postTran expr] -; postReduce ['Reduce,op,['COLLECT,['IN,g:= GENSYM(),expr], -; ['construct, g]]] - -;;; *** |postReduce| REDEFINED - -(DEFUN |postReduce| (#0=#:G167610) (PROG (|op| |expr| |g|) (RETURN (PROGN (SPADLET |op| (CADR #0#)) (SPADLET |expr| (CADDR #0#)) (COND ((OR |$InteractiveMode| (AND (PAIRP |expr|) (EQ (QCAR |expr|) (QUOTE COLLECT)))) (CONS (QUOTE REDUCE) (CONS |op| (CONS 0 (CONS (|postTran| |expr|) NIL))))) ((QUOTE T) (|postReduce| (CONS (QUOTE |Reduce|) (CONS |op| (CONS (CONS (QUOTE COLLECT) (CONS (CONS (QUOTE IN) (CONS (SPADLET |g| (GENSYM)) (CONS |expr| NIL))) (CONS (CONS (QUOTE |construct|) (CONS |g| NIL)) NIL))) NIL)))))))))) ;postFlattenLeft(x,op) ==-- ; x is [ =op,a,b] => [:postFlattenLeft(a,op),b] ; [x] @@ -2552,26 +2515,12 @@ parse ;;; *** |postFlattenLeft| REDEFINED (DEFUN |postFlattenLeft| (|x| |op|) (PROG (|ISTMP#1| |a| |ISTMP#2| |b|) (RETURN (COND ((AND (PAIRP |x|) (EQUAL (QCAR |x|) |op|) (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 |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) (APPEND (|postFlattenLeft| |a| |op|) (CONS |b| NIL))) ((QUOTE T) (CONS |x| NIL)))))) -;postSemiColon u == postBlock ['Block,:postFlattenLeft(u,";")] - -;;; *** |postSemiColon| REDEFINED - -(DEFUN |postSemiColon| (|u|) (|postBlock| (CONS (QUOTE |Block|) (|postFlattenLeft| |u| (QUOTE |;|))))) ;postSequence ['Sequence,:l] == ['(elt $ makeRecord),:postTranList l] ;;; *** |postSequence| REDEFINED (DEFUN |postSequence| (#0=#:G167652) (PROG (|l|) (RETURN (PROGN (SPADLET |l| (CDR #0#)) (CONS (QUOTE (|elt| $ |makeRecord|)) (|postTranList| |l|)))))) ;--------------------> NEW DEFINITION (see br-saturn.boot.pamphlet) -;postSignature ['Signature,op,sig] == -; sig is ["->",:.] => -; sig1:= postType sig -; op:= postAtom (STRINGP op => INTERN op; op) -; ["SIGNATURE",op,:removeSuperfluousMapping killColons sig1] - -;;; *** |postSignature| REDEFINED - -(DEFUN |postSignature| (#0=#:G167665) (PROG (|sig| |sig1| |op|) (RETURN (PROGN (SPADLET |op| (CADR #0#)) (SPADLET |sig| (CADDR #0#)) (COND ((AND (PAIRP |sig|) (EQ (QCAR |sig|) (QUOTE ->))) (PROGN (SPADLET |sig1| (|postType| |sig|)) (SPADLET |op| (|postAtom| (COND ((STRINGP |op|) (INTERN |op|)) ((QUOTE T) |op|)))) (CONS (QUOTE SIGNATURE) (CONS |op| (|removeSuperfluousMapping| (|killColons| |sig1|))))))))))) ;killColons x == ; atom x => x ; x is ['Record,:.] => x @@ -2582,13 +2531,6 @@ parse ;;; *** |killColons| REDEFINED (DEFUN |killColons| (|x|) (PROG (|ISTMP#1| |ISTMP#2| |y|) (RETURN (COND ((ATOM |x|) |x|) ((AND (PAIRP |x|) (EQ (QCAR |x|) (QUOTE |Record|))) |x|) ((AND (PAIRP |x|) (EQ (QCAR |x|) (QUOTE |Union|))) |x|) ((AND (PAIRP |x|) (EQ (QCAR |x|) (QUOTE |:|)) (PROGN (SPADLET |ISTMP#1| (QCDR |x|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) (QUOTE T))))))) (|killColons| |y|)) ((QUOTE T) (CONS (|killColons| (CAR |x|)) (|killColons| (CDR |x|)))))))) -;postSlash ['_/,a,b] == -; STRINGP a => postTran ['Reduce,INTERN a,b] -; ['_/,postTran a,postTran b] - -;;; *** |postSlash| REDEFINED - -(DEFUN |postSlash| (#0=#:G167699) (PROG (|a| |b|) (RETURN (PROGN (SPADLET |a| (CADR #0#)) (SPADLET |b| (CADDR #0#)) (COND ((STRINGP |a|) (|postTran| (CONS (QUOTE |Reduce|) (CONS (INTERN |a|) (CONS |b| NIL))))) ((QUOTE T) (CONS (QUOTE /) (CONS (|postTran| |a|) (CONS (|postTran| |b|) NIL))))))))) ;removeSuperfluousMapping sig1 == ; --get rid of this asap ; sig1 is [x,:y] and x is ['Mapping,:.] => [rest x,:y] @@ -2607,24 +2549,8 @@ parse ;;; *** |postType| REDEFINED (DEFUN |postType| (|typ|) (PROG (|source| |ISTMP#2| |ISTMP#1| |target|) (RETURN (COND ((AND (PAIRP |typ|) (EQ (QCAR |typ|) (QUOTE ->)) (PROGN (SPADLET |ISTMP#1| (QCDR |typ|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |source| (QCAR |ISTMP#1|)) (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) (PROGN (SPADLET |target| (QCAR |ISTMP#2|)) (QUOTE T))))))) (COND ((BOOT-EQUAL |source| (QUOTE |constant|)) (CONS (LIST (|postTran| |target|)) (CONS (QUOTE |constant|) NIL))) ((QUOTE T) (LIST (CONS (QUOTE |Mapping|) (CONS (|postTran| |target|) (|unTuple| (|postTran| |source|)))))))) ((AND (PAIRP |typ|) (EQ (QCAR |typ|) (QUOTE ->)) (PROGN (SPADLET |ISTMP#1| (QCDR |typ|)) (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) (PROGN (SPADLET |target| (QCAR |ISTMP#1|)) (QUOTE T))))) (LIST (CONS (QUOTE |Mapping|) (CONS (|postTran| |target|) NIL)))) ((QUOTE T) (LIST (|postTran| |typ|))))))) -;postTuple u == -; u is ['Tuple] => u -; u is ['Tuple,:l,a] => (['Tuple,:postTranList rest u]) - -;;; *** |postTuple| REDEFINED - -(DEFUN |postTuple| (|u|) (PROG (|ISTMP#1| |ISTMP#2| |a| |l|) (RETURN (COND ((AND (PAIRP |u|) (EQ (QCDR |u|) NIL) (EQ (QCAR |u|) (QUOTE |@Tuple|))) |u|) ((AND (PAIRP |u|) (EQ (QCAR |u|) (QUOTE |@Tuple|)) (PROGN (SPADLET |ISTMP#1| (QCDR |u|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) (QUOTE T)) (PAIRP |ISTMP#2|) (PROGN (SPADLET |a| (QCAR |ISTMP#2|)) (SPADLET |l| (QCDR |ISTMP#2|)) (QUOTE T)) (PROGN (SPADLET |l| (NREVERSE |l|)) (QUOTE T))))) (CONS (QUOTE |@Tuple|) (|postTranList| (CDR |u|)))))))) ;--u is ['Tuple,:l,a] => (--a:= postTran a; ['Tuple,:postTranList rest u]) ; --RDJ: don't understand need for above statement that is commented out -;postWhere ['where,a,b] == -; x:= -; b is ['Block,:c] => c -; LIST b -; ['where,postTran a,:postTranList x] - -;;; *** |postWhere| REDEFINED - -(DEFUN |postWhere| (#0=#:G167776) (PROG (|a| |b| |c| |x|) (RETURN (PROGN (SPADLET |a| (CADR #0#)) (SPADLET |b| (CADDR #0#)) (SPADLET |x| (COND ((AND (PAIRP |b|) (EQ (QCAR |b|) (QUOTE |Block|)) (PROGN (SPADLET |c| (QCDR |b|)) (QUOTE T))) |c|) ((QUOTE T) (LIST |b|)))) (CONS (QUOTE |where|) (CONS (|postTran| |a|) (|postTranList| |x|))))))) ;isPackageType x == not CONTAINED("$",x) ;;; *** |isPackageType| REDEFINED diff --git a/src/interp/vmlisp.lisp.pamphlet b/src/interp/vmlisp.lisp.pamphlet index 5a045e2..e638ee6 100644 --- a/src/interp/vmlisp.lisp.pamphlet +++ b/src/interp/vmlisp.lisp.pamphlet @@ -6834,40 +6834,6 @@ o there is some code at the end of SPECEVAL BOOT that puts "up" ;; (|xor| |parseExclusiveOr|) )) (MAKEPROP (CAR X) '|parseTran| (CADR X))) -(REPEAT (IN X '( -; (|with| |postWith|) - (|Scripts| |postScripts|) - (/ |postSlash|) -; (|construct| |postConstruct|) -; (|Block| |postBlock|) - (QUOTE |postQUOTE|) -; (COLLECT |postCollect|) -; (|:BF:| |postBigFloat|) -; (|in| |postin|) ;" the infix operator version of in" -; (IN |postIn|) ;" the iterator form of in" - (REPEAT |postRepeat|) - (|TupleCollect| |postTupleCollect|) -; (|add| |postAdd|) - (|Reduce| |postReduce|) -; (\, |postComma|) - (\; |postSemiColon|) - (|where| |postWhere|) -; (|::| |postColonColon|) -; (\: |postColon|) -; (@ |postAtSign|) - (|pretend| |postPretend|) -; (|if| |postIf|) -; (|Join| |postJoin|) - (|Signature| |postSignature|) -; (CATEGORY |postCategory|) -;;( |postDef|) -; (== |postDef|) -; (|==>| |postMDef|) -; (|->| |postMapping|) -; (|=>| |postExit|) - (|@Tuple| |postTuple|) -)) (MAKEPROP (CAR X) '|postTran| (CADR X))) - (MAKEPROP 'INTEGER 'ISFUNCTION 'INTEGERP) (MAKEPROP '|Integer| '|isFunction| '|IsInteger|) (MAKEPROP '|Boolean| '|isFunction| '|isBoolean|)