diff --git a/books/bookvol5.pamphlet b/books/bookvol5.pamphlet index 6349ed4..a30f4f2 100644 --- a/books/bookvol5.pamphlet +++ b/books/bookvol5.pamphlet @@ -3282,7 +3282,6 @@ contiguous comment spanning enough lines to overflow the stack. \defun{ifCond}{ifCond} \calls{ifCond}{MakeSymbol} \calls{ifCond}{incCommandTail} -\calls{ifCond}{ListMemberQ?} \usesdollar{ifCond}{inclAssertions} <>= (defun |ifCond| (s info) @@ -3290,7 +3289,7 @@ contiguous comment spanning enough lines to overflow the stack. (declare (special |$inclAssertions|)) (setq word (|MakeSymbol| (string-trim *whitespace* (|incCommandTail| s info)))) - (|ListMemberQ?| word |$inclAssertions|))) + (member word |$inclAssertions|))) @ @@ -3516,7 +3515,6 @@ contiguous comment spanning enough lines to overflow the stack. \defun{assertCond}{assertCond} \calls{assertCond}{MakeSymbol} \calls{assertCond}{incCommandTail} -\calls{assertCond}{ListMemberQ?} \usesdollar{assertCond}{inclAssertions} \uses{assertCond}{*whitespace*} <>= @@ -3525,7 +3523,7 @@ contiguous comment spanning enough lines to overflow the stack. (declare (special |$inclAssertions| *whitespace*)) (setq word (|MakeSymbol| (string-trim *whitespace* (|incCommandTail| s info)))) - (unless (|ListMemberQ?| word |$inclAssertions|) + (unless (member word |$inclAssertions|) (setq |$inclAssertions| (cons word |$inclAssertions|))))) @ @@ -8635,7 +8633,6 @@ the original Macro pform. \calls{macLambdaParameterHandling}{pfTypedId} \calls{macLambdaParameterHandling}{pf0LambdaArgs} \calls{macLambdaParameterHandling}{pfIdSymbol} -\calls{macLambdaParameterHandling}{AlistRemoveQ} \calls{macLambdaParameterHandling}{pfMLambda?} \calls{macLambdaParameterHandling}{pf0MLambdaArgs} \calls{macLambdaParameterHandling}{pfLeaf} @@ -8651,7 +8648,10 @@ the original Macro pform. ((|pfLambda?| pform) ; remove ( identifier . replacement ) from assoclist (setq parlist (mapcar #'|pfTypedId| (|pf0LambdaArgs| pform))) (setq symlist (mapcar #'|pfIdSymbol| parlist)) - (dolist (par symlist) (setq replist (|AlistRemoveQ| par replist))) + (dolist (par symlist) + (setq replist + (let ((pr (assoc par replist :test #'equal))) + (if pr (remove par replist :test #'equal) l)))) replist) ((|pfMLambda?| pform) ;construct assoclist ( identifier . replacement ) (setq parlist (|pf0MLambdaArgs| pform)) ; extract parameter list @@ -8667,12 +8667,11 @@ the original Macro pform. @ \defun{macSubstituteId}{macSubstituteId} -\calls{macSubstituteId}{AlistAssocQ} \calls{macSubstituteId}{pfIdSymbol} <>= (defun |macSubstituteId| (replist pform) (let (ex) - (setq ex (|AlistAssocQ| (|pfIdSymbol| pform) replist)) + (setq ex (assoc (|pfIdSymbol| pform) replist :test #'eq)) (cond (ex (rplpair pform (cdr ex)) diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index 80a1e06..9691716 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -8932,41 +8932,6 @@ of the symbol being parsed. The original list read: @ -\defun{deftran}{deftran} -This two-level call allows DEF-RENAME to be locally bound to do -nothing (see boot2Lisp) yet still allow function call (lisp2BootAndComp). -\calls{deftran}{} -\usesdollar{deftran}{macroassoc} -<>= -(defun deftran (x) - (let (op y) - (cond - ((stringp x) (def-string x)) - ((identp x) (cond ((lassoc x $macroassoc)) (x))) - ((atom x) x) - ((eq (setq op (first x)) 'where) (def-where (cdr x))) - ((eq op 'repeat) (def-repeat (cdr x))) - ((eq op 'collect) (def-collect (cdr x))) - ((eq op 'makestring) - (cond ((stringp (second x)) x) - ((eqcar (second x) 'quote) - (list 'makestring (stringimage (cadadr x)))) - ((list 'makestring (deftran (second x)))))) - ((eq op 'quote) - (if (stringp (setq y (second x))) (list 'makestring y) - (if (and (identp y) (char= (elt (pname y) 0) #\.)) - `(intern ,(pname y) ,(package-name *package*)) x))) - ((eq op 'is) (|defIS| (second x) (third x))) - ((eq op 'spadlet) (def-let (second x) (third x))) - ((eq op 'dcq) (list 'dcq (second x) (deftran (third x)))) - ((eq op 'cond) (cons 'cond (def-cond (cdr x)))) - ((member (first x) '(|sayBrightly| say moan croak) :test #'eq) - (def-message x)) - ((setq y (getl (first x) 'def-tran)) - (funcall y (mapcar #'deftran (cdr x)))) - ((mapcar #'deftran x))))) - -@ \defun{def-process}{def-process} \calls{def-process}{def} \calls{def-process}{b-mdef} @@ -9861,6 +9826,84 @@ 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 + +\end{verbatim} + +\defun{deftran}{deftran} +This two-level call allows DEF-RENAME to be locally bound to do +nothing (see boot2Lisp) yet still allow function call (lisp2BootAndComp). +\calls{deftran}{} +\usesdollar{deftran}{macroassoc} +<>= +(defun deftran (x) + (let (op y) + (cond + ((stringp x) (def-string x)) + ((identp x) (cond ((lassoc x $macroassoc)) (x))) + ((atom x) x) + ((eq (setq op (first x)) 'where) (def-where (cdr x))) + ((eq op 'repeat) (def-repeat (cdr x))) + ((eq op 'collect) (def-collect (cdr x))) + ((eq op 'makestring) + (cond ((stringp (second x)) x) + ((eqcar (second x) 'quote) + (list 'makestring (stringimage (cadadr x)))) + ((list 'makestring (deftran (second x)))))) + ((eq op 'quote) + (if (stringp (setq y (second x))) (list 'makestring y) + (if (and (identp y) (char= (elt (pname y) 0) #\.)) + `(intern ,(pname y) ,(package-name *package*)) x))) + ((eq op 'is) (|defIS| (second x) (third x))) + ((eq op 'spadlet) (def-let (second x) (third x))) + ((eq op 'dcq) (list 'dcq (second x) (deftran (third x)))) + ((eq op 'cond) (cons 'cond (def-cond (cdr x)))) + ((member (first x) '(|sayBrightly| say moan croak) :test #'eq) + (def-message x)) + ((setq y (getl (first x) 'def-tran)) + (funcall y (mapcar #'deftran (cdr x)))) + ((mapcar #'deftran x))))) + +@ + +\defplist{category}{def-category} +<>= +(eval-when (eval load) + (setf (get 'category 'def-tran) 'def-category)) + +@ + +\defun{def-category}{def-category} +\calls{def-category}{eqcar} +\calls{def-category}{kadr} +<>= +(defun def-category (l) + (let (siglist atlist) + (mapcar #'(lambda (x) + (if (eqcar (kadr X) 'signature) + (push x siglist) + (push x atlist))) + l) + (list 'category (mkq (nreverse siglist)) (mkq (nreverse atlist))))) + +@ + \chapter{PARSE forms} \section{The original meta specification} This package provides routines to support the Metalanguage @@ -14981,6 +15024,7 @@ if \verb|$InteractiveMode| then use a null outputstream <> <> <> +<> <> <> <> diff --git a/changelog b/changelog index ed43a50..99f7cb7 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,9 @@ +20101219 tpd src/axiom-website/patches.html 20101219.02.tpd.patch +20101219 tpd src/interp/vmlisp.lisp cleaning +20101219 tpd src/interp/parsing.lisp cleaning vmlisp +20101219 tpd src/interp/msgdb.lisp cleaning vmlisp +20101219 tpd books/bookvol9 cleaning vmlisp +20101219 tpd books/bookvol5 cleaning vmlisp 20101219 tpd src/axiom-website/patches.html 20101219.01.tpd.patch 20101219 tpd src/interp/vmlisp.lisp cleaning vmlisp 20101219 tpd books/bookvol5 cleaning vmlisp diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 094018b..7c6050e 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3325,5 +3325,7 @@ src/interp/vmlisp.lisp cleaning vmlisp
src/interp/vmlisp.lisp cleaning vmlisp
20101219.01.tpd.patch src/interp/vmlisp.lisp cleaning vmlisp
+20101219.02.tpd.patch +src/interp/vmlisp.lisp cleaning vmlisp
diff --git a/src/interp/msgdb.lisp.pamphlet b/src/interp/msgdb.lisp.pamphlet index 34b4f3b..491860c 100644 --- a/src/interp/msgdb.lisp.pamphlet +++ b/src/interp/msgdb.lisp.pamphlet @@ -1110,7 +1110,7 @@ (SPADLET |ISTMP#1| (QCAR |msg|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |ce| (QCAR |ISTMP#1|)) 'T))) - (|ListMember?| |ce| '(|%ce| "%ce"))) + (member |ce| '(|%ce| "%ce") :test #'equal)) |msg|) ('T (SPADLET |potentialMarg| 0) (SPADLET |actualMarg| 0) (SPADLET |off| diff --git a/src/interp/parsing.lisp.pamphlet b/src/interp/parsing.lisp.pamphlet index 83ed03a..5c4372c 100644 --- a/src/interp/parsing.lisp.pamphlet +++ b/src/interp/parsing.lisp.pamphlet @@ -668,9 +668,6 @@ bootlex (init-boot/spad-reader) (let* ((Boot-Line-Stack (PREPARSE in-stream)) (parseout (prog2 (|PARSE-Expression|) (pop-stack-1)) ) ) - ;(setq parseout (|new2OldLisp| parseout)) - ; (setq parseout (DEF-RENAME parseout)) - ; (DEF-PROCESS parseout) parseout)) ;; note that this is no longer called or used. Boot has been removed. @@ -1019,7 +1016,7 @@ foo defined inside of fum gets renamed as fum,foo.") (mapcar #'(lambda (x) (MAKEPROP (CAR X) 'RENAME (CDR X))) '((|true| 'T) (|otherwise| 'T) (|false| NIL) (|and| AND) (|or| OR) (|is| IS) - (|list| LIST) (|cons| CONS) (|car| CAR) (|cdr| CDR) + (|list| LIST) (|cons| CONS) (|setDifference| SETDIFFERENCE) (INTERSECTION |intersection|) (|setIntersection| |intersection|) (|setUnion| |union|) (UNION |union|) (REMOVE |remove|) (MEMBER |member|) (ASSOC |assoc|) @@ -1161,17 +1158,6 @@ foo defined inside of fum gets renamed as fum,foo.") (LIST 'CATEGORY (MKQ (NREVERSE SIGLIST)) (MKQ (NREVERSE ATLIST))))) -(defun LIST2STRING (X) -"Converts a list to a string which looks like a printed list, -except that elements are separated by commas." - (COND ((ATOM X) (STRINGIMAGE X)) - ((STRCONC "(" (LIST2STRING (FIRST X)) (LIST2STRING1 (CDR X)) ")")))) - -(defun LIST2STRING1 (X) - (COND - ((NOT X) "") - ((STRCONC "\," (LIST2STRING (FIRST X)) (LIST2STRING1 (CDR X)))))) - (defvar |$new2OldRenameAssoc| '((\QUAD . \.) (\' . QUOTE) (|nil| . NIL) (|append| . APPEND) (|union| . UNION) (|cons| . CONS))) diff --git a/src/interp/vmlisp.lisp.pamphlet b/src/interp/vmlisp.lisp.pamphlet index f976cfa..bb41b92 100644 --- a/src/interp/vmlisp.lisp.pamphlet +++ b/src/interp/vmlisp.lisp.pamphlet @@ -2055,14 +2055,6 @@ do the compile, and then rename the result back to code.o. (in-package 'boot) -;;--------------------> NEW DEFINITION (see unlisp.lisp.pamphlet) -(defun |AlistAssocQ| (key l) - (assoc key l :test #'eq) ) - -;;--------------------> NEW DEFINITION (see unlisp.lisp.pamphlet) -(defun |ListMember?| (ob l) - (member ob l :test #'equal) ) - (defvar *npPCff* nil "rewrite flets, using global scoping") (defun npPCff () (and (funcall *npPCff*) (|npPush| (list (|npPop1|))))) (defun npPCg () @@ -6270,7 +6262,7 @@ o there is some code at the end of SPECEVAL BOOT that puts "up" (|<| DEF-LESSP) (REPEAT DEF-REPEAT) ;;(|TRACE,LET| DEF-TRACE-LET) - (CATEGORY DEF-CATEGORY) +; (CATEGORY DEF-CATEGORY) (EQUAL DEF-EQUAL) (|is| DEF-IS) (SEQ DEF-SEQ) @@ -6331,9 +6323,6 @@ o there is some code at the end of SPECEVAL BOOT that puts "up" (|Enumeration| |mkEnumerationFunList|) )) (MAKEPROP (CAR X) '|makeFunctionList| (CADR X))) -; (SEGMENT |parseSegment|) -;; (|xor| |parseExclusiveOr|) - (MAKEPROP 'INTEGER 'ISFUNCTION 'INTEGERP) (MAKEPROP '|Integer| '|isFunction| '|IsInteger|) (MAKEPROP '|Boolean| '|isFunction| '|isBoolean|) @@ -6346,8 +6335,6 @@ o there is some code at the end of SPECEVAL BOOT that puts "up" (|apply| APPLY) (|atom| ATOM) (|brace| REMDUP) - (|car| CAR) - (|cdr| CDR) (|cons| CONS) (|copy| COPY) (|croak| CROAK) @@ -7052,159 +7039,6 @@ o there is some code at the end of SPECEVAL BOOT that puts "up" (defmacro |car| (x) `(car ,x)) (defmacro |cdr| (x) `(cdr ,x)) -(defmacro |caar| (x) `(caar ,x)) -(defmacro |cadr| (x) `(cadr ,x)) -(defmacro |cdar| (x) `(cdar ,x)) -(defmacro |cddr| (x) `(cddr ,x)) - -(defmacro |caaar| (x) `(caaar ,x)) -(defmacro |caadr| (x) `(caadr ,x)) -(defmacro |cadar| (x) `(cadar ,x)) -(defmacro |caddr| (x) `(caddr ,x)) -(defmacro |cdaar| (x) `(cdaar ,x)) -(defmacro |cdadr| (x) `(cdadr ,x)) -(defmacro |cddar| (x) `(cddar ,x)) -(defmacro |cdddr| (x) `(cdddr ,x)) - -(defmacro |FastCar| (x) `(car (the cons ,x))) -(defmacro |FastCdr| (x) `(cdr (the cons ,x))) - -(defmacro |FastCaar| (x) `(|FastCar| (|FastCar| ,x))) -(defmacro |FastCadr| (x) `(|FastCar| (|FastCdr| ,x))) -(defmacro |FastCdar| (x) `(|FastCdr| (|FastCar| ,x))) -(defmacro |FastCddr| (x) `(|FastCdr| (|FastCdr| ,x))) - -(defmacro |FastCaaar| (x) `(|FastCar| (|FastCaar| ,x))) -(defmacro |FastCaadr| (x) `(|FastCar| (|FastCadr| ,x))) -(defmacro |FastCadar| (x) `(|FastCar| (|FastCdar| ,x))) -(defmacro |FastCaddr| (x) `(|FastCar| (|FastCddr| ,x))) -(defmacro |FastCdaar| (x) `(|FastCdr| (|FastCaar| ,x))) -(defmacro |FastCdadr| (x) `(|FastCdr| (|FastCadr| ,x))) -(defmacro |FastCddar| (x) `(|FastCdr| (|FastCdar| ,x))) -(defmacro |FastCdddr| (x) `(|FastCdr| (|FastCddr| ,x))) - -(defmacro |IfCar| (x) `(if (consp ,x) (car ,x))) -(defmacro |IfCdr| (x) `(if (consp ,x) (cdr ,x))) - -(defmacro |EqCar| (l a) `(eq (car ,l) ,a)) -(defmacro |EqCdr| (l d) `(eq (cdr ,l) ,d)) - -;;; -;;; Lists -;;; - - -(defun |ListNReverse| (l) - (nreverse l) ) - -(defun |ListIsLength?| (l n) - (if l (= n 0) (|ListIsLength?| (cdr l) (1- n))) ) - -;;--------------------> NEW DEFINITION (override in vmlisp.lisp.pamphlet) -(defun |ListMemberQ?| (ob l) - (member ob l :test #'eq) ) - -(defun |ListMember?| (ob l) - (member ob l :test #'equal) ) - -(defun |ListRemoveQ| (ob l) - (remove ob l :test #'eq :count 1) ) - -(defun |ListNRemoveQ| (ob l) - (delete ob l :test #'eq :count 1) ) - -(defun |ListRemoveDuplicatesQ| (l) - (remove-duplicates l :test #'eq) ) - -(defun |ListUnion| (l1 l2) - (union l1 l2 :test #'equal) ) - -(defun |ListUnionQ| (l1 l2) - (union l1 l2 :test #'eq) ) - -(defun |ListIntersection| (l1 l2) - (intersection l1 l2 :test #'equal) ) - -(defun |ListIntersectionQ| (l1 l2) - (intersection l1 l2 :test #'eq) ) - -(defun |ListAdjoin| (ob l) - (adjoin ob l :test #'equal) ) - -(defun |ListAdjoinQ| (ob l) - (adjoin ob l :test #'eq) ) - -;;; -;;; Association lists -;;; - - -(defun |AlistAssoc| (key l) - (assoc key l :test #'equal) ) - -;;--------------------> NEW DEFINITION (override in vmlisp.lisp.pamphlet) -(defun |AlistAssocQ| (key l) - (assoc key l :test #'eq) ) - -(defun |AlistRemove| (key l) - (let ((pr (assoc key l :test #'equal))) - (if pr - (remove pr l :test #'equal) - l) )) - -(defun |AlistRemoveQ| (key l) - (let ((pr (assoc key l :test #'eq))) - (if pr - (remove pr l :test #'eq) - l) )) - -(defun |AlistAdjoinQ| (pr l) - (cons pr (|AlistRemoveQ| (car pr) l)) ) - -(defun |AlistUnionQ| (l1 l2) - (union l1 l2 :test #'eq :key #'car) ) - -;;; -;;; Tables -;;; - -;;(defmacro |EqTable| () -;; `(make-hash-table :test #'eq) ) -;;(defmacro |EqualTable| () -;; `(make-hash-table :test #'equal) ) -;;(defmacro |StringTable| () -;; `(make-hash-table :test #'equal) ) -;; following is not used and causes CCL problems -;;(defmacro |SymbolTable| () -;; `(make-hash-table :test #'eq) ) - - -(defmacro |Table?| (ob) - `(hash-table-p ,ob) ) - -(defmacro |TableCount| (tab) - `(hash-table-count ,tab) ) - -(defmacro |TableGet| (tab key &rest default) - `(gethash ,key ,tab ,@default) ) - -(defmacro |TableSet| (tab key val) - `(setf (gethash ,key ,tab) ,val) ) - -(defun |TableUnset| (tab key) - (let ((val (gethash key tab))) - (remhash key tab) - val )) - -(defun |TableKeys| (tab) - (let ((key-list nil)) - (maphash - #'(lambda (key val) (declare (ignore val)) - (setq key-list (cons key key-list)) ) - tab ) - key-list )) - -(defun log10 (u) (log u 10)) @ \eject