diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index 605c3ab..5f530fd 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -4928,6 +4928,20 @@ of the symbol being parsed. The original list read: \end{chunk} +\defun{parseType}{parseType} +\calls{parseType}{msubst} +\calls{parseType}{parseTran} +\begin{chunk}{defun parseType} +(defun |parseType| (x) + (declare (special |$EmptyMode| |$quadSymbol|)) + (setq x (msubst |$EmptyMode| |$quadSymbol| x)) + (if (and (pairp x) (eq (qcar x) '|typeOf|) + (pairp (qcdr x)) (eq (qcdr (qcdr x)) nil)) + (list '|typeOf| (|parseTran| (qcar (qcdr x)))) + x)) + +\end{chunk} + \defplist{category}{parseCategory} \begin{chunk}{postvars} (eval-when (eval load) @@ -4948,6 +4962,20 @@ of the symbol being parsed. The original list read: \end{chunk} +\defun{parseDropAssertions}{parseDropAssertions} +\calls{parseDropAssertions}{parseDropAssertions} +\begin{chunk}{defun parseDropAssertions} +(defun |parseDropAssertions| (x) + (cond + ((not (pairp x)) x) + ((and (pairp (qcar x)) (eq (qcar (qcar x)) 'if) + (pairp (qcdr (qcar x))) + (eq (qcar (qcdr (qcar x))) '|asserted|)) + (|parseDropAssertions| (qcdr x))) + (t (cons (qcar x) (|parseDropAssertions| (qcdr x)))))) + +\end{chunk} + \defplist{::}{parseCoerce} \begin{chunk}{postvars} (eval-when (eval load) @@ -11685,6 +11713,63 @@ Stack of results of reduced productions. \chapter{Utility Functions} +\defun{parseTranCheckForRecord}{parseTranCheckForRecord} +\begin{verbatim} +;parseTranCheckForRecord(x,op) == +; (x:= parseTran x) is ['Record,:l] => +; or/[y for y in l | y isnt [":",.,.]] => +; postError ['" Constructor",:bright x,'"has missing label"] +; x +; x +\end{verbatim} +\calls{parseTranCheckForRecord}{qcar} +\calls{parseTranCheckForRecord}{qcdr} +\calls{parseTranCheckForRecord}{postError} +\calls{parseTranCheckForRecord}{parseTran} +\begin{chunk}{defun parseTranCheckForRecord} +(defun |parseTranCheckForRecord| (x op) + (let (tmp3) + (setq x (|parseTran| x)) + (cond + ((and (pairp x) (eq (qcar x) '|Record|)) + (cond + ((do ((z nil tmp3) (tmp4 (qcdr x) (cdr tmp4)) (y nil)) + ((or z (atom tmp4)) tmp3) + (setq y (car tmp4)) + (cond + ((null (and (pairp y) (eq (qcar y) '|:|) (pairp (qcdr y)) + (pairp (qcdr (qcdr y))) (eq (qcdr (qcdr (qcdr y))) nil))) + (setq tmp3 (or tmp3 y))))) + (|postError| (list " Constructor" x "has missing label" ))) + (t x))) + (t x)))) + +\end{chunk} + + +\defun{new2OldLisp}{new2OldLisp} +\calls{new2OldLisp}{new2OldTran} +\calls{new2OldLisp}{postTransform} +\begin{chunk}{defun new2OldLisp} +(defun |new2OldLisp| (x) + (|new2OldTran| (|postTransform| x))) + +\end{chunk} + +\defun{makeSimplePredicateOrNil}{makeSimplePredicateOrNil} +\calls{makeSimplePredicateOrNil}{isSimple} +\calls{makeSimplePredicateOrNil}{isAlmostSimple} +\calls{makeSimplePredicateOrNil}{wrapSEQExit} +\begin{chunk}{defun makeSimplePredicateOrNil} +(defun |makeSimplePredicateOrNil| (p) + (let (u g) + (cond + ((|isSimple| p) nil) + ((setq u (|isAlmostSimple| p)) u) + (t (|wrapSEQExit| (list (list 'let (setq g (gensym)) p) g)))))) + +\end{chunk} + \defun{parse-spadstring}{parse-spadstring} \calls{parse-spadstring}{match-current-token} \calls{parse-spadstring}{token-symbol} @@ -14935,6 +15020,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun line-new-line} \getchunk{defun postMakeCons} +\getchunk{defun makeSimplePredicateOrNil} \getchunk{defun make-string-adjustable} \getchunk{defun make-symbol-of} \getchunk{defun match-advance-string} @@ -14945,11 +15031,12 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun meta-syntax-error} \getchunk{defun modifyModeStack} +\getchunk{defun ncINTERPFILE} \getchunk{defun next-char} \getchunk{defun next-line} \getchunk{defun next-tab-loc} \getchunk{defun next-token} -\getchunk{defun ncINTERPFILE} +\getchunk{defun new2OldLisp} \getchunk{defun nonblankloc} \getchunk{defun optional} @@ -15046,6 +15133,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun parseDollarGreaterThan} \getchunk{defun parseDollarLessEqual} \getchunk{defun parseDollarNotEqual} +\getchunk{defun parseDropAssertions} \getchunk{defun parseEquivalence} \getchunk{defun parseExit} \getchunk{defun postFlatten} @@ -15078,8 +15166,10 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun parseSegment} \getchunk{defun parseSeq} \getchunk{defun parseTran} +\getchunk{defun parseTranCheckForRecord} \getchunk{defun parseTranList} \getchunk{defun parseTransform} +\getchunk{defun parseType} \getchunk{defun parseVCONS} \getchunk{defun parseWhere} \getchunk{defun Pop-Reduction} diff --git a/changelog b/changelog index 1ddf6ce..cff6b3b 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20110311 tpd src/axiom-website/patches.html 20110311.01.tpd.patch +20110311 tpd src/interp/parsing.lisp treeshake compiler +20110311 tpd books/bookvol9 treeshake compiler 20110310 tpd src/axiom-website/patches.html 20110310.01.tpd.patch 20110310 tpd src/interp/parsing.lisp treeshake compiler 20110310 tpd books/bookvol9 treeshake compiler diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 96b705d..bc989b8 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3427,5 +3427,7 @@ books/bookvol9 treeshake compiler
books/bookvol9 treeshake compiler
20110310.01.tpd.patch books/bookvol9 treeshake compiler
+20110311.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/parsing.lisp.pamphlet b/src/interp/parsing.lisp.pamphlet index 2082639..a31ec0e 100644 --- a/src/interp/parsing.lisp.pamphlet +++ b/src/interp/parsing.lisp.pamphlet @@ -798,8 +798,6 @@ foo defined inside of fum gets renamed as fum,foo.") '((\QUAD . \.) (\' . QUOTE) (|nil| . NIL) (|append| . APPEND) (|union| . UNION) (|cons| . CONS))) -(defun |new2OldLisp| (x) (|new2OldTran| (|postTransform| x))) - (defun |new2OldTran| (x) (PROG (G10463 a b G10465 G10466 G10467 G10469 d G10470 c) (RETURN @@ -1197,33 +1195,6 @@ parse (DEFUN |transUnCons| (|u|) (PROG (|ISTMP#1| |x| |ISTMP#2| |y|) (RETURN (COND ((ATOM |u|) (|systemErrorHere| "transUnCons")) ((AND (PAIRP |u|) (EQ (QCAR |u|) (QUOTE APPEND)) (PROGN (SPADLET |ISTMP#1| (QCDR |u|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |x| (QCAR |ISTMP#1|)) (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) (QUOTE T))))))) (COND ((NULL |y|) |x|) ((QUOTE T) (|systemErrorHere| "transUnCons")))) ((AND (PAIRP |u|) (EQ (QCAR |u|) (QUOTE CONS)) (PROGN (SPADLET |ISTMP#1| (QCDR |u|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |x| (QCAR |ISTMP#1|)) (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) (QUOTE T))))))) (COND ((ATOM |y|) (CONS |x| |y|)) ((QUOTE T) (CONS |x| (|transUnCons| |y|))))))))) ; -; -; -; -;parseType x == -; x := substitute($EmptyMode,$quadSymbol,x) -; x is ['typeOf,val] => ['typeOf,parseTran val] -; x - -;;; *** |parseType| REDEFINED - -(defun |parseType| (x) - (let (tmp1 val) - (setq x (msubst |$EmptyMode| |$quadSymbol| x)) - (cond - ((and (pairp x) - (eq (qcar x) '|typeOf|) - (progn - (setq tmp1 (qcdr x)) - (and (pairp tmp1) - (eq (qcdr tmp1) nil) - (progn - (spadlet val (qcar tmp1)) - t)))) - (cons '|typeOf| (cons (|parseTran| val) nil))) - (t x)))) - -; ;parseTypeEvaluate form == ; form is [op,:argl] => ; newType? op => form @@ -1323,16 +1294,6 @@ parse ; ; ; -;parseTranCheckForRecord(x,op) == -; (x:= parseTran x) is ['Record,:l] => -; or/[y for y in l | y isnt [":",.,.]] => -; postError ['" Constructor",:bright x,'"has missing label"] -; x -; x - -;;; *** |parseTranCheckForRecord| REDEFINED - -(DEFUN |parseTranCheckForRecord| (|x| |op|) (PROG (|l| |ISTMP#1| |ISTMP#2|) (RETURN (SEQ (COND ((PROGN (SPADLET |ISTMP#1| (SPADLET |x| (|parseTran| |x|))) (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) (QUOTE |Record|)) (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) (QUOTE T)))) (COND ((PROG (#0=#:G166937) (SPADLET #0# NIL) (RETURN (DO ((#1=#:G166944 NIL #0#) (#2=#:G166945 |l| (CDR #2#)) (|y| NIL)) ((OR #1# (ATOM #2#) (PROGN (SETQ |y| (CAR #2#)) NIL)) #0#) (SEQ (EXIT (COND ((NULL (AND (PAIRP |y|) (EQ (QCAR |y|) (QUOTE |:|)) (PROGN (SPADLET |ISTMP#1| (QCDR |y|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL))))))) (SETQ #0# (OR #0# |y|))))))))) (|postError| (CONS " Constructor" (APPEND (|bright| |x|) (CONS "has missing label" NIL))))) ((QUOTE T) |x|))) ((QUOTE T) |x|)))))) ; ;parseCases [expr,ifClause] == ; casefn(expr,ifClause) where @@ -1350,16 +1311,6 @@ parse (DEFUN |parseCases| (#0=#:G167006) (PROG (|expr| |ifClause|) (RETURN (PROGN (SPADLET |expr| (CAR #0#)) (SPADLET |ifClause| (CADR #0#)) (|parseCases,casefn| |expr| |ifClause|))))) ; ; -;parseDropAssertions x == -;--note: the COPY of this list is necessary-- do not replace by RPLACing version -; x is [y,:r] => -; y is ['IF,'asserted,:.] => parseDropAssertions r -; [y,:parseDropAssertions r] -; x - -;;; *** |parseDropAssertions| REDEFINED - -(DEFUN |parseDropAssertions| (|x|) (PROG (|y| |r| |ISTMP#1|) (RETURN (COND ((AND (PAIRP |x|) (PROGN (SPADLET |y| (QCAR |x|)) (SPADLET |r| (QCDR |x|)) (QUOTE T))) (COND ((AND (PAIRP |y|) (EQ (QCAR |y|) (QUOTE IF)) (PROGN (SPADLET |ISTMP#1| (QCDR |y|)) (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) (QUOTE |asserted|))))) (|parseDropAssertions| |r|)) ((QUOTE T) (CONS |y| (|parseDropAssertions| |r|))))) ((QUOTE T) |x|))))) ; ; @@ -1377,24 +1328,6 @@ parse ;(DEFUN |parseExclusiveOr| (#0=#:G167140) (PROG (|a| |b|) (RETURN (PROGN (SPADLET |a| (CAR #0#)) (SPADLET |b| (CADR #0#)) (|parseIf| (CONS |a| (CONS (|parseIf| (CONS |b| (QUOTE (|false| |true|)))) (CONS |b| NIL)))))))) ; -; -; -; -; -; -; -;makeSimplePredicateOrNil p == -; isSimple p => nil -; u:= isAlmostSimple p => u -; true => wrapSEQExit [['LET,g:= GENSYM(),p],g] - -;;; *** |makeSimplePredicateOrNil| REDEFINED - -(DEFUN |makeSimplePredicateOrNil| (|p|) (PROG (|u| |g|) (RETURN (COND ((|isSimple| |p|) NIL) ((SPADLET |u| (|isAlmostSimple| |p|)) |u|) ((QUOTE T) (|wrapSEQExit| (CONS (CONS (QUOTE LET) (CONS (SPADLET |g| (GENSYM)) (CONS |p| NIL))) (CONS |g| NIL)))))))) -; -; -; -; ;transSeq l == ; null l => nil ; null rest l => decExitLevel first l