diff --git a/pcl/boot.lisp b/pcl/boot.lisp index e388f857f976258e399809c337cf302f55af46d5..b0819bc93a4ae7a7190aa6642ff60639d2595bae 100644 --- a/pcl/boot.lisp +++ b/pcl/boot.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.27 2002/03/12 16:22:23 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.28 2002/08/26 02:23:10 pmai Exp $") (in-package :pcl) @@ -103,8 +103,8 @@ work during bootstrapping. (defun redirect-early-function-internal (real early) (setf (gdefinition real) (set-function-name - #'(lambda (&rest args) - (apply (the function (symbol-function early)) args)) + (lambda (&rest args) + (apply (the function (symbol-function early)) args)) real))) (dolist (fns *early-functions*) @@ -328,8 +328,8 @@ work during bootstrapping. (class-name (class-of proto-method)) 'standard-method) initargs-form - (getf (getf initargs ':plist) - ':pv-table-symbol)))))))) + (getf (getf initargs :plist) + :pv-table-symbol)))))))) (defun interned-symbol-p (x) (and (symbolp x) (symbol-package x))) @@ -342,16 +342,16 @@ work during bootstrapping. (and (eq (car name) 'setf) (cadr name)) name)) (every #'interned-symbol-p qualifiers) - (every #'(lambda (s) - (if (consp s) - (and (eq (car s) 'eql) - (constantp (cadr s)) - (let ((sv (eval (cadr s)))) - (or (interned-symbol-p sv) - (integerp sv) - (and (characterp sv) - (standard-char-p sv))))) - (interned-symbol-p s))) + (every (lambda (s) + (if (consp s) + (and (eq (car s) 'eql) + (constantp (cadr s)) + (let ((sv (eval (cadr s)))) + (or (interned-symbol-p sv) + (integerp sv) + (and (characterp sv) + (standard-char-p sv))))) + (interned-symbol-p s))) specializers) (consp initargs-form) (eq (car initargs-form) 'list*) @@ -360,12 +360,12 @@ work during bootstrapping. (eq (car fn) 'function) (consp (setq fn-lambda (cadr fn))) (eq (car fn-lambda) 'lambda)) - (let* ((specls (mapcar #'(lambda (specl) - (if (consp specl) - `(,(car specl) ,(eval (cadr specl))) - specl)) + (let* ((specls (mapcar (lambda (specl) + (if (consp specl) + `(,(car specl) ,(eval (cadr specl))) + specl)) specializers)) - (mname `(,(if (eq (cadr initargs-form) ':function) + (mname `(,(if (eq (cadr initargs-form) :function) 'method 'fast-method) ,name ,@qualifiers ,specls)) (mname-sym (intern (let ((*print-pretty* nil)) @@ -383,10 +383,10 @@ work during bootstrapping. *defmethod-times* (make-defmethod-form-internal name qualifiers - `(list ,@(mapcar #'(lambda (specializer) - (if (consp specializer) - ``(,',(car specializer) ,,(cadr specializer)) - `',specializer)) + `(list ,@(mapcar (lambda (specializer) + (if (consp specializer) + ``(,',(car specializer) ,,(cadr specializer)) + `',specializer)) specializers)) unspecialized-lambda-list method-class-name initargs-form @@ -461,7 +461,7 @@ work during bootstrapping. (multiple-value-bind (parameters lambda-list specializers) (parse-specialized-lambda-list specialized-lambda-list) (let* ((required-parameters - (mapcar #'(lambda (r s) (declare (ignore s)) r) + (mapcar (lambda (r s) (declare (ignore s)) r) parameters specializers)) (slots (mapcar #'list required-parameters)) @@ -475,9 +475,9 @@ work during bootstrapping. (class-declarations `(declare ,@(remove nil - (mapcar #'(lambda (a s) (and (symbolp s) - (neq s 't) - `(class ,a ,s))) + (mapcar (lambda (a s) (and (symbolp s) + (neq s t) + `(class ,a ,s))) parameters specializers)))) (method-lambda @@ -519,7 +519,7 @@ work during bootstrapping. (extract-declarations (cddr walked-lambda)) (declare (ignore ignore)) (when (or next-method-p-p call-next-method-p) - (setq plist (list* :needs-next-methods-p 't plist))) + (setq plist (list* :needs-next-methods-p t plist))) (when (some #'cdr slots) (multiple-value-bind (slot-name-lists call-list) (slot-name-lists-from-slots slots calls) @@ -784,23 +784,23 @@ work during bootstrapping. (fast-method-call (let* ((arg-info (gf-arg-info gf)) (nreq (arg-info-number-required arg-info)) (restp (arg-info-applyp arg-info))) - #'(lambda (&rest args) - #+copy-&rest-arg (setq args (copy-list args)) - (trace-emf-call emf t args) - (apply (fast-method-call-function emf) - (fast-method-call-pv-cell emf) - (fast-method-call-next-method-call emf) - (if restp - (let* ((rest-args (nthcdr nreq args)) - (req-args (ldiff args rest-args))) - (nconc req-args rest-args)) - args))))) - (method-call #'(lambda (&rest args) - #+copy-&rest-arg (setq args (copy-list args)) - (trace-emf-call emf t args) - (apply (method-call-function emf) - args - (method-call-call-method-args emf)))) + (lambda (&rest args) + #+copy-&rest-arg (setq args (copy-list args)) + (trace-emf-call emf t args) + (apply (fast-method-call-function emf) + (fast-method-call-pv-cell emf) + (fast-method-call-next-method-call emf) + (if restp + (let* ((rest-args (nthcdr nreq args)) + (req-args (ldiff args rest-args))) + (nconc req-args rest-args)) + args))))) + (method-call (lambda (&rest args) + #+copy-&rest-arg (setq args (copy-list args)) + (trace-emf-call emf t args) + (apply (method-call-function emf) + args + (method-call-call-method-args emf)))) (function emf))) (defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call) @@ -937,21 +937,21 @@ work during bootstrapping. (next-method-p-p nil)) ;flag indicating that next-method-p ;should be in the method definition (flet ((walk-function (form context env) - (cond ((not (eq context ':eval)) form) + (cond ((not (eq context :eval)) form) ((not (listp form)) form) ((eq (car form) 'call-next-method) - (setq call-next-method-p 't) + (setq call-next-method-p t) form) ((eq (car form) 'next-method-p) - (setq next-method-p-p 't) + (setq next-method-p-p t) form) ((and (eq (car form) 'function) (cond ((eq (cadr form) 'call-next-method) - (setq call-next-method-p 't) + (setq call-next-method-p t) (setq closurep t) form) ((eq (cadr form) 'next-method-p) - (setq next-method-p-p 't) + (setq next-method-p-p t) (setq closurep t) form) (t nil)))) @@ -1015,20 +1015,17 @@ work during bootstrapping. (dolist (decl (cdar declarations)) (when (and (eq (car decl) 'ignore) (memq symbol (cdr decl))) - (return t))))) - (gathering ((references (collecting))) - (iterate ((s (list-elements specialized-lambda-list)) - (p (list-elements required-parameters))) - (progn p) - (cond ((not (listp s))) - ((ignoredp (car s)) - (warn "In defmethod ~S, there is a~%~ - redundant ignore declaration for the parameter ~S." - method-name - specializers - (car s))) - (t - (gather (car s) references))))))) + (return t))))) + (loop for s in specialized-lambda-list + and p in required-parameters + when (listp s) + if (ignoredp (car s)) do + (warn "In defmethod ~S, there is a~%~ + redundant ignore declaration for the parameter ~S." + method-name specializers (car s)) + else + collect (car s)))) + (defvar *method-function-plist* (make-hash-table :test #'eq)) @@ -1084,16 +1081,16 @@ work during bootstrapping. (defun load-defmethod (class name quals specls ll initargs &optional pv-table-symbol) (setq initargs (copy-tree initargs)) - (let ((method-spec (or (getf initargs ':method-spec) + (let ((method-spec (or (getf initargs :method-spec) (make-method-spec name quals specls)))) - (setf (getf initargs ':method-spec) method-spec) + (setf (getf initargs :method-spec) method-spec) (load-defmethod-internal class name quals specls ll initargs pv-table-symbol))) (defun load-defmethod-internal (method-class gf-spec qualifiers specializers lambda-list initargs pv-table-symbol) (when pv-table-symbol - (setf (getf (getf initargs ':plist) :pv-table-symbol) + (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)) (let ((method (apply #'add-named-method gf-spec qualifiers specializers lambda-list @@ -1118,12 +1115,12 @@ work during bootstrapping. `(method ,gf-spec ,@qualifiers ,unparsed-specializers)) (defun initialize-method-function (initargs &optional return-function-p method) - (let* ((mf (getf initargs ':function)) - (method-spec (getf initargs ':method-spec)) - (plist (getf initargs ':plist)) - (pv-table-symbol (getf plist ':pv-table-symbol)) + (let* ((mf (getf initargs :function)) + (method-spec (getf initargs :method-spec)) + (plist (getf initargs :plist)) + (pv-table-symbol (getf plist :pv-table-symbol)) (pv-table nil) - (mff (getf initargs ':fast-function))) + (mff (getf initargs :fast-function))) (flet ((set-mf-property (p v) (when mf (setf (method-function-get mf p) v)) @@ -1180,10 +1177,10 @@ work during bootstrapping. (if (memq x lambda-list-keywords) (case x (&optional (setq state 'optional)) - (&key (setq keysp 't + (&key (setq keysp t state 'key)) - (&allow-other-keys (setq allow-other-keys-p 't)) - (&rest (setq restp 't + (&allow-other-keys (setq allow-other-keys-p t)) + (&rest (setq restp t state 'rest)) (&aux (return t)) (otherwise @@ -1218,16 +1215,16 @@ work during bootstrapping. (old-keysp (and old-ftype (c::function-type-keyp old-ftype))) (old-allowp (and old-ftype (c::function-type-allowp old-ftype))) (keywords (union old-keys (mapcar #'keyword-spec-name keywords)))) - `(function ,(append (make-list nrequired :initial-element 't) + `(function ,(append (make-list nrequired :initial-element t) (when (plusp noptional) (append '(&optional) - (make-list noptional :initial-element 't))) + (make-list noptional :initial-element t))) (when (or restp old-restp) '(&rest t)) (when (or keysp old-keysp) (append '(&key) - (mapcar #'(lambda (key) - `(,key t)) + (mapcar (lambda (key) + `(,key t)) keywords) (when (or allow-other-keys-p old-allowp) '(&allow-other-keys))))) @@ -1280,13 +1277,13 @@ work during bootstrapping. 'standard-generic-function)) (defvar *sgf-slots-init* - (mapcar #'(lambda (canonical-slot) - (if (memq (getf canonical-slot :name) '(arg-info source)) - *slot-unbound* - (let ((initfunction (getf canonical-slot :initfunction))) - (if initfunction - (funcall initfunction) - *slot-unbound*)))) + (mapcar (lambda (canonical-slot) + (if (memq (getf canonical-slot :name) '(arg-info source)) + *slot-unbound* + (let ((initfunction (getf canonical-slot :initfunction))) + (if initfunction + (funcall initfunction) + *slot-unbound*)))) (early-collect-inheritance 'standard-generic-function))) (defvar *sgf-method-class-index* @@ -1344,7 +1341,7 @@ work during bootstrapping. (length (arg-info-metatypes arg-info))) (defun arg-info-nkeys (arg-info) - (count-if #'(lambda (x) (neq x 't)) (arg-info-metatypes arg-info))) + (count-if (lambda (x) (neq x t)) (arg-info-metatypes arg-info))) ;;; Keep pages clean by not setting if the value is already the same. (defmacro esetf (pos val) @@ -1366,7 +1363,7 @@ work during bootstrapping. (when (and (not lambda-list-p) methods) (setq lambda-list (gf-lambda-list gf))) (when (or lambda-list-p - (and first-p (eq (arg-info-lambda-list arg-info) ':no-lambda-list))) + (and first-p (eq (arg-info-lambda-list arg-info) :no-lambda-list))) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) (analyze-lambda-list lambda-list) (when (and methods (not first-p)) @@ -1424,7 +1421,7 @@ work during bootstrapping. (when (consp gf-keywords) (unless (or (and restp (not keysp)) allow-other-keys-p - (every #'(lambda (k) (memq k keywords)) gf-keywords)) + (every (lambda (k) (memq k keywords)) gf-keywords)) (lose "the method does not accept each of the keyword arguments~%~ ~S." gf-keywords))))))) @@ -1586,7 +1583,7 @@ work during bootstrapping. (let ((arg-info (if (eq *boot-state* 'complete) (gf-arg-info gf) (early-gf-arg-info gf)))) - (if (eq ':no-lambda-list (arg-info-lambda-list arg-info)) + (if (eq :no-lambda-list (arg-info-lambda-list arg-info)) (let ((methods (if (eq *boot-state* 'complete) (generic-function-methods gf) (early-gf-methods gf)))) @@ -1673,7 +1670,7 @@ work during bootstrapping. metatypes arg-info)) (values (length metatypes) applyp metatypes - (count-if #'(lambda (x) (neq x 't)) metatypes) + (count-if (lambda (x) (neq x t)) metatypes) arg-info))) (defun early-make-a-method (class qualifiers arglist specializers initargs doc @@ -1689,17 +1686,17 @@ work during bootstrapping. ;; Note that the use of not symbolp in this call to every should be ;; read as 'classp' we can't use classp itself because it doesn't ;; exist yet. - (if (every #'(lambda (s) (not (symbolp s))) specializers) + (if (every (lambda (s) (not (symbolp s))) specializers) (setq parsed specializers - unparsed (mapcar #'(lambda (s) - (if (eq s 't) 't (class-name s))) + unparsed (mapcar (lambda (s) + (if (eq s t) t (class-name s))) specializers)) (setq unparsed specializers parsed ())) (list :early-method ;This is an early method dammit! - (getf initargs ':function) - (getf initargs ':fast-function) + (getf initargs :function) + (getf initargs :fast-function) parsed ;The parsed specializers. This is used ;by early-method-specializers to cache @@ -1761,7 +1758,7 @@ work during bootstrapping. (defun early-method-specializers (early-method &optional objectsp) (if (and (listp early-method) (eq (car early-method) :early-method)) - (cond ((eq objectsp 't) + (cond ((eq objectsp t) (or (fourth early-method) (setf (fourth early-method) (mapcar #'find-class (cadddr (fifth early-method)))))) @@ -1836,7 +1833,7 @@ work during bootstrapping. (or (dolist (m (early-gf-methods generic-function)) (when (and (or (equal (early-method-specializers m nil) specializers) - (equal (early-method-specializers m 't) + (equal (early-method-specializers m t) specializers)) (equal (early-method-qualifiers m) qualifiers)) (return m))) @@ -1880,11 +1877,11 @@ work during bootstrapping. (dolist (early-gf-spec *early-generic-functions*) (when noisyp (format t "~&~S..." early-gf-spec)) (let* ((gf (gdefinition early-gf-spec)) - (methods (mapcar #'(lambda (early-method) - (let ((args (copy-list (fifth early-method)))) - (setf (fourth args) - (early-method-specializers early-method t)) - (apply #'real-make-a-method args))) + (methods (mapcar (lambda (early-method) + (let ((args (copy-list (fifth early-method)))) + (setf (fourth args) + (early-method-specializers early-method t)) + (apply #'real-make-a-method args))) (early-gf-methods gf)))) (setf (generic-function-method-class gf) *the-class-standard-method*) (setf (generic-function-method-combination gf) *standard-method-combination*) @@ -1896,26 +1893,26 @@ work during bootstrapping. (dolist (fixup *generic-function-fixups*) (let* ((fspec (car fixup)) (gf (gdefinition fspec)) - (methods (mapcar #'(lambda (method) - (let* ((lambda-list (first method)) - (specializers (second method)) - (method-fn-name (third method)) - (fn-name (or method-fn-name fspec)) - (fn (symbol-function fn-name)) - (initargs - (list :function - (set-function-name - #'(lambda (args next-methods) - (declare (ignore next-methods)) - (apply fn args)) - `(call ,fn-name))))) - (declare (type function fn)) - (make-a-method 'standard-method - () - lambda-list - specializers - initargs - nil))) + (methods (mapcar (lambda (method) + (let* ((lambda-list (first method)) + (specializers (second method)) + (method-fn-name (third method)) + (fn-name (or method-fn-name fspec)) + (fn (symbol-function fn-name)) + (initargs + (list :function + (set-function-name + (lambda (args next-methods) + (declare (ignore next-methods)) + (apply fn args)) + `(call ,fn-name))))) + (declare (type function fn)) + (make-a-method 'standard-method + () + lambda-list + specializers + initargs + nil))) (cdr fixup)))) (setf (generic-function-method-class gf) *the-class-standard-method*) (setf (generic-function-method-combination gf) *standard-method-combination*) @@ -2064,7 +2061,7 @@ work during bootstrapping. (parse-specialized-lambda-list (cdr arglist)) (values (cons (if (listp arg) (car arg) arg) parameters) (cons (if (listp arg) (car arg) arg) lambda-list) - (cons (if (listp arg) (cadr arg) 't) specializers) + (cons (if (listp arg) (cadr arg) t) specializers) (cons (if (listp arg) (car arg) arg) required))))))) @@ -2081,17 +2078,17 @@ work during bootstrapping. (and (symbolp instance) `((declare (variable-rebinding ,in ,instance))))) ,in - (symbol-macrolet ,(mapcar #'(lambda (slot-entry) - (let ((variable-name - (if (symbolp slot-entry) - slot-entry - (car slot-entry))) - (slot-name - (if (symbolp slot-entry) - slot-entry - (cadr slot-entry)))) - `(,variable-name - (slot-value ,in ',slot-name)))) + (symbol-macrolet ,(mapcar (lambda (slot-entry) + (let ((variable-name + (if (symbolp slot-entry) + slot-entry + (car slot-entry))) + (slot-name + (if (symbolp slot-entry) + slot-entry + (cadr slot-entry)))) + `(,variable-name + (slot-value ,in ',slot-name)))) slots) ,@body)))) @@ -2106,11 +2103,11 @@ work during bootstrapping. (and (symbolp instance) `((declare (variable-rebinding ,in ,instance))))) ,in - (symbol-macrolet ,(mapcar #'(lambda (slot-entry) + (symbol-macrolet ,(mapcar (lambda (slot-entry) (let ((variable-name (car slot-entry)) (accessor-name (cadr slot-entry))) `(,variable-name - (,accessor-name ,in)))) + (,accessor-name ,in)))) slots) ,@body)))) diff --git a/pcl/braid.lisp b/pcl/braid.lisp index 8fe1de4b024d49bbc405895172aa975a295f99c9..45fb7b2d9b1ef322480be8152c7f1cb534d285f2 100644 --- a/pcl/braid.lisp +++ b/pcl/braid.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.21 2002/07/03 10:57:17 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.22 2002/08/26 02:23:11 pmai Exp $") ;;; ;;; Bootstrapping the meta-braid. ;;; @@ -101,20 +101,20 @@ ;;; (defmacro initial-classes-and-wrappers (&rest classes) `(progn - ,@(mapcar #'(lambda (class) - (let ((wr (intern (format nil "~A-WRAPPER" class) - *the-pcl-package*))) - `(setf ,wr ,(if (eq class 'standard-generic-function) - '*sgf-wrapper* - `(boot-make-wrapper - (early-class-size ',class) - ',class)) - ,class (allocate-standard-instance - ,(if (eq class 'standard-generic-function) - 'funcallable-standard-class-wrapper - 'standard-class-wrapper)) - (wrapper-class ,wr) ,class - (find-class ',class) ,class))) + ,@(mapcar (lambda (class) + (let ((wr (intern (format nil "~A-WRAPPER" class) + *the-pcl-package*))) + `(setf ,wr ,(if (eq class 'standard-generic-function) + '*sgf-wrapper* + `(boot-make-wrapper + (early-class-size ',class) + ',class)) + ,class (allocate-standard-instance + ,(if (eq class 'standard-generic-function) + 'funcallable-standard-class-wrapper + 'standard-class-wrapper)) + (wrapper-class ,wr) ,class + (find-class ',class) ,class))) classes))) (defun bootstrap-meta-braid () @@ -192,7 +192,7 @@ (t (boot-make-wrapper (length slots) name)))) (proto nil)) - (when (eq name 't) (setq *the-wrapper-of-t* wrapper)) + (when (eq name t) (setq *the-wrapper-of-t* wrapper)) (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name)) *the-pcl-package*) class) @@ -265,7 +265,7 @@ (bootstrap-set-slot metaclass-name class slot-name value))) (set-slot 'name name) (set-slot 'source source) - (set-slot 'type (if (eq class (find-class 't)) + (set-slot 'type (if (eq class (find-class t)) t `(class ,class))) (set-slot 'class-eq-specializer @@ -309,10 +309,10 @@ (defun bootstrap-make-slot-definitions (name class slots wrapper effective-p) (let ((index -1)) - (mapcar #'(lambda (slot) - (incf index) - (bootstrap-make-slot-definition - name class slot wrapper effective-p index)) + (mapcar (lambda (slot) + (incf index) + (bootstrap-make-slot-definition + name class slot wrapper effective-p index)) slots))) (defun bootstrap-make-slot-definition (name class slot wrapper effective-p index) @@ -381,7 +381,7 @@ (list class-name) (list class-name) "automatically generated reader method")) (writer (values 'standard-writer-method #'make-std-writer-method-function - (list 'new-value class-name) (list 't class-name) + (list 'new-value class-name) (list t class-name) "automatically generated writer method")) (boundp (values 'standard-boundp-method #'make-std-boundp-method-function (list class-name) (list class-name) @@ -429,7 +429,7 @@ ;; (dolist (e *built-in-classes*) (dolist (super (cadr e)) - (unless (or (eq super 't) + (unless (or (eq super t) (assq super *built-in-classes*)) (error "In *built-in-classes*: ~S has ~S as a super,~%~ but ~S is not itself a class in *built-in-classes*." @@ -488,7 +488,7 @@ (defvar find-structure-class nil) (defun eval-form (form) - #'(lambda () (eval form))) + (lambda () (eval form))) (defun slot-initargs-from-structure-slotd (slotd) `(:name ,(structure-slotd-name slotd) diff --git a/pcl/cache.lisp b/pcl/cache.lisp index 4df562dcd3fd6c70fcbb288585ec041c34adbe8f..aa52ab938d33ab994a51618cf583a0c559956ffa 100644 --- a/pcl/cache.lisp +++ b/pcl/cache.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.14 2000/07/06 08:15:02 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.15 2002/08/26 02:23:11 pmai Exp $") ;;; ;;; The basics of the PCL wrapper cache mechanism. ;;; @@ -210,7 +210,7 @@ ;;; (defun show-free-cache-vectors () (let ((elements ())) - (maphash #'(lambda (s e) (push (list s e) elements)) *free-cache-vectors*) + (maphash (lambda (s e) (push (list s e) elements)) *free-cache-vectors*) (setq elements (sort elements #'< :key #'car)) (dolist (e elements) (let* ((size (car e)) @@ -329,7 +329,7 @@ (defun (setf wrapper-state) (new-value wrapper) (setf (kernel:layout-invalid wrapper) - (if (eq new-value 't) + (if (eq new-value t) nil new-value))) @@ -449,7 +449,7 @@ ;;; (defmacro invalid-wrapper-p (wrapper) - `(neq (wrapper-state ,wrapper) 't)) + `(neq (wrapper-state ,wrapper) t)) (defvar *previous-nwrappers* (make-hash-table)) @@ -467,15 +467,16 @@ ;; kind of transitivity of wrapper updates. ;; (dolist (previous (gethash owrapper *previous-nwrappers*)) - (when (eq state ':obsolete) - (setf (car previous) ':obsolete)) + (when (eq state :obsolete) + (setf (car previous) :obsolete)) (setf (cadr previous) nwrapper) (push previous new-previous)) + + (loop with ocnv = (wrapper-cache-number-vector owrapper) + for type in wrapper-layout and i from 0 + when (eq type 'number) do + (setf (cache-number-vector-ref ocnv i) 0)) - (let ((ocnv (wrapper-cache-number-vector owrapper))) - (iterate ((type (list-elements wrapper-layout)) - (i (interval :from 0))) - (when (eq type 'number) (setf (cache-number-vector-ref ocnv i) 0)))) (push (setf (wrapper-state owrapper) (list state nwrapper)) new-previous) @@ -485,7 +486,7 @@ (defun check-wrapper-validity (instance) (let* ((owrapper (wrapper-of instance)) (state (wrapper-state owrapper))) - (if (eq state 't) + (if (eq state t) owrapper (let ((nwrapper (ecase (car state) @@ -763,8 +764,8 @@ (wrapper nil) ,@(when wrappers `((class *the-class-t*) - (type 't)))) - (unless (eq mt 't) + (type t)))) + (unless (eq mt t) (setq wrapper (wrapper-of arg)) (when (invalid-wrapper-p wrapper) (setq ,invalid-wrapper-p t) @@ -790,8 +791,8 @@ (let* (,@(when wrappers `((,wrappers (nreverse wrappers-rev)) (,classes (nreverse classes-rev)) - (,types (mapcar #'(lambda (class) - `(class-eq ,class)) + (,types (mapcar (lambda (class) + `(class-eq ,class)) ,classes))))) ,@body)))) @@ -809,6 +810,10 @@ (or (nth arg-number (the list *dfun-arg-symbols*)) (intern (format nil ".ARG~A." arg-number) *the-pcl-package*))) +(defun dfun-arg-symbol-list (metatypes) + (loop for i from 0 and s in metatypes + collect (dfun-arg-symbol i))) + (defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.)) (defun slot-vector-symbol (arg-number) @@ -816,68 +821,39 @@ (intern (format nil ".SLOTS~A." arg-number) *the-pcl-package*))) (defun make-dfun-lambda-list (metatypes applyp) - (gathering1 (collecting) - (iterate ((i (interval :from 0)) - (s (list-elements metatypes))) - (progn s) - (gather1 (dfun-arg-symbol i))) - (when applyp - (gather1 '&rest) - (gather1 '.dfun-rest-arg.)))) + (if applyp + (nconc (dfun-arg-symbol-list metatypes) (list '&rest '.dfun-rest-arg.)) + (dfun-arg-symbol-list metatypes))) (defun make-dlap-lambda-list (metatypes applyp) - (gathering1 (collecting) - (iterate ((i (interval :from 0)) - (s (list-elements metatypes))) - (progn s) - (gather1 (dfun-arg-symbol i))) - (when applyp - (gather1 '&rest)))) + (if applyp + (nconc (dfun-arg-symbol-list metatypes) (list '&rest)) + (dfun-arg-symbol-list metatypes))) (defun make-emf-call (metatypes applyp fn-variable &optional emf-type) - (let ((required - (gathering1 (collecting) - (iterate ((i (interval :from 0)) - (s (list-elements metatypes))) - (progn s) - (gather1 (dfun-arg-symbol i)))))) + (let ((required (dfun-arg-symbol-list metatypes))) `(,(if (eq emf-type 'fast-method-call) 'invoke-effective-method-function-fast 'invoke-effective-method-function) ,fn-variable ,applyp ,@required ,@(when applyp `(.dfun-rest-arg.))))) (defun make-dfun-call (metatypes applyp fn-variable) - (let ((required - (gathering1 (collecting) - (iterate ((i (interval :from 0)) - (s (list-elements metatypes))) - (progn s) - (gather1 (dfun-arg-symbol i)))))) + (let ((required (dfun-arg-symbol-list metatypes))) (if applyp `(function-apply ,fn-variable ,@required .dfun-rest-arg.) `(function-funcall ,fn-variable ,@required)))) (defun make-dfun-arg-list (metatypes applyp) - (let ((required - (gathering1 (collecting) - (iterate ((i (interval :from 0)) - (s (list-elements metatypes))) - (progn s) - (gather1 (dfun-arg-symbol i)))))) + (let ((required (dfun-arg-symbol-list metatypes))) (if applyp `(list* ,@required .dfun-rest-arg.) `(list ,@required)))) (defun make-fast-method-call-lambda-list (metatypes applyp) - (gathering1 (collecting) - (gather1 '.pv-cell.) - (gather1 '.next-method-call.) - (iterate ((i (interval :from 0)) - (s (list-elements metatypes))) - (progn s) - (gather1 (dfun-arg-symbol i))) - (when applyp - (gather1 '.dfun-rest-arg.)))) + (nconc (list '.pv-cell. '.next-method-call.) + (dfun-arg-symbol-list metatypes) + (when applyp + (list '.dfun-rest-arg.)))) ;;; @@ -1077,12 +1053,12 @@ (defmacro with-local-cache-functions ((cache) &body body) `(let ((.cache. ,cache)) (declare (type cache .cache.)) - (macrolet ,(mapcar #'(lambda (fn) - `(,(car fn) ,(cadr fn) - `(let (,,@(mapcar #'(lambda (var) - ``(,',var ,,var)) - (cadr fn))) - ,@',(cddr fn)))) + (macrolet ,(mapcar (lambda (fn) + `(,(car fn) ,(cadr fn) + `(let (,,@(mapcar (lambda (var) + ``(,',var ,,var)) + (cadr fn))) + ,@',(cddr fn)))) *local-cache-functions*) ,@body))) @@ -1423,8 +1399,8 @@ (defun caches-to-allocate () (sort (let ((l nil)) - (maphash #'(lambda (size entry) - (push (list (car entry) size) l)) + (maphash (lambda (size entry) + (push (list (car entry) size) l)) pcl::*free-caches*) l) #'> :key #'cadr)) diff --git a/pcl/combin.lisp b/pcl/combin.lisp index e8ffe66fb602277daf11a762ebe967acba5812bc..25b0eeeb9606982bb787c9d245524b3e58ad3095 100644 --- a/pcl/combin.lisp +++ b/pcl/combin.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/combin.lisp,v 1.10 2001/04/25 21:44:51 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/combin.lisp,v 1.11 2002/08/26 02:23:11 pmai Exp $") ;;; (in-package :pcl) @@ -82,10 +82,10 @@ (method (car cm-args))) (when method (if (if (listp method) - (eq (car method) ':early-method) + (eq (car method) :early-method) (method-p method)) (if method-alist-p - 't + t (multiple-value-bind (mf fmf) (if (listp method) (early-method-function method) @@ -121,9 +121,9 @@ (null (cddr cm-args)))) (method (car cm-args)) (cm-args1 (cdr cm-args))) - #'(lambda (method-alist wrappers) - (make-effective-method-function-simple1 generic-function method cm-args1 fmf-p - method-alist wrappers)))) + (lambda (method-alist wrappers) + (make-effective-method-function-simple1 generic-function method cm-args1 fmf-p + method-alist wrappers)))) (defun make-emf-from-method (method cm-args &optional gf fmf-p method-alist wrappers) (multiple-value-bind (mf real-mf-p fmf pv-cell) @@ -134,7 +134,7 @@ gf (car next-methods) (list* (cdr next-methods) (cdr cm-args)) fmf-p method-alist wrappers)) - (arg-info (method-function-get fmf ':arg-info))) + (arg-info (method-function-get fmf :arg-info))) (make-fast-method-call :function fmf :pv-cell pv-cell :next-method-call next @@ -148,7 +148,7 @@ &optional method-alist wrappers) (when method (if (if (listp method) - (eq (car method) ':early-method) + (eq (car method) :early-method) (method-p method)) (make-emf-from-method method cm-args gf fmf-p method-alist wrappers) (if (and (consp method) (eq (car method) 'make-method)) @@ -201,14 +201,14 @@ (t '.call-method.))) ((and (consp form) (eq (car form) 'call-method-list)) - (case (if (every #'(lambda (form) - (eq 'fast-method-call - (make-effective-method-function-type - generic-function form - method-alist-p wrappers-p))) + (case (if (every (lambda (form) + (eq 'fast-method-call + (make-effective-method-function-type + generic-function form + method-alist-p wrappers-p))) (cdr form)) 'fast-method-call - 't) + t) (fast-method-call '.fast-call-method-list.) (t @@ -226,14 +226,14 @@ (list gensym)))) ((and (consp form) (eq (car form) 'call-method-list)) (let ((gensym (get-effective-method-gensym)) - (type (if (every #'(lambda (form) - (eq 'fast-method-call - (make-effective-method-function-type - generic-function form - method-alist-p wrappers-p))) + (type (if (every (lambda (form) + (eq 'fast-method-call + (make-effective-method-function-type + generic-function form + method-alist-p wrappers-p))) (cdr form)) 'fast-method-call - 't))) + t))) (values `(dolist (emf ,gensym nil) ,(make-emf-call metatypes applyp 'emf type)) (list gensym)))) @@ -247,9 +247,9 @@ generic-function form)))) ((and (consp form) (eq (car form) 'call-method-list)) (list (cons '.meth-list. - (mapcar #'(lambda (form) - (make-effective-method-function-simple - generic-function form)) + (mapcar (lambda (form) + (make-effective-method-function-simple + generic-function form)) (cdr form))))) (t (default-constant-converter form)))) @@ -268,42 +268,42 @@ generic-function effective-method))) (multiple-value-bind (cfunction constants) (get-function1 effective-method-lambda - #'(lambda (form) - (memf-test-converter form generic-function - method-alist-p wrappers-p)) - #'(lambda (form) - (memf-code-converter form generic-function - metatypes applyp - method-alist-p wrappers-p)) - #'(lambda (form) - (memf-constant-converter form generic-function))) - #'(lambda (method-alist wrappers) - (let* ((constants - (mapcar #'(lambda (constant) - (if (consp constant) - (case (car constant) - (.meth. - (funcall (cdr constant) - method-alist wrappers)) - (.meth-list. - (mapcar #'(lambda (fn) - (funcall fn method-alist wrappers)) - (cdr constant))) - (t constant)) - constant)) - constants)) - (function (set-function-name - (apply cfunction constants) - `(combined-method ,name)))) - (make-fast-method-call :function function - :arg-info arg-info))))))) + (lambda (form) + (memf-test-converter form generic-function + method-alist-p wrappers-p)) + (lambda (form) + (memf-code-converter form generic-function + metatypes applyp + method-alist-p wrappers-p)) + (lambda (form) + (memf-constant-converter form generic-function))) + (lambda (method-alist wrappers) + (let* ((constants + (mapcar (lambda (constant) + (if (consp constant) + (case (car constant) + (.meth. + (funcall (cdr constant) + method-alist wrappers)) + (.meth-list. + (mapcar (lambda (fn) + (funcall fn method-alist wrappers)) + (cdr constant))) + (t constant)) + constant)) + constants)) + (function (set-function-name + (apply cfunction constants) + `(combined-method ,name)))) + (make-fast-method-call :function function + :arg-info arg-info))))))) (defmacro call-method-list (&rest calls) `(progn ,@calls)) (defun make-call-methods (methods) `(call-method-list - ,@(mapcar #'(lambda (method) `(call-method ,method ())) methods))) + ,@(mapcar (lambda (method) `(call-method ,method ())) methods))) (defun standard-compute-effective-method (generic-function combin applicable-methods) (declare (ignore combin)) @@ -379,22 +379,22 @@ (standard-compute-effective-method generic-function combin applicable-methods)) (defvar *invalid-method-error* - #'(lambda (&rest args) - (declare (ignore args)) - (error - "INVALID-METHOD-ERROR was called outside the dynamic scope~%~ - of a method combination function (inside the body of~%~ - DEFINE-METHOD-COMBINATION or a method on the generic~%~ - function COMPUTE-EFFECTIVE-METHOD)."))) + (lambda (&rest args) + (declare (ignore args)) + (error + "INVALID-METHOD-ERROR was called outside the dynamic scope~%~ + of a method combination function (inside the body of~%~ + DEFINE-METHOD-COMBINATION or a method on the generic~%~ + function COMPUTE-EFFECTIVE-METHOD)."))) (defvar *method-combination-error* - #'(lambda (&rest args) - (declare (ignore args)) - (error - "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~ - of a method combination function (inside the body of~%~ - DEFINE-METHOD-COMBINATION or a method on the generic~%~ - function COMPUTE-EFFECTIVE-METHOD)."))) + (lambda (&rest args) + (declare (ignore args)) + (error + "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~ + of a method combination function (inside the body of~%~ + DEFINE-METHOD-COMBINATION or a method on the generic~%~ + function COMPUTE-EFFECTIVE-METHOD)."))) ;This definition appears in defcombin.lisp. ; diff --git a/pcl/construct.lisp b/pcl/construct.lisp index 78c7756eacaab5ceaaad628849f86e1e604cd1d4..4edbaf6681f7780d65a97e5966b78101fcac8640 100644 --- a/pcl/construct.lisp +++ b/pcl/construct.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/construct.lisp,v 1.12 1999/05/30 23:13:54 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/construct.lisp,v 1.13 2002/08/26 02:23:11 pmai Exp $") ;;; ;;; This file defines the defconstructor and other make-instance optimization ;;; mechanisms. @@ -117,10 +117,8 @@ (defun expand-defconstructor (class-name name lambda-list supplied-initargs) (let ((class (find-class class-name nil)) - (supplied-initarg-names - (gathering1 (collecting) - (iterate ((name (*list-elements supplied-initargs :by #'cddr))) - (gather1 name))))) + (supplied-initarg-names (loop for name in supplied-initargs by #'cddr + collect name))) (when (null class) (error "defconstructor form being compiled (or evaluated) before~@ class ~S is defined." @@ -241,9 +239,10 @@ Other possible code types are ~S." constructor (constructor-class constructor) (constructor-code-type constructor) - (gathering1 (collecting) + (let ((collected ())) (doplist (key val) (constructor-code-generators constructor) - (gather1 key))))) + (push key collected)) + (nreverse collected)))) ;;; ;;; I am not in a hairy enough mood to make this implementation be metacircular @@ -405,15 +404,14 @@ ((class slot-class) name lambda-list supplied-initarg-names supplied-initargs) (cons 'list - (gathering1 (collecting) - (dolist (entry *constructor-code-types*) - (let ((generator - (funcall (cadr entry) class name lambda-list - supplied-initarg-names - supplied-initargs))) - (when generator - (gather1 `',(car entry)) - (gather1 generator))))))) + (loop for (type generator-generator) in *constructor-code-types* + for generator = (funcall generator-generator + class name lambda-list + supplied-initarg-names + supplied-initargs) + when generator + collect `',type + and collect generator))) (defmethod compute-constructor-code ((class slot-class) (constructor constructor)) @@ -477,7 +475,7 @@ (funcall fn constructor)) (dolist (subclass (class-direct-subclasses class)) (recurse subclass)))) - (recurse (find-class 't)) + (recurse (find-class t)) (values nclasses nconstructors)))) (defun reset-constructors () @@ -488,15 +486,15 @@ (defun disable-constructors () (multiple-value-bind (nclass ncons) (map-constructors - #'(lambda (c) - (let ((gen (getf (constructor-code-generators c) 'fallback))) - (if (null gen) - (error "No fallback constructor for ~S." c) - (set-constructor-code c - (funcall gen - (constructor-class c) - () () () ()) - 'fallback))))) + (lambda (c) + (let ((gen (getf (constructor-code-generators c) 'fallback))) + (if (null gen) + (error "No fallback constructor for ~S." c) + (set-constructor-code c + (funcall gen + (constructor-class c) + () () () ()) + 'fallback))))) (format t "~&~D classes, ~D constructors." nclass ncons))) (defun enable-constructors () @@ -519,21 +517,21 @@ (list *the-class-slot-object* *the-class-t*))) (defun non-pcl-initialize-instance-methods-p (methods) - (notevery #'(lambda (m) (eq m *standard-initialize-instance-method*)) + (notevery (lambda (m) (eq m *standard-initialize-instance-method*)) methods)) (defun non-pcl-shared-initialize-methods-p (methods) - (notevery #'(lambda (m) (eq m *standard-shared-initialize-method*)) + (notevery (lambda (m) (eq m *standard-shared-initialize-method*)) methods)) (defun non-pcl-or-after-initialize-instance-methods-p (methods) - (notevery #'(lambda (m) (or (eq m *standard-initialize-instance-method*) - (equal '(:after) (method-qualifiers m)))) + (notevery (lambda (m) (or (eq m *standard-initialize-instance-method*) + (equal '(:after) (method-qualifiers m)))) methods)) (defun non-pcl-or-after-shared-initialize-methods-p (methods) - (notevery #'(lambda (m) (or (eq m *standard-shared-initialize-method*) - (equal '(:after) (method-qualifiers m)))) + (notevery (lambda (m) (or (eq m *standard-shared-initialize-method*) + (equal '(:after) (method-qualifiers m)))) methods)) ;;; @@ -563,13 +561,13 @@ (push (cons name *slot-unbound*) constants)) ((constantp initform) (push (cons name (eval initform)) constants) - (when (eq flag ':unsupplied) (setq flag ':constants))) + (when (eq flag :unsupplied) (setq flag :constants))) (t (push (cons name *slot-unbound*) constants) - (setq flag 't))))) - (let* ((constants-alist (sort constants #'(lambda (x y) - (memq (car y) - (memq (car x) layout))))) + (setq flag t))))) + (let* ((constants-alist (sort constants (lambda (x y) + (memq (car y) + (memq (car x) layout))))) (constants-list (mapcar #'cdr constants-alist))) (values constants-list flag)))) @@ -584,34 +582,30 @@ ;;; (defun compute-initarg-positions (class initarg-names) (let* ((layout (wrapper-instance-slots-layout (class-wrapper class))) - (positions - (gathering1 (collecting) - (iterate ((slot-name (list-elements layout)) - (position (interval :from 0))) - (gather1 (cons slot-name position))))) - (slot-initargs - (mapcar #'(lambda (slotd) - (list (slot-definition-initargs slotd) - (or (cdr (assq (slot-definition-name slotd) positions)) - ':class))) - (class-slots class)))) - ;; Go through each of the initargs, and figure out what position - ;; it fills by replacing the entries in slot-initargs it fills. + (positions (loop for position from 0 and slot-name in layout + collect (cons slot-name position))) + (slot-initargs-positions + (loop for slotd in (class-slots class) + collect + (list (slot-definition-initargs slotd) + (or (cdr (assq (slot-definition-name slotd) positions)) + :class))))) + ;; Go through each of the initargs, and figure out what position it + ;; fills by replacing the entries in slot-initargs-positions it fills. (dolist (initarg initarg-names) - (dolist (slot-entry slot-initargs) + (dolist (slot-entry slot-initargs-positions) (let ((slot-initargs (car slot-entry))) (when (and (listp slot-initargs) (not (null slot-initargs)) (memq initarg slot-initargs)) (setf (car slot-entry) initarg))))) - (gathering1 (collecting) - (dolist (initarg initarg-names) - (let ((positions (gathering1 (collecting) - (dolist (slot-entry slot-initargs) - (when (eq (car slot-entry) initarg) - (gather1 (cadr slot-entry))))))) - (when positions - (gather1 (cons initarg positions)))))))) + ;; Now collect all possible positions for each initarg + (loop for initarg in initarg-names + for positions = (loop for (arg position) in slot-initargs-positions + when (eq arg initarg) + collect position) + when positions + collect (cons initarg positions)))) ;;; @@ -630,10 +624,10 @@ (kernel:instance-lambda ,arglist (make-instance ',(class-name class) - ,@(gathering1 (collecting) - (iterate ((tail (*list-tails supplied-initargs :by #'cddr))) - (gather1 `',(car tail)) - (gather1 (cadr tail)))))))))) + ,@(loop for (name value) on supplied-initargs by #'cddr + collect `',name + collect value))))))) + ;;; ;;; The GENERAL case allows: @@ -686,15 +680,17 @@ (dolist (pos (cddr entry)) (setf (%instance-ref .slots. pos) val)))) - ,@(gathering1 (collecting) + ,@(let ((collected ())) (doplist (initarg value) supplied-initargs (unless (constantp value) - (gather1 `(let ((.value. ,value)) - (push .value. .initargs.) - (push ',initarg .initargs.) - (dolist (.p. (pop .positions.)) - (setf (%instance-ref .slots. .p.) - .value.))))))) + (push `(let ((.value. ,value)) + (push .value. .initargs.) + (push ',initarg .initargs.) + (dolist (.p. (pop .positions.)) + (setf (%instance-ref .slots. .p.) + .value.))) + collected))) + (nreverse collected)) (dolist (fn .shared-initfns.) (apply fn .instance. t .initargs.)) @@ -840,14 +836,16 @@ (let ((val (funcall (car entry)))) (dolist (pos (cdr entry)) (setf (%instance-ref .slots. pos) val)))) - - ,@(gathering1 (collecting) + + ,@(let ((collected ())) (doplist (initarg value) supplied-initargs (unless (constantp value) - (gather1 - `(let ((.value. ,value)) - (dolist (.p. (pop .positions.)) - (setf (%instance-ref .slots. .p.) .value.))))))) + (push `(let ((.value. ,value)) + (dolist (.p. (pop .positions.)) + (setf (%instance-ref .slots. .p.) + .value.))) + collected))) + (nreverse collected)) .instance.)))))))) @@ -969,14 +967,16 @@ (.slots. (,slots-fetcher .instance.)) (.positions. .supplied-initarg-positions.)) .positions. - - ,@(gathering1 (collecting) + + ,@(let ((collected ())) (doplist (initarg value) supplied-initargs (unless (constantp value) - (gather1 - `(let ((.value. ,value)) - (dolist (.p. (pop .positions.)) - (setf (%instance-ref .slots. .p.) .value.))))))) + (push `(let ((.value. ,value)) + (dolist (.p. (pop .positions.)) + (setf (%instance-ref .slots. .p.) + .value.))) + collected))) + (nreverse collected)) .instance.)))))))))) diff --git a/pcl/cpl.lisp b/pcl/cpl.lisp index 4690d9d5e6065b60f490710d0b3ab130f0a842f0..5c554791790554e5c0f09988971132da52b5922a 100644 --- a/pcl/cpl.lisp +++ b/pcl/cpl.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cpl.lisp,v 1.9 1999/05/30 23:13:55 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cpl.lisp,v 1.10 2002/08/26 02:23:11 pmai Exp $") ;;; (in-package :pcl) @@ -266,21 +266,21 @@ (format nil "named ~S" (class-name class)) class)))) (mapcar - #'(lambda (reason) - (ecase (caddr reason) - (:super - (format - nil - "the class ~A appears in the supers of the class ~A" - (class-or-name (cadr reason)) - (class-or-name (car reason)))) - (:in-supers - (format - nil - "the class ~A follows the class ~A in the supers of the class ~A" - (class-or-name (cadr reason)) - (class-or-name (car reason)) - (class-or-name (cadddr reason)))))) + (lambda (reason) + (ecase (caddr reason) + (:super + (format + nil + "the class ~A appears in the supers of the class ~A" + (class-or-name (cadr reason)) + (class-or-name (car reason)))) + (:in-supers + (format + nil + "the class ~A follows the class ~A in the supers of the class ~A" + (class-or-name (cadr reason)) + (class-or-name (car reason)) + (class-or-name (cadddr reason)))))) reasons))) (defun find-cycle-reasons (all-cpds) diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp index dcb8163046aaf32a05ad92deee575b7ed9b539e4..09272a5c188ebac11556d44c7ffbcfe9092f3e6f 100644 --- a/pcl/defclass.lisp +++ b/pcl/defclass.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.20 2002/08/13 21:13:58 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.21 2002/08/26 02:23:12 pmai Exp $") ;;; (in-package :pcl) @@ -155,12 +155,12 @@ (*slots* ())) (declare (special *initfunctions* *readers* *writers* *slots*)) (let ((canonical-slots - (mapcar #'(lambda (spec) - (canonicalize-slot-specification name spec)) + (mapcar (lambda (spec) + (canonicalize-slot-specification name spec)) slots)) (other-initargs - (mapcar #'(lambda (option) - (canonicalize-defclass-option name option)) + (mapcar (lambda (option) + (canonicalize-defclass-option name option)) options)) (defstruct-p (and (eq *boot-state* 'complete) (let ((mclass (find-class metaclass nil))) @@ -171,18 +171,18 @@ (make-top-level-form `(defclass ,name) (if defstruct-p '(load eval) *defclass-times*) `(progn - ,@(mapcar #'(lambda (x) - `(declaim (ftype (function (t) t) ,x))) + ,@(mapcar (lambda (x) + `(declaim (ftype (function (t) t) ,x))) *readers*) - ,@(mapcar #'(lambda (x) - `(declaim (ftype (function (t t) t) ,x))) + ,@(mapcar (lambda (x) + `(declaim (ftype (function (t t) t) ,x))) *writers*) - ,@(mapcar #'(lambda (x) - `(declaim (ftype (function (t) t) - ,(slot-reader-symbol x) - ,(slot-boundp-symbol x)) - (ftype (function (t t) t) - ,(slot-writer-symbol x)))) + ,@(mapcar (lambda (x) + `(declaim (ftype (function (t) t) + ,(slot-reader-symbol x) + ,(slot-boundp-symbol x)) + (ftype (function (t t) t) + ,(slot-writer-symbol x)))) *slots*) (let ,(mapcar #'cdr *initfunctions*) (load-defclass ',name @@ -210,13 +210,13 @@ (defun make-initfunction (initform) (declare (special *initfunctions*)) - (cond ((or (eq initform 't) + (cond ((or (eq initform t) (equal initform ''t)) '(function true)) - ((or (eq initform 'nil) + ((or (eq initform nil) (equal initform ''nil)) '(function false)) - ((or (eql initform '0) + ((or (eql initform 0) (equal initform ''0)) '(function zero)) (t @@ -344,10 +344,9 @@ (values (early-collect-slots cpl) cpl (early-collect-default-initargs cpl) - (gathering1 (collecting) - (dolist (definition *early-class-definitions*) - (when (memq class-name (ecd-superclass-names definition)) - (gather1 (ecd-class-name definition)))))))) + (loop for definition in *early-class-definitions* + when (memq class-name (ecd-superclass-names definition)) + collect (ecd-class-name definition))))) (defun early-collect-slots (cpl) (let* ((definitions (mapcar #'early-class-definition cpl)) diff --git a/pcl/defcombin.lisp b/pcl/defcombin.lisp index b62c0ff4f5ffcf298f754d57824b78ebb1e4a96c..adaf1b7d2b3ef6ff703d6e0c07fe1274728bd44b 100644 --- a/pcl/defcombin.lisp +++ b/pcl/defcombin.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.13 2002/08/13 21:15:24 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.14 2002/08/26 02:23:12 pmai Exp $") ;;; (in-package :pcl) @@ -134,14 +134,14 @@ :qualifiers () :specializers specializers :lambda-list '(generic-function type options) - :function #'(lambda(args nms &rest cm-args) - (declare (ignore nms cm-args)) - (apply - #'(lambda (gf type options) - (declare (ignore gf)) - (do-short-method-combination - type options operator ioa new-method doc)) - args)) + :function (lambda(args nms &rest cm-args) + (declare (ignore nms cm-args)) + (apply + (lambda (gf type options) + (declare (ignore gf)) + (do-short-method-combination + type options operator ioa new-method doc)) + args)) :definition-source `((define-method-combination ,type) ,truename))) (when old-method (remove-method #'find-method-combination old-method)) @@ -202,7 +202,7 @@ (if (and (null (cdr primary)) (not (null ioa))) `(call-method ,(car primary) ()) - `(,operator ,@(mapcar #'(lambda (m) `(call-method ,m ())) + `(,operator ,@(mapcar (lambda (m) `(call-method ,m ())) primary))))) (cond ((null primary) `(error "No ~S methods for the generic function ~S." @@ -255,16 +255,16 @@ :qualifiers () :specializers specializers :lambda-list '(generic-function type options) - :function #'(lambda (args nms &rest cm-args) - (declare (ignore nms cm-args)) - (apply - #'(lambda (generic-function type options) - (declare (ignore generic-function)) - (make-instance 'long-method-combination - :type type - :options options - :documentation doc)) - args)) + :function (lambda (args nms &rest cm-args) + (declare (ignore nms cm-args)) + (apply + (lambda (generic-function type options) + (declare (ignore generic-function)) + (make-instance 'long-method-combination + :type type + :options options + :documentation doc)) + args)) :definition-source `((define-method-combination ,type) ,(load-truename))))) (setf (gethash type *long-method-combination-functions*) function) @@ -303,7 +303,7 @@ (when ll (setq wrapped-body - `(apply #'(lambda ,ll ,wrapped-body) + `(apply (lambda ,ll ,wrapped-body) (method-combination-options .method-combination.)))) (values @@ -317,19 +317,19 @@ (defun wrap-method-group-specifier-bindings (method-group-specifiers declarations real-body) - (with-gathering ((names (collecting)) - (specializer-caches (collecting)) - (cond-clauses (collecting)) - (required-checks (collecting)) - (order-cleanups (collecting))) - (dolist (method-group-specifier method-group-specifiers) - (multiple-value-bind (name tests description order required) - (parse-method-group-specifier method-group-specifier) - (declare (ignore description)) - (let ((specializer-cache (gensym))) - (gather name names) - (gather specializer-cache specializer-caches) - (gather `((or ,@tests) + (let ((names ()) + (specializer-caches ()) + (cond-clauses ()) + (required-checks ()) + (order-cleanups ())) + (dolist (method-group-specifier method-group-specifiers) + (multiple-value-bind (name tests description order required) + (parse-method-group-specifier method-group-specifier) + (declare (ignore description)) + (let ((specializer-cache (gensym))) + (push name names) + (push specializer-cache specializer-caches) + (push `((or ,@tests) (if (equal ,specializer-cache .specializers.) (return-from .long-method-combination-function. '(error "More than one method of type ~S ~ @@ -337,60 +337,57 @@ ',name)) (setq ,specializer-cache .specializers.)) (push .method. ,name)) - cond-clauses) - (when required - (gather `(when (null ,name) - (return-from .long-method-combination-function. - '(error "No ~S methods." ',name))) - required-checks)) - (loop (unless (and (constantp order) - (neq order (setq order (eval order)))) - (return t))) - (gather (cond ((eq order :most-specific-first) - `(setq ,name (nreverse ,name))) - ((eq order :most-specific-last) ()) - (t - `(ecase ,order - (:most-specific-first - (setq ,name (nreverse ,name))) - (:most-specific-last)))) - order-cleanups)))) - `(let (,@names ,@specializer-caches) - ,@declarations - (dolist (.method. .applicable-methods.) - (let ((.qualifiers. (method-qualifiers .method.)) - (.specializers. (method-specializers .method.))) - (progn .qualifiers. .specializers.) - (cond ,@cond-clauses))) - ,@required-checks - ,@order-cleanups + cond-clauses) + (when required + (push `(when (null ,name) + (return-from .long-method-combination-function. + '(error "No ~S methods." ',name))) + required-checks)) + (loop (unless (and (constantp order) + (neq order (setq order (eval order)))) + (return t))) + (push (cond ((eq order :most-specific-first) + `(setq ,name (nreverse ,name))) + ((eq order :most-specific-last) ()) + (t + `(ecase ,order + (:most-specific-first + (setq ,name (nreverse ,name))) + (:most-specific-last)))) + order-cleanups)))) + `(let (,@(nreverse names) ,@(nreverse specializer-caches)) + ,@declarations + (dolist (.method. .applicable-methods.) + (let ((.qualifiers. (method-qualifiers .method.)) + (.specializers. (method-specializers .method.))) + (progn .qualifiers. .specializers.) + (cond ,@(nreverse cond-clauses)))) + ,@(nreverse required-checks) + ,@(nreverse order-cleanups) ,@real-body))) (defun parse-method-group-specifier (method-group-specifier) ;;(declare (values name tests description order required)) - (let* ((name (pop method-group-specifier)) - (patterns ()) - (tests - (gathering1 (collecting) - (block collect-tests - (loop - (if (or (null method-group-specifier) - (memq (car method-group-specifier) - '(:description :order :required))) - (return-from collect-tests t) - (let ((pattern (pop method-group-specifier))) - (push pattern patterns) - (gather1 (parse-qualifier-pattern name pattern))))))))) - (values name - tests - (getf method-group-specifier :description - (make-default-method-group-description patterns)) - (getf method-group-specifier :order :most-specific-first) - (getf method-group-specifier :required nil)))) + (loop + with name = (pop method-group-specifier) + for pattern = (pop method-group-specifier) + until (null pattern) + until (memq pattern '(:description :order :required)) + collect pattern into patterns + collect (parse-qualifier-pattern name pattern) into tests + finally + (return + (values name + tests + (getf method-group-specifier :description + (make-default-method-group-description + (nreverse patterns))) + (getf method-group-specifier :order :most-specific-first) + (getf method-group-specifier :required nil))))) (defun parse-qualifier-pattern (name pattern) (cond ((eq pattern '()) `(null .qualifiers.)) - ((eq pattern '*) 't) + ((eq pattern '*) t) ((symbolp pattern) `(,pattern .qualifiers.)) ((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.)) (t (error "In the method group specifier ~S,~%~ @@ -432,17 +429,15 @@ ;;; (defun deal-with-arguments-option (wrapped-body arguments-option) (let* ((intercept-lambda-list - (gathering1 (collecting) - (dolist (arg arguments-option) - (if (memq arg lambda-list-keywords) - (gather1 arg) - (gather1 (gensym)))))) + (loop for arg in arguments-option + collect (if (memq arg lambda-list-keywords) + arg + (gensym)))) (intercept-rebindings - (gathering1 (collecting) - (iterate ((arg (list-elements arguments-option)) - (int (list-elements intercept-lambda-list))) - (unless (memq arg lambda-list-keywords) - (gather1 `(,arg ',int))))))) + (loop for arg in arguments-option + and int in intercept-lambda-list + unless (memq arg lambda-list-keywords) + collect `(,arg ',int)))) ;; ;; (setf (cadr wrapped-body) @@ -461,7 +456,7 @@ (append intercept-lambda-list '(&rest .ignore.))))) `(let ((inner-result. ,wrapped-body)) - `(apply #'(lambda ,',intercept-lambda-list + `(apply (lambda ,',intercept-lambda-list ,,(when (memq '.ignore. intercept-lambda-list) ''(declare (ignore .ignore.))) ,inner-result.) diff --git a/pcl/defs.lisp b/pcl/defs.lisp index 80394262f79f4b348694eff8c172883659e8c30a..afe91ee26760c69c796904e696de9c275cca9640 100644 --- a/pcl/defs.lisp +++ b/pcl/defs.lisp @@ -148,8 +148,8 @@ ;;; interface (defun type-from-specializer (specl) - (cond ((eq specl 't) - 't) + (cond ((eq specl t) + t) ((consp specl) (unless (member (car specl) '(class prototype class-eq eql)) (error "~S is not a legal specializer type" specl)) @@ -168,7 +168,7 @@ (declare (special *the-class-t*)) (setq type (type-from-specializer type)) (if (atom type) - (if (eq type 't) + (if (eq type t) *the-class-t* (error "bad argument to type-class")) (case (car type) @@ -199,10 +199,10 @@ (defun make-class-eq-predicate (class) (when (symbolp class) (setq class (find-class class))) - #'(lambda (object) (eq class (class-of object)))) + (lambda (object) (eq class (class-of object)))) (defun make-eql-predicate (eql-object) - #'(lambda (object) (eql eql-object object))) + (lambda (object) (eql eql-object object))) ;;; Internal to this file. @@ -331,7 +331,7 @@ (defmacro define-gf-predicate (predicate-name &rest classes) `(progn (defmethod ,predicate-name ((x t)) nil) - ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t)) + ,@(mapcar (lambda (c) `(defmethod ,predicate-name ((x ,c)) t)) classes))) (defun make-class-predicate-name (name) @@ -416,8 +416,8 @@ (res `(,name ,(mapcar #'lisp:class-name (direct-supers class)) ,(mapcar #'lisp:class-name (direct-subs class)) - ,(map 'list #'(lambda (x) - (lisp:class-name (kernel:layout-class x))) + ,(map 'list (lambda (x) + (lisp:class-name (kernel:layout-class x))) (reverse (kernel:layout-inherits (kernel:class-layout class)))) @@ -662,11 +662,11 @@ ()) (defclass effective-slot-definition (slot-definition) - ((reader-function ; #'(lambda (object) ...) + ((reader-function ; (lambda (object) ...) :accessor slot-definition-reader-function) - (writer-function ; #'(lambda (new-value object) ...) + (writer-function ; (lambda (new-value object) ...) :accessor slot-definition-writer-function) - (boundp-function ; #'(lambda (object) ...) + (boundp-function ; (lambda (object) ...) :accessor slot-definition-boundp-function) (accessor-flags :initform 0))) diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp index 44343e2c4a6b27e9daa5e6346d36070cb44638b3..3f8c49bfb67ecbc464412dd741feb5d37656abca 100644 --- a/pcl/defsys.lisp +++ b/pcl/defsys.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defsys.lisp,v 1.24 2001/04/10 22:37:21 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defsys.lisp,v 1.25 2002/08/26 02:23:12 pmai Exp $") ;;; ;;; Some support stuff for compiling and loading PCL. It would be nice if ;;; there was some portable make-system we could all agree to share for a @@ -57,20 +57,9 @@ (in-package :user) (defpackage "WALKER" (:use :common-lisp)) -(defpackage "ITERATE" (:use :common-lisp :walker)(:export "ITERATE")) -(defpackage "PCL" (:use :walker :iterate :common-lisp)) +(defpackage "PCL" (:use :walker :common-lisp)) (in-package "PCL") -;;(in-package :walker :use '(:lisp)) -;;(in-package :iterate :use '(:lisp :walker)) -;;(in-package :pcl :use '(:walker :iterate :lisp)) -#+nil -(export (intern (symbol-name :iterate) ;Have to do this here, - (find-package :iterate)) ;because in the defsystem - (find-package :iterate)) ;(later in this file) - ;we use the symbol iterate - ;to name the file - ;;; ;;; Sure, its weird for this to be here, but in order to follow the rules ;;; about order of export and all that stuff, we can't put it in PKG before @@ -187,7 +176,7 @@ and load your system with: (setf (get name 'system-definition) new-value)) (defmacro defsystem (name directory files) - `(set-system ',name (list #'(lambda () ,directory) + `(set-system ',name (list (lambda () ,directory) (make-modules ',files) ',(mapcar #'car files)))) @@ -214,13 +203,13 @@ and load your system with: (progn (setq modules (cons (make-module name) modules)) (car modules)))) (parse-spec (spec) - (if (eq spec 't) + (if (eq spec t) (reverse (cdr modules)) (case (car spec) (+ (append (reverse (cdr modules)) (mapcar #'get-module (cdr spec)))) (- (let ((rem (mapcar #'get-module (cdr spec)))) - (remove-if #'(lambda (m) (member m rem)) + (remove-if (lambda (m) (member m rem)) (reverse (cdr modules))))) (otherwise (mapcar #'get-module spec)))))) (dolist (file system-description) @@ -234,8 +223,8 @@ and load your system with: (module-comp-env module) (parse-spec (caddr file)) (module-recomp-reasons module) (parse-spec (cadddr file)))))) (let ((filenames (mapcar #'car system-description))) - (sort modules #'(lambda (name1 name2) - (member name2 (member name1 filenames))) + (sort modules (lambda (name1 name2) + (member name2 (member name1 filenames))) :key #'module-name))))) @@ -248,13 +237,13 @@ and load your system with: (defun make-compile-transformation (module transforms) (unless (dolist (trans transforms) - (and (eq (car trans) ':compile) + (and (eq (car trans) :compile) (eq (cadr trans) module) (return t))) (dolist (c (module-comp-env module)) (make-load-transformation c transforms)) (setf (cdr transforms) - (remove-if #'(lambda (trans) (and (eq (car trans) :load) - (eq (cadr trans) module))) + (remove-if (lambda (trans) (and (eq (car trans) :load) + (eq (cadr trans) module))) (cdr transforms))) (push `(:compile ,module) (cdr transforms)))) @@ -266,7 +255,7 @@ and load your system with: (let ((*being-loaded* (cons (cons module (cdr transforms)) *being-loaded*))) (catch module (unless (dolist (trans transforms) - (when (and (eq (car trans) ':load) + (when (and (eq (car trans) :load) (eq (cadr trans) module)) (return t))) (dolist (l (module-load-env module)) @@ -275,7 +264,7 @@ and load your system with: (defun make-load-without-dependencies-transformation (module transforms) (unless (dolist (trans transforms) - (and (eq (car trans) ':load) + (and (eq (car trans) :load) (eq (cadr trans) module) (return trans))) (push `(:load ,module) (cdr transforms)))) @@ -283,7 +272,7 @@ and load your system with: (defun compile-filter (module transforms) (or (dolist (r (module-recomp-reasons module)) (when (dolist (transform transforms) - (when (and (eq (car transform) ':compile) + (when (and (eq (car transform) :compile) (eq (cadr transform) r)) (return t))) (return t))) @@ -317,9 +306,9 @@ and load your system with: ;; been recompiled. (make-transformations modules - #'(lambda (m transforms) - (or (member (module-name m) arg) - (compile-filter m transforms))) + (lambda (m transforms) + (or (member (module-name m) arg) + (compile-filter m transforms))) #'make-compile-transformation)) (:query-compile ;; Ask the user which files to compile. Compile those @@ -327,20 +316,20 @@ and load your system with: ;; another file has been recompiled. (make-transformations modules - #'(lambda (m transforms) - (or (compile-filter m transforms) - (y-or-n-p "Compile ~A?" - (module-name m)))) + (lambda (m transforms) + (or (compile-filter m transforms) + (y-or-n-p "Compile ~A?" + (module-name m)))) #'make-compile-transformation)) (:confirm-compile ;; Offer the user a chance to prevent a file from being ;; recompiled. (make-transformations modules - #'(lambda (m transforms) - (and (compile-filter m transforms) - (y-or-n-p "Go ahead and compile ~A?" - (module-name m)))) + (lambda (m transforms) + (and (compile-filter m transforms) + (y-or-n-p "Go ahead and compile ~A?" + (module-name m)))) #'make-compile-transformation)) (:load ;; Load the whole system. @@ -352,16 +341,16 @@ and load your system with: ;; Load only those files the user says to load. (make-transformations modules - #'(lambda (m transforms) - (declare (ignore transforms)) - (y-or-n-p "Load ~A?" (module-name m))) + (lambda (m transforms) + (declare (ignore transforms)) + (y-or-n-p "Load ~A?" (module-name m))) #'make-load-without-dependencies-transformation)))))) (defun true (&rest ignore) (declare (ignore ignore)) - 't) + t) -(defparameter *byte-files* '(defclass defcombin iterate env)) +(defparameter *byte-files* '(defclass defcombin env)) (defun operate-on-system (name mode &optional arg print-only) (let ((system (get-system name))) @@ -425,8 +414,8 @@ and load your system with: (unless system (error "Can't find system with name ~S." name)) (let ((*system-directory* (funcall (the function (car system)))) (modules (cadr system))) - (mapcar #'(lambda (module) - (make-source-pathname (module-name module))) + (mapcar (lambda (module) + (make-source-pathname (module-name module))) modules)))) (defun system-binary-files (name) @@ -434,8 +423,8 @@ and load your system with: (unless system (error "Can't find system with name ~S." name)) (let ((*system-directory* (funcall (the function (car system)))) (modules (cadr system))) - (mapcar #'(lambda (module) - (make-binary-pathname (module-name module))) + (mapcar (lambda (module) + (make-binary-pathname (module-name module))) modules)))) ;;; *** SITE SPECIFIC PCL DIRECTORY *** @@ -475,13 +464,12 @@ and load your system with: ( (pkg t t ()) (walk (pkg) (pkg) ()) - (iterate t t ()) (macros t t ()) (low (pkg macros) t (macros)) (fin t t (low)) (defclass t t (low)) - (defs t t (defclass macros iterate)) + (defs t t (defclass macros)) (fngen t t (low)) (cache t t (low defs)) (dlisp t t (defs low fin cache)) @@ -535,7 +523,7 @@ and load your system with: (operate-on-system 'pcl :query-compile)) ((eq m :confirm) (operate-on-system 'pcl :confirm-compile)) - ((eq m 't) + ((eq m t) (operate-on-system 'pcl :recompile) (operate-on-system 'gray-streams :recompile)) ((listp m) @@ -588,13 +576,13 @@ and load your system with: (fmakunbound sym) (setf (symbol-plist sym) nil)))) (let ((pcl (find-package "PCL"))) - (mapcar #'(lambda (name value) - (let ((var (intern name pcl))) - (proclaim `(special ,var)) - (set var value))) + (mapcar (lambda (name value) + (let ((var (intern name pcl))) + (proclaim `(special ,var)) + (set var value))) names values)) (dolist (sym *redefined-functions*) - (setf (symbol-function sym) (get sym ':definition-before-pcl))) + (setf (symbol-function sym) (get sym :definition-before-pcl))) nil)) (defun reset-package (&optional (package-name "PCL")) diff --git a/pcl/dfun.lisp b/pcl/dfun.lisp index f08117fe9500e38ede1a825a826a8f96568119e8..d58f920bd274c60ee6b80a3c2131d16ef913339a 100644 --- a/pcl/dfun.lisp +++ b/pcl/dfun.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.13 2001/10/30 22:50:58 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.14 2002/08/26 02:23:12 pmai Exp $") ;;; (in-package :pcl) @@ -115,10 +115,10 @@ And so, we are saved. (when (and *raise-metatypes-to-class-p* (member generator '(emit-checking emit-caching emit-in-checking-cache-p emit-constant-value))) - (setq args (cons (mapcar #'(lambda (mt) - (if (eq mt 't) - mt - 'class)) + (setq args (cons (mapcar (lambda (mt) + (if (eq mt t) + mt + 'class)) (car args)) (cdr args)))) (let* ((generator-entry (assq generator *dfun-constructors*)) @@ -166,13 +166,15 @@ And so, we are saved. (defmacro precompile-dfun-constructors (&optional system) (let ((*precompiling-lap* t)) `(progn - ,@(gathering1 (collecting) - (dolist (generator-entry *dfun-constructors*) + ,@(let ((collected ())) + (dolist (generator-entry *dfun-constructors* + (nreverse collected)) (dolist (args-entry (cdr generator-entry)) (when (or (null (caddr args-entry)) (eq (caddr args-entry) system)) - (when system (setf (caddr args-entry) system)) - (gather1 + (when system + (setf (caddr args-entry) system)) + (push (make-top-level-form `(precompile-dfun-constructor ,(car generator-entry)) '(load) @@ -181,7 +183,8 @@ And so, we are saved. ',(car args-entry) ',system ,(apply (symbol-function (car generator-entry)) - (car args-entry)))))))))))) + (car args-entry)))) + collected)))))))) ;;; @@ -322,13 +325,13 @@ And so, we are saved. (defun accessor-miss-function (gf dfun-info) (ecase (dfun-info-accessor-type dfun-info) (reader - #'(lambda (arg) - (declare (pcl-fast-call)) - (accessor-miss gf nil arg dfun-info))) + (lambda (arg) + (declare (pcl-fast-call)) + (accessor-miss gf nil arg dfun-info))) (writer - #'(lambda (new arg) - (declare (pcl-fast-call)) - (accessor-miss gf new arg dfun-info))))) + (lambda (new arg) + (declare (pcl-fast-call)) + (accessor-miss gf new arg dfun-info))))) (declaim (ext:freeze-type dfun-info)) @@ -411,7 +414,7 @@ And so, we are saved. (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info generic-function) (declare (ignore nreq)) - (if (every #'(lambda (mt) (eq mt 't)) metatypes) + (if (every (lambda (mt) (eq mt t)) metatypes) (let ((dfun-info (default-method-only-dfun-info))) (values (funcall (get-dfun-constructor 'emit-default-only metatypes applyp) @@ -424,20 +427,20 @@ And so, we are saved. (funcall (get-dfun-constructor 'emit-checking metatypes applyp) cache function - #'(lambda (&rest args) - (declare (pcl-fast-call)) - #+copy-&rest-arg (setq args (copy-list args)) - (checking-miss generic-function args dfun-info))) + (lambda (&rest args) + (declare (pcl-fast-call)) + #+copy-&rest-arg (setq args (copy-list args)) + (checking-miss generic-function args dfun-info))) cache dfun-info))))) (defun make-final-checking-dfun (generic-function function classes-list new-class) (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function)))) - (if (every #'(lambda (mt) (eq mt 't)) metatypes) - (values #'(lambda (&rest args) - #+copy-&rest-arg (setq args (copy-list args)) - (invoke-emf function args)) + (if (every (lambda (mt) (eq mt t)) metatypes) + (values (lambda (&rest args) + #+copy-&rest-arg (setq args (copy-list args)) + (invoke-emf function args)) nil (default-method-only-dfun-info)) (let ((cache (make-final-ordinary-dfun-internal generic-function nil #'checking-limit-fn @@ -448,14 +451,14 @@ And so, we are saved. (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info generic-function) (declare (ignore nreq applyp nkeys)) - (every #'(lambda (mt) (eq mt 't)) metatypes))) + (every (lambda (mt) (eq mt t)) metatypes))) (defun use-caching-dfun-p (generic-function) - (some #'(lambda (method) - (let ((fmf (if (listp method) - (third method) - (method-fast-function method)))) - (method-function-get fmf ':slot-name-lists))) + (some (lambda (method) + (let ((fmf (if (listp method) + (third method) + (method-fast-function method)))) + (method-function-get fmf :slot-name-lists))) (if (early-gf-p generic-function) (early-gf-methods generic-function) (generic-function-methods generic-function)))) @@ -481,10 +484,10 @@ And so, we are saved. (values (funcall (get-dfun-constructor 'emit-caching metatypes applyp) cache - #'(lambda (&rest args) - (declare (pcl-fast-call)) - #+copy-&rest-arg (setq args (copy-list args)) - (caching-miss generic-function args dfun-info))) + (lambda (&rest args) + (declare (pcl-fast-call)) + #+copy-&rest-arg (setq args (copy-list args)) + (caching-miss generic-function args dfun-info))) cache dfun-info)))) @@ -504,7 +507,7 @@ And so, we are saved. (when (and metatypes (not (null (car metatypes))) (dolist (mt metatypes nil) - (unless (eq mt 't) (return t)))) + (unless (eq mt t) (return t)))) (get-dfun-constructor 'emit-caching metatypes applyp)))) (defun use-constant-value-dfun-p (gf &optional boolean-values-p) @@ -519,19 +522,19 @@ And so, we are saved. (and (null applyp) (or (not (eq *boot-state* 'complete)) (compute-applicable-methods-emf-std-p gf)) - (notany #'(lambda (method) - (or (and (eq *boot-state* 'complete) - (some #'eql-specializer-p - (method-specializers method))) - (let ((value (method-function-get - (if early-p - (or (third method) (second method)) - (or (method-fast-function method) - (method-function method))) - :constant-value default))) - (if boolean-values-p - (not (or (eq value 't) (eq value nil))) - (eq value default))))) + (notany (lambda (method) + (or (and (eq *boot-state* 'complete) + (some #'eql-specializer-p + (method-specializers method))) + (let ((value (method-function-get + (if early-p + (or (third method) (second method)) + (or (method-fast-function method) + (method-function method))) + :constant-value default))) + (if boolean-values-p + (not (or (eq value t) (eq value nil))) + (eq value default))))) methods))))) (defun make-constant-value-dfun (generic-function &optional cache) @@ -543,10 +546,10 @@ And so, we are saved. (values (funcall (get-dfun-constructor 'emit-constant-value metatypes) cache - #'(lambda (&rest args) - (declare (pcl-fast-call)) - #+copy-&rest-arg (setq args (copy-list args)) - (constant-value-miss generic-function args dfun-info))) + (lambda (&rest args) + (declare (pcl-fast-call)) + #+copy-&rest-arg (setq args (copy-list args)) + (constant-value-miss generic-function args dfun-info))) cache dfun-info)))) @@ -595,21 +598,21 @@ And so, we are saved. (defun dispatch-dfun-cost (gf) (generate-discrimination-net-internal gf (generic-function-methods gf) nil - #'(lambda (methods known-types) - (declare (ignore methods known-types)) - 0) - #'(lambda (position type true-value false-value) - (declare (ignore position)) - (+ (max true-value false-value) - (if (eq 'class (car type)) - (let ((cpl (class-precedence-list (class-of (cadr type))))) - (cond((memq *the-class-built-in-class* cpl) - *built-in-typep-cost*) - ((memq *the-class-structure-class* cpl) - *structure-typep-cost*) - (t - *non-built-in-typep-cost*))) - 0))) + (lambda (methods known-types) + (declare (ignore methods known-types)) + 0) + (lambda (position type true-value false-value) + (declare (ignore position)) + (+ (max true-value false-value) + (if (eq 'class (car type)) + (let ((cpl (class-precedence-list (class-of (cadr type))))) + (cond((memq *the-class-built-in-class* cpl) + *built-in-typep-cost*) + ((memq *the-class-structure-class* cpl) + *structure-typep-cost*) + (t + *non-built-in-typep-cost*))) + 0))) #'identity)) ;; This version is from the pcl found in the gcl-2.1 distribution. @@ -617,27 +620,27 @@ And so, we are saved. (defun dispatch-dfun-cost (gf &optional limit) (generate-discrimination-net-internal gf (generic-function-methods gf) nil - #'(lambda (methods known-types) - (declare (ignore methods known-types)) - 0) - #'(lambda (position type true-value false-value) - (declare (ignore position)) - (let* ((type-test-cost - (if (eq 'class (car type)) - (let* ((metaclass (class-of (cadr type))) - (mcpl (class-precedence-list metaclass))) - (cond ((memq *the-class-built-in-class* mcpl) - *built-in-typep-cost*) - ((memq *the-class-structure-class* mcpl) - *structure-typep-cost*) - (t - *non-built-in-typep-cost*))) - 0)) - (max-cost-so-far - (+ (max true-value false-value) type-test-cost))) - (when (and limit (<= limit max-cost-so-far)) - (return-from dispatch-dfun-cost max-cost-so-far)) - max-cost-so-far)) + (lambda (methods known-types) + (declare (ignore methods known-types)) + 0) + (lambda (position type true-value false-value) + (declare (ignore position)) + (let* ((type-test-cost + (if (eq 'class (car type)) + (let* ((metaclass (class-of (cadr type))) + (mcpl (class-precedence-list metaclass))) + (cond ((memq *the-class-built-in-class* mcpl) + *built-in-typep-cost*) + ((memq *the-class-structure-class* mcpl) + *structure-typep-cost*) + (t + *non-built-in-typep-cost*))) + 0)) + (max-cost-so-far + (+ (max true-value false-value) type-test-cost))) + (when (and limit (<= limit max-cost-so-far)) + (return-from dispatch-dfun-cost max-cost-so-far)) + max-cost-so-far)) #'identity)) @@ -683,11 +686,11 @@ And so, we are saved. (defun fill-dfun-cache (table valuep nkeys limit-fn &optional cache) (let ((cache (or cache (get-cache nkeys valuep limit-fn (+ (hash-table-count table) 3))))) - (maphash #'(lambda (classes value) - (setq cache (fill-cache cache - (class-wrapper classes) - value - t))) + (maphash (lambda (classes value) + (setq cache (fill-cache cache + (class-wrapper classes) + value + t))) table) cache)) @@ -824,18 +827,18 @@ And so, we are saved. (let ((methods (if (early-gf-p gf) (early-gf-methods gf) (generic-function-methods gf)))) - (cond ((every #'(lambda (method) - (if (consp method) - (eq *the-class-standard-reader-method* - (early-method-class method)) - (standard-reader-method-p method))) + (cond ((every (lambda (method) + (if (consp method) + (eq *the-class-standard-reader-method* + (early-method-class method)) + (standard-reader-method-p method))) methods) 'reader) - ((every #'(lambda (method) - (if (consp method) - (eq *the-class-standard-writer-method* - (early-method-class method)) - (standard-writer-method-p method))) + ((every (lambda (method) + (if (consp method) + (eq *the-class-standard-writer-method* + (early-method-class method)) + (standard-writer-method-p method))) methods) 'writer)))) @@ -872,12 +875,12 @@ And so, we are saved. (no-methods-dfun-info))) ((setq type (final-accessor-dfun-type gf)) (make-final-accessor-dfun gf type classes-list new-class)) - ((and (not (and (every #'(lambda (specl) (eq specl *the-class-t*)) + ((and (not (and (every (lambda (specl) (eq specl *the-class-t*)) (setq specls (method-specializers (car methods)))) (setq all-same-p - (every #'(lambda (method) - (and (equal specls - (method-specializers method)))) + (every (lambda (method) + (and (equal specls + (method-specializers method)))) methods)))) (use-constant-value-dfun-p gf)) (make-final-constant-value-dfun gf classes-list new-class)) @@ -948,8 +951,8 @@ And so, we are saved. (setq oindex (dfun-info-index dfun-info)) (setq cache (dfun-info-cache dfun-info)) (if (eql nindex oindex) - (do-fill #'(lambda (ncache) - (one-index nindex ncache))) + (do-fill (lambda (ncache) + (one-index nindex ncache))) (n-n))) (n-n (setq cache (dfun-info-cache dfun-info)) @@ -1143,39 +1146,39 @@ And so, we are saved. (when (or (null specl-cpl) (member *the-class-structure-object* specl-cpl)) (return-from make-accessor-table nil)) - (maphash #'(lambda (class slotd) - (let ((cpl (if early-p - (early-class-precedence-list class) - (class-precedence-list class)))) - (when (memq specl cpl) - (unless (and (or so-p - (member *the-class-std-object* cpl)) - (or early-p - (slot-accessor-std-p slotd type))) - (return-from make-accessor-table nil)) - (push (cons specl slotd) (gethash class table))))) + (maphash (lambda (class slotd) + (let ((cpl (if early-p + (early-class-precedence-list class) + (class-precedence-list class)))) + (when (memq specl cpl) + (unless (and (or so-p + (member *the-class-std-object* cpl)) + (or early-p + (slot-accessor-std-p slotd type))) + (return-from make-accessor-table nil)) + (push (cons specl slotd) (gethash class table))))) (gethash slot-name *name->class->slotd-table*)))) - (maphash #'(lambda (class specl+slotd-list) - (dolist (sclass (if early-p - (early-class-precedence-list class) - (class-precedence-list class)) - (error "This can't happen")) - (let ((a (assq sclass specl+slotd-list))) - (when a - (let* ((slotd (cdr a)) - (index (if early-p - (early-slot-definition-location slotd) - (slot-definition-location slotd)))) - (unless index (return-from make-accessor-table nil)) - (setf (gethash class table) index) - (when (consp index) (setq no-class-slots-p nil)) - (setq all-index (if (or (null all-index) - (eql all-index index)) - index t)) - (incf size) - (cond ((= size 1) (setq first class)) - ((= size 2) (setq second class))) - (return nil)))))) + (maphash (lambda (class specl+slotd-list) + (dolist (sclass (if early-p + (early-class-precedence-list class) + (class-precedence-list class)) + (error "This can't happen")) + (let ((a (assq sclass specl+slotd-list))) + (when a + (let* ((slotd (cdr a)) + (index (if early-p + (early-slot-definition-location slotd) + (slot-definition-location slotd)))) + (unless index (return-from make-accessor-table nil)) + (setf (gethash class table) index) + (when (consp index) (setq no-class-slots-p nil)) + (setq all-index (if (or (null all-index) + (eql all-index index)) + index t)) + (incf size) + (cond ((= size 1) (setq first class)) + ((= size 2) (setq second class))) + (return nil)))))) table) (values table all-index first second size no-class-slots-p))) @@ -1211,13 +1214,13 @@ And so, we are saved. (defun sort-applicable-methods (precedence methods types) (sort-methods methods precedence - #'(lambda (class1 class2 index) - (let* ((class (type-class (nth index types))) - (cpl (if (eq *boot-state* 'complete) - (class-precedence-list class) - (early-class-precedence-list class)))) - (if (memq class2 (memq class1 cpl)) - class1 class2))))) + (lambda (class1 class2 index) + (let* ((class (type-class (nth index types))) + (cpl (if (eq *boot-state* 'complete) + (class-precedence-list class) + (early-class-precedence-list class)))) + (if (memq class2 (memq class1 cpl)) + class1 class2))))) (defun sort-methods (methods precedence compare-classes-function) (flet ((sorter (method1 method2) @@ -1310,7 +1313,7 @@ And so, we are saved. (defun compute-precedence (lambda-list nreq argument-precedence-order) (if (null argument-precedence-order) (let ((list nil))(dotimes (i nreq list) (push (- (1- nreq) i) list))) - (mapcar #'(lambda (x) (position x lambda-list)) argument-precedence-order))) + (mapcar (lambda (x) (position x lambda-list)) argument-precedence-order))) (defun saut-and (specl type) (let ((applicable nil) @@ -1416,11 +1419,11 @@ And so, we are saved. (defun specializer-applicable-using-type-p (specl type) (setq specl (type-from-specializer specl)) - (when (eq specl 't) + (when (eq specl t) (return-from specializer-applicable-using-type-p (values t t))) ;; This is used by c-a-m-u-t and generate-discrimination-net-internal, ;; and has only what they need. - (if (or (atom type) (eq (car type) 't)) + (if (or (atom type) (eq (car type) t)) (values nil t) (case (car type) (and (saut-and specl type)) @@ -1432,7 +1435,7 @@ And so, we are saved. (t (error "~s cannot handle the second argument ~s" 'specializer-applicable-using-type-p type))))) -(defun map-all-classes (function &optional (root 't)) +(defun map-all-classes (function &optional (root t)) (let ((braid-p (or (eq *boot-state* 'braid) (eq *boot-state* 'complete)))) (labels ((do-class (class) @@ -1472,14 +1475,14 @@ And so, we are saved. (all-sorted-p t) function-p) (if (null methods) (if function-p - #'(lambda (method-alist wrappers) - (declare (ignore method-alist wrappers)) - #'(kernel:instance-lambda (&rest args) - (apply #'no-applicable-method gf args))) - #'(lambda (method-alist wrappers) - (declare (ignore method-alist wrappers)) - #'(lambda (&rest args) - (apply #'no-applicable-method gf args)))) + (lambda (method-alist wrappers) + (declare (ignore method-alist wrappers)) + #'(kernel:instance-lambda (&rest args) + (apply #'no-applicable-method gf args))) + (lambda (method-alist wrappers) + (declare (ignore method-alist wrappers)) + (lambda (&rest args) + (apply #'no-applicable-method gf args)))) (let* ((key (car methods)) (ht-value (or (gethash key *effective-method-table*) (setf (gethash key *effective-method-table*) @@ -1599,26 +1602,26 @@ And so, we are saved. (incf (cdr b)))))) (defun count-all-dfuns () - (setq dfun-count (mapcar #'(lambda (type) (list type 0 nil)) + (setq dfun-count (mapcar (lambda (type) (list type 0 nil)) '(ONE-CLASS TWO-CLASS DEFAULT-METHOD-ONLY ONE-INDEX N-N CHECKING CACHING DISPATCH))) (map-all-generic-functions #'count-dfun) - (mapc #'(lambda (type+count+sizes) - (setf (third type+count+sizes) - (sort (third type+count+sizes) #'< :key #'car))) + (mapc (lambda (type+count+sizes) + (setf (third type+count+sizes) + (sort (third type+count+sizes) #'< :key #'car))) dfun-count) - (mapc #'(lambda (type+count+sizes) - (format t "~&There are ~4d dfuns of type ~s" - (cadr type+count+sizes) (car type+count+sizes)) - (format t "~% ~S~%" (caddr type+count+sizes))) + (mapc (lambda (type+count+sizes) + (format t "~&There are ~4d dfuns of type ~s" + (cadr type+count+sizes) (car type+count+sizes)) + (format t "~% ~S~%" (caddr type+count+sizes))) dfun-count) (values)) (defun gfs-of-type (type) (unless (consp type) (setq type (list type))) (let ((gf-list nil)) - (map-all-generic-functions #'(lambda (gf) - (when (memq (type-of (gf-dfun-info gf)) type) - (push gf gf-list)))) + (map-all-generic-functions (lambda (gf) + (when (memq (type-of (gf-dfun-info gf)) type) + (push gf gf-list)))) gf-list)) diff --git a/pcl/dlisp.lisp b/pcl/dlisp.lisp index fd203dabb124904e18e7f5ec17284af1b74b8729..98b71584835817aee5d4a4440f140394851c73ea 100644 --- a/pcl/dlisp.lisp +++ b/pcl/dlisp.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp.lisp,v 1.7 1999/05/30 23:13:58 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp.lisp,v 1.8 2002/08/26 02:23:13 pmai Exp $") ;;; (in-package :pcl) @@ -257,13 +257,13 @@ (defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs) (let* ((index -1) - (wrapper-bindings (mapcan #'(lambda (arg mt) - (unless (eq mt 't) - (incf index) - `((,(intern (format nil "WRAPPER-~D" index) - *the-pcl-package*) - ,(emit-fetch-wrapper mt arg 'miss - (pop slot-regs)))))) + (wrapper-bindings (mapcan (lambda (arg mt) + (unless (eq mt t) + (incf index) + `((,(intern (format nil "WRAPPER-~D" index) + *the-pcl-package*) + ,(emit-fetch-wrapper mt arg 'miss + (pop slot-regs)))))) args metatypes)) (wrappers (mapcar #'car wrapper-bindings))) (declare (fixnum index)) @@ -345,11 +345,11 @@ (block search (loop (setq next-location (the fixnum (+ location ,cache-line-size))) (when (and ,@(mapcar - #'(lambda (wrapper) - `(eq ,wrapper - (cache-vector-ref cache-vector - (setq location - (the fixnum (+ location 1)))))) + (lambda (wrapper) + `(eq ,wrapper + (cache-vector-ref cache-vector + (setq location + (the fixnum (+ location 1)))))) wrappers)) ,@(when value `((setq location (the fixnum (+ location 1))) @@ -361,8 +361,8 @@ (when (= location primary) (dolist (entry overflow) (let ((entry-wrappers (car entry))) - (when (and ,@(mapcar #'(lambda (wrapper) - `(eq ,wrapper (pop entry-wrappers))) + (when (and ,@(mapcar (lambda (wrapper) + `(eq ,wrapper (pop entry-wrappers))) wrappers)) ,@(when value `((setq ,value (cdr entry)))) @@ -386,19 +386,19 @@ `(progn ,@(let ((adds 0) (len (length wrappers))) (declare (fixnum adds len)) - (mapcar #'(lambda (wrapper) - `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref - ,wrapper field))) - (declare (fixnum wrapper-cache-no)) - (when (zerop wrapper-cache-no) (go ,miss-label)) - (setq primary (the fixnum (+ primary wrapper-cache-no))) - ,@(progn - (incf adds) - (when (or (zerop (mod adds wrapper-cache-number-adds-ok)) - (eql adds len)) - `((setq primary - ,(let ((form `(logand primary mask))) - `(the fixnum ,form)))))))) + (mapcar (lambda (wrapper) + `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref + ,wrapper field))) + (declare (fixnum wrapper-cache-no)) + (when (zerop wrapper-cache-no) (go ,miss-label)) + (setq primary (the fixnum (+ primary wrapper-cache-no))) + ,@(progn + (incf adds) + (when (or (zerop (mod adds wrapper-cache-number-adds-ok)) + (eql adds len)) + `((setq primary + ,(let ((form `(logand primary mask))) + `(the fixnum ,form)))))))) wrappers)))) ;;; cmu17 note: since std-instance-p is weakened, that branch may run diff --git a/pcl/dlisp2.lisp b/pcl/dlisp2.lisp index d2cf9e8faa8b18e77d68a6c2e7735383fcc59dfd..eb2e019077089da3c3063fc6d63468cac4fae37b 100644 --- a/pcl/dlisp2.lisp +++ b/pcl/dlisp2.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp2.lisp,v 1.7 1999/05/30 23:13:58 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp2.lisp,v 1.8 2002/08/26 02:23:13 pmai Exp $") ;;; (in-package :pcl) @@ -93,46 +93,46 @@ (cached-emf-p return-value-p metatypes applyp) (declare (ignore applyp)) (if cached-emf-p - #'(lambda (cache miss-fn) - (declare (type function miss-fn)) - #'(kernel:instance-lambda (&rest args) - (declare #.*optimize-speed*) - #+copy-&rest-arg (setq args (copy-list args)) - (with-dfun-wrappers (args metatypes) - (dfun-wrappers invalid-wrapper-p) - (apply miss-fn args) - (if invalid-wrapper-p - (apply miss-fn args) - (let ((emf (probe-cache cache dfun-wrappers not-in-cache))) - (if (eq emf not-in-cache) - (apply miss-fn args) - (if return-value-p - emf - (invoke-emf emf args)))))))) - #'(lambda (cache emf miss-fn) - (declare (type function miss-fn)) - #'(kernel:instance-lambda (&rest args) - (declare #.*optimize-speed*) - #+copy-&rest-arg (setq args (copy-list args)) - (with-dfun-wrappers (args metatypes) - (dfun-wrappers invalid-wrapper-p) - (apply miss-fn args) - (if invalid-wrapper-p - (apply miss-fn args) - (let ((found-p (not (eq not-in-cache - (probe-cache cache dfun-wrappers - not-in-cache))))) - (if found-p - (invoke-emf emf args) - (if return-value-p - t - (apply miss-fn args)))))))))) + (lambda (cache miss-fn) + (declare (type function miss-fn)) + #'(kernel:instance-lambda (&rest args) + (declare #.*optimize-speed*) + #+copy-&rest-arg (setq args (copy-list args)) + (with-dfun-wrappers (args metatypes) + (dfun-wrappers invalid-wrapper-p) + (apply miss-fn args) + (if invalid-wrapper-p + (apply miss-fn args) + (let ((emf (probe-cache cache dfun-wrappers not-in-cache))) + (if (eq emf not-in-cache) + (apply miss-fn args) + (if return-value-p + emf + (invoke-emf emf args)))))))) + (lambda (cache emf miss-fn) + (declare (type function miss-fn)) + #'(kernel:instance-lambda (&rest args) + (declare #.*optimize-speed*) + #+copy-&rest-arg (setq args (copy-list args)) + (with-dfun-wrappers (args metatypes) + (dfun-wrappers invalid-wrapper-p) + (apply miss-fn args) + (if invalid-wrapper-p + (apply miss-fn args) + (let ((found-p (not (eq not-in-cache + (probe-cache cache dfun-wrappers + not-in-cache))))) + (if found-p + (invoke-emf emf args) + (if return-value-p + t + (apply miss-fn args)))))))))) (defun emit-default-only-function (metatypes applyp) (declare (ignore metatypes applyp)) - (values #'(lambda (emf) - #'(lambda (&rest args) - #+copy-&rest-arg (setq args (copy-list args)) - (invoke-emf emf args))) + (values (lambda (emf) + (lambda (&rest args) + #+copy-&rest-arg (setq args (copy-list args)) + (invoke-emf emf args))) t)) diff --git a/pcl/env.lisp b/pcl/env.lisp index c1f325d9de9035c1321eb1fd308c7495942b49ae..3face3a5775abc0f0c2629f96d74ce3cd2fda1d0 100644 --- a/pcl/env.lisp +++ b/pcl/env.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/env.lisp,v 1.14 2002/06/05 23:00:11 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/env.lisp,v 1.15 2002/08/26 02:23:13 pmai Exp $") ;;; ;;; Basic environmental stuff. ;;; @@ -334,10 +334,10 @@ (macrolet ((frob (&rest names) `(progn - ,@(mapcar #'(lambda (name) - `(defmethod ,name ((class lisp:class)) - (funcall #',name - (coerce-to-pcl-class class)))) + ,@(mapcar (lambda (name) + `(defmethod ,name ((class lisp:class)) + (funcall #',name + (coerce-to-pcl-class class)))) names)))) (frob class-direct-slots diff --git a/pcl/extensions.lisp b/pcl/extensions.lisp index 524470cf5bc2230991fa4a31a0b8d98c8e21f2cc..463bf74bc9a91c5fc07e84a13abff8e22dfa1b37 100644 --- a/pcl/extensions.lisp +++ b/pcl/extensions.lisp @@ -18,7 +18,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/extensions.lisp,v 1.4 2002/08/24 13:46:52 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/extensions.lisp,v 1.5 2002/08/26 02:23:13 pmai Exp $") ;;; (in-package 'pcl) @@ -67,12 +67,12 @@ updater)) -(defun finalize-all-classes (&optional (root-name 't)) +(defun finalize-all-classes (&optional (root-name t)) "Makes sure that all classes are finalized. If Root-Name is supplied, then finalizes Root-Name and all of its subclasses and their subclasses." - (map-all-classes #'(lambda (class) - (unless (class-finalized-p class) - (finalize-inheritance class))) + (map-all-classes (lambda (class) + (unless (class-finalized-p class) + (finalize-inheritance class))) root-name)) @@ -111,7 +111,7 @@ (cond ((consp wrapper) `(let ((wrapper ,wrapper)) - (unless (eq (wrapper-state wrapper) 't) + (unless (eq (wrapper-state wrapper) t) (setf wrapper (wrapper-state-trap wrapper ,instance))) (with-slots-slot-value-from-index ,instance wrapper ,slot-name ,slots ,index ,variable-instance))) @@ -127,7 +127,7 @@ (cond ((consp wrapper) `(let ((wrapper ,wrapper)) - (unless (eq (wrapper-state wrapper) 't) + (unless (eq (wrapper-state wrapper) t) (setf wrapper (wrapper-state-trap wrapper ,instance))) (set-with-slots-slot-value-from-index ,instance wrapper ,slot-name ,slots ,index ,variable-instance @@ -153,7 +153,7 @@ ((consp wrapper) `(if *safe-to-use-slot-value-wrapper-optimizations-p* (let ((wrapper ,wrapper)) - (unless (eq (wrapper-state wrapper) 't) + (unless (eq (wrapper-state wrapper) t) (setf wrapper (wrapper-state-trap wrapper ,instance))) (slot-value-from-wrapper-and-slots ,instance ,slot-name wrapper ,slots-layout ,slots NIL)) @@ -174,7 +174,7 @@ ((consp wrapper) `(if *safe-to-use-set-slot-value-wrapper-optimizations-p* (let ((wrapper ,wrapper)) - (unless (eq (wrapper-state wrapper) 't) + (unless (eq (wrapper-state wrapper) t) (setf wrapper (wrapper-state-trap wrapper ,instance))) (setf (slot-value-from-wrapper-and-slots ,instance ,slot-name wrapper ,slots-layout ,slots NIL) @@ -299,16 +299,16 @@ #+pcl-user-instances (type-var-user 3) (slot-index-vars - (mapcar #'(lambda (slot-entry) - (list (car slot-entry) - (cdr slot-entry) - (gensym (concatenate - 'simple-string - (if (string= instance-string "") - "INSTANCE-FORM-" - instance-string) - (symbol-name (cdr slot-entry)) - "-INDEX")))) + (mapcar (lambda (slot-entry) + (list (car slot-entry) + (cdr slot-entry) + (gensym (concatenate + 'simple-string + (if (string= instance-string "") + "INSTANCE-FORM-" + instance-string) + (symbol-name (cdr slot-entry)) + "-INDEX")))) (remove-duplicates hard-accessors :key #'cdr))) (slots-layout-var (gensym (concatenate 'simple-string "SLOTS-LAYOUT-" instance-string))) @@ -394,33 +394,33 @@ prototype-form slot-index-vars))))) (symbol-macrolet (,@(mapcar - #'(lambda (slot-cons) - `(,(car slot-cons) - (with-slots-slot-value-from-index - ,instance-form-var - ,runtime-wrapper-form - ',(cdr slot-cons) - ,runtime-slots-form - ,(third (assoc (car slot-cons) slot-index-vars - :test #'eq)) - ,(when (and variable-instance - (not (eq variable-instance - instance-form-var))) + (lambda (slot-cons) + `(,(car slot-cons) + (with-slots-slot-value-from-index + ,instance-form-var + ,runtime-wrapper-form + ',(cdr slot-cons) + ,runtime-slots-form + ,(third (assoc (car slot-cons) slot-index-vars + :test #'eq)) + ,(when (and variable-instance + (not (eq variable-instance + instance-form-var))) variable-instance)))) hard-accessors) ,@(mapcar - #'(lambda (variable-cons) - `(,(car variable-cons) - (with-slots-slot-value-from-wrapper-and-slots + (lambda (variable-cons) + `(,(car variable-cons) + (with-slots-slot-value-from-wrapper-and-slots ,instance-form-var - ,(second variable-cons) - ,runtime-wrapper-form - ,slots-layout-var - ,runtime-slots-form - ,(when (and variable-instance - (not (eq variable-instance - instance-form-var))) - variable-instance)))) + ,(second variable-cons) + ,runtime-wrapper-form + ,slots-layout-var + ,runtime-slots-form + ,(when (and variable-instance + (not (eq variable-instance + instance-form-var))) + variable-instance)))) variable-accessors)) ,@body)))) @@ -428,16 +428,16 @@ prototype-form slot-index-vars) (declare (type list slot-index-vars)) - `((unless (eq (wrapper-state ,wrapper-var) 't) + `((unless (eq (wrapper-state ,wrapper-var) t) (setf ,wrapper-var (wrapper-state-trap ,wrapper-var ,prototype-form))) (setf ,slots-layout-var (wrapper-instance-slots-layout ,wrapper-var)) ,@(if (<= (length slot-index-vars) 2) (mapcar - #'(lambda (slot-cons) - `(setf ,(third slot-cons) - (instance-slot-index-from-slots-layout - ,slots-layout-var ',(second slot-cons)))) + (lambda (slot-cons) + `(setf ,(third slot-cons) + (instance-slot-index-from-slots-layout + ,slots-layout-var ',(second slot-cons)))) slot-index-vars) ;; More than two slots, so more efficient to search slots-layout-var ;; only once, rather than once for each with instance-slot-index. @@ -478,16 +478,16 @@ `((,instance-form-var ,instance-form)))) (symbol-macrolet (,@(mapcar - #'(lambda (slot-cons) - `(,(car slot-cons) - (accessor-slot-value ,instance-form-var - ',(cdr slot-cons)))) + (lambda (slot-cons) + `(,(car slot-cons) + (accessor-slot-value ,instance-form-var + ',(cdr slot-cons)))) hard-accessors) ,@(mapcar - #'(lambda (variable-cons) - `(,(car variable-cons) - (accessor-slot-value ,instance-form-var - ,(second variable-cons)))) + (lambda (variable-cons) + `(,(car variable-cons) + (accessor-slot-value ,instance-form-var + ,(second variable-cons)))) variable-accessors)) ,@body)))) diff --git a/pcl/fast-init.lisp b/pcl/fast-init.lisp index 2d091742fa12e09d1e8577f53ba9a3e03c6d65b9..931722f5bb09b92d0fc540619f51cc1f143e0a8f 100644 --- a/pcl/fast-init.lisp +++ b/pcl/fast-init.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/fast-init.lisp,v 1.7 2002/04/13 22:40:07 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/fast-init.lisp,v 1.8 2002/08/26 02:23:13 pmai Exp $") ;;; ;;; This file defines the optimized make-instance functions. ;;; @@ -59,7 +59,7 @@ (return nil)) (setq key (eval (pop initargs-tail))) (setq value (pop initargs-tail)) - (when (eq ':allow-other-keys key) + (when (eq :allow-other-keys key) (setq allow-other-keys-p value)) (push key keys)))) (let* ((class (eval class)) @@ -88,15 +88,15 @@ (defmacro expanding-make-instance (&rest forms &environment env) `(progn - ,@(mapcar #'(lambda (form) - (walk-form form env - #'(lambda (subform context env) - (declare (ignore env)) - (or (and (eq context ':eval) - (consp subform) - (eq (car subform) 'make-instance) - (expand-make-instance-form subform)) - subform)))) + ,@(mapcar (lambda (form) + (walk-form form env + (lambda (subform context env) + (declare (ignore env)) + (or (and (eq context :eval) + (consp subform) + (eq (car subform) 'make-instance) + (expand-make-instance-form subform)) + subform)))) forms))) (defmacro defconstructor @@ -146,7 +146,7 @@ (cached-name (intern (format nil "~A-CACHED-~A" type name)))) `(defmacro ,reader-name (info) `(let ((value (,',cached-name ,info))) - (if (eq value ':unknown) + (if (eq value :unknown) (progn (,',trap ,info ',',name) (,',cached-name ,info)) @@ -168,35 +168,35 @@ (defmacro define-initialize-info () (let ((cached-slot-names - (mapcar #'(lambda (name) - (intern (format nil "CACHED-~A" name))) + (mapcar (lambda (name) + (intern (format nil "CACHED-~A" name))) initialize-info-cached-slots)) (cached-names - (mapcar #'(lambda (name) - (intern (format nil "~A-CACHED-~A" - 'initialize-info name))) + (mapcar (lambda (name) + (intern (format nil "~A-CACHED-~A" + 'initialize-info name))) initialize-info-cached-slots))) `(progn (defstruct initialize-info key wrapper - ,@(mapcar #'(lambda (name) - `(,name :unknown)) + ,@(mapcar (lambda (name) + `(,name :unknown)) cached-slot-names)) (defmacro reset-initialize-info-internal (info) `(progn - ,@(mapcar #'(lambda (cname) - `(setf (,cname ,info) ':unknown)) + ,@(mapcar (lambda (cname) + `(setf (,cname ,info) :unknown)) ',cached-names))) (defun initialize-info-bound-slots (info) (let ((slots nil)) - ,@(mapcar #'(lambda (name cached-name) - `(unless (eq ':unknown (,cached-name info)) - (push ',name slots))) + ,@(mapcar (lambda (name cached-name) + `(unless (eq :unknown (,cached-name info)) + (push ',name slots))) initialize-info-cached-slots cached-names) slots)) - ,@(mapcar #'(lambda (name) - `(define-cached-reader initialize-info ,name - update-initialize-info-internal)) + ,@(mapcar (lambda (name) + `(define-cached-reader initialize-info ,name + update-initialize-info-internal)) initialize-info-cached-slots)))) (define-initialize-info) @@ -356,7 +356,7 @@ (setq class (find-class class))) (when (classp class) (unless (class-finalized-p class) (finalize-inheritance class))) - (let* ((initargs (mapcan #'(lambda (key) (list key nil)) keys)) + (let* ((initargs (mapcan (lambda (key) (list key nil)) keys)) (class-and-initargs (list* class initargs)) (make-instance (gdefinition 'make-instance)) (make-instance-methods @@ -377,8 +377,8 @@ (list* proto t initargs))))) (when (null make-instance-methods) (return-from get-make-instance-function - #'(lambda (class initargs) - (apply #'no-applicable-method make-instance class initargs)))) + (lambda (class initargs) + (apply #'no-applicable-method make-instance class initargs)))) (unless (and (null (cdr make-instance-methods)) (eq (car make-instance-methods) std-mi-meth) (null (cdr default-initargs-methods)) @@ -390,8 +390,8 @@ (eq (car (method-specializers meth)) *the-class-slot-object*) (and (null (cdr quals)) - (or (eq (car quals) ':before) - (eq (car quals) ':after))))))) + (or (eq (car quals) :before) + (eq (car quals) :after))))))) (and (every #'check-meth initialize-instance-methods) (every #'check-meth shared-initialize-methods)))) (return-from get-make-instance-function nil)) @@ -430,7 +430,7 @@ (defun complicated-instance-creation-method (m) (let ((qual (method-qualifiers m))) (if qual - (not (and (null (cdr qual)) (eq (car qual) ':after))) + (not (and (null (cdr qual)) (eq (car qual) :after))) (let ((specl (car (method-specializers m)))) (or (not (classp specl)) (not (eq 'slot-object (class-name specl)))))))) @@ -472,36 +472,36 @@ (std-si-meth (find-standard-ii-method shared-initialize-methods 'slot-object)) (shared-initfns - (nreverse (mapcar #'(lambda (method) - (make-effective-method-function - #'shared-initialize - `(call-method ,method nil) - nil lwrapper)) + (nreverse (mapcar (lambda (method) + (make-effective-method-function + #'shared-initialize + `(call-method ,method nil) + nil lwrapper)) (remove std-si-meth shared-initialize-methods)))) (std-ii-meth (find-standard-ii-method initialize-instance-methods 'slot-object)) (initialize-initfns - (nreverse (mapcar #'(lambda (method) - (make-effective-method-function - #'initialize-instance - `(call-method ,method nil) - nil lwrapper)) + (nreverse (mapcar (lambda (method) + (make-effective-method-function + #'initialize-instance + `(call-method ,method nil) + nil lwrapper)) (remove std-ii-meth initialize-instance-methods))))) - #'(lambda (class1 initargs) - (if (not (eq wrapper (class-wrapper class))) - (let* ((info (initialize-info (coerce-to-class class1) initargs)) - (fn (initialize-info-make-instance-function info))) - (declare (type function fn)) - (funcall fn class1 initargs)) - (let* ((instance (funcall allocate-function wrapper constants)) - (initargs (call-initialize-function initialize-function - instance initargs))) - (dolist (fn shared-initfns) - (invoke-effective-method-function fn t instance t initargs)) - (dolist (fn initialize-initfns) - (invoke-effective-method-function fn t instance initargs)) - instance)))))) + (lambda (class1 initargs) + (if (not (eq wrapper (class-wrapper class))) + (let* ((info (initialize-info (coerce-to-class class1) initargs)) + (fn (initialize-info-make-instance-function info))) + (declare (type function fn)) + (funcall fn class1 initargs)) + (let* ((instance (funcall allocate-function wrapper constants)) + (initargs (call-initialize-function initialize-function + instance initargs))) + (dolist (fn shared-initfns) + (invoke-effective-method-function fn t instance t initargs)) + (dolist (fn initialize-initfns) + (invoke-effective-method-function fn t instance initargs)) + instance)))))) (defun make-instance-function-complex (key class keys initialize-instance-methods @@ -514,35 +514,35 @@ #'shared-initialize shared-initialize-methods `((class-eq ,class) t t) `((,(find-standard-ii-method shared-initialize-methods 'slot-object) - ,#'(lambda (instance init-type &rest initargs) - (declare (ignore init-type)) - #+copy-&rest-arg (setq initargs (copy-list initargs)) - (call-initialize-function initialize-function - instance initargs) - instance))) + ,(lambda (instance init-type &rest initargs) + (declare (ignore init-type)) + #+copy-&rest-arg (setq initargs (copy-list initargs)) + (call-initialize-function initialize-function + instance initargs) + instance))) (list wrapper *the-wrapper-of-t* *the-wrapper-of-t*))) (initialize-instance (get-secondary-dispatch-function #'initialize-instance initialize-instance-methods `((class-eq ,class) t) `((,(find-standard-ii-method initialize-instance-methods 'slot-object) - ,#'(lambda (instance &rest initargs) - #+copy-&rest-arg (setq initargs (copy-list initargs)) - (invoke-effective-method-function - shared-initialize t instance t initargs)))) + ,(lambda (instance &rest initargs) + #+copy-&rest-arg (setq initargs (copy-list initargs)) + (invoke-effective-method-function + shared-initialize t instance t initargs)))) (list wrapper *the-wrapper-of-t*)))) - #'(lambda (class1 initargs) - (if (not (eq wrapper (class-wrapper class))) - (let* ((info (initialize-info (coerce-to-class class1) initargs)) - (fn (initialize-info-make-instance-function info))) - (declare (type function fn)) - (funcall fn class1 initargs)) - (let* ((initargs (call-initialize-function initargs-function - nil initargs)) - (instance (apply #'allocate-instance class initargs))) - (invoke-effective-method-function - initialize-instance t instance initargs) - instance)))))) + (lambda (class1 initargs) + (if (not (eq wrapper (class-wrapper class))) + (let* ((info (initialize-info (coerce-to-class class1) initargs)) + (fn (initialize-info-make-instance-function info))) + (declare (type function fn)) + (funcall fn class1 initargs)) + (let* ((initargs (call-initialize-function initargs-function + nil initargs)) + (instance (apply #'allocate-instance class initargs))) + (invoke-effective-method-function + initialize-instance t instance initargs) + instance)))))) (defun get-simple-initialization-function (class keys &optional allow-other-keys-arg) (let ((info (initialize-info class keys nil allow-other-keys-arg))) @@ -575,10 +575,10 @@ (default-initargs (class-default-initargs class)) (nkeys keys) (slots-alist - (mapcan #'(lambda (slot) - (mapcar #'(lambda (arg) - (cons arg slot)) - (slot-definition-initargs slot))) + (mapcan (lambda (slot) + (mapcar (lambda (arg) + (cons arg slot)) + (slot-definition-initargs slot))) (class-slots class))) (nslots nil)) (dolist (key nkeys) @@ -612,15 +612,15 @@ (wrapper (class-wrapper class)) (constants (when simple-p (make-list (wrapper-no-of-instance-slots wrapper) - ':initial-element *slot-unbound*))) + :initial-element *slot-unbound*))) (slots (class-slots class)) (slot-names (mapcar #'slot-definition-name slots)) - (slots-key (mapcar #'(lambda (slot) - (let ((index most-positive-fixnum)) - (dolist (key (slot-definition-initargs slot)) - (let ((pos (position key keys))) - (when pos (setq index (min index pos))))) - (cons slot index))) + (slots-key (mapcar (lambda (slot) + (let ((index most-positive-fixnum)) + (dolist (key (slot-definition-initargs slot)) + (let ((pos (position key keys))) + (when pos (setq index (min index pos))))) + (cons slot index))) slots)) (slots (stable-sort slots-key #'< :key #'cdr))) (let ((n-popped 0)) @@ -639,7 +639,7 @@ (let* ((slot (car slot+index)) (name (slot-definition-name slot))) (when (and (eql (cdr slot+index) most-positive-fixnum) - (or (eq si-slot-names 't) + (or (eq si-slot-names t) (member name si-slot-names))) (let* ((initform (slot-definition-initform slot)) (initfunction (slot-definition-initfunction slot)) @@ -710,7 +710,7 @@ (apply (the function (cadr entry)) args) `(call-initialize-instance-simple ,pv-cell ,form-list)))) #|| - #'(lambda (instance initargs) + (lambda (instance initargs) (initialize-instance-simple pv-cell form-list instance initargs)) ||# `(call-initialize-instance-simple ,pv-cell ,form-list)))) @@ -733,12 +733,14 @@ (defmacro precompile-iis-functions (&optional system) (let ((index -1)) `(progn - ,@(gathering1 (collecting) - (dolist (iis-entry *initialize-instance-simple-alist*) + ,@(let ((collected ())) + (dolist (iis-entry *initialize-instance-simple-alist* + (nreverse collected)) (when (or (null (caddr iis-entry)) (eq (caddr iis-entry) system)) - (when system (setf (caddr iis-entry) system)) - (gather1 + (when system + (setf (caddr iis-entry) system)) + (push (make-top-level-form `(precompile-initialize-instance-simple ,system ,(incf index)) '(load) @@ -746,7 +748,8 @@ ',(car iis-entry) #',(car iis-entry) ',system - ',(cdddr iis-entry)))))))))) + ',(cdddr iis-entry))) + collected))))))) (defun compile-iis-functions (after-p) (let ((*compile-make-instance-functions-p* t) @@ -849,9 +852,9 @@ `((instance-write-internal pv slots ,(const pv-offset) value ,default ,(typecase location - (fixnum ':instance) - (cons ':class) - (t ':default))))))) + (fixnum :instance) + (cons :class) + (t :default))))))) (skip-when-instance-boundp (let* ((pv-offset (cadr form)) (location (pvref pv pv-offset)) @@ -866,9 +869,9 @@ `(instance-boundp-internal pv slots ,(const pv-offset) ,default ,(typecase (pvref pv pv-offset) - (fixnum ':instance) - (cons ':class) - (t ':default)))) + (fixnum :instance) + (cons :class) + (t :default)))) ,@(let ((sforms (cons nil nil))) (dotimes (i (cadddr form) (car sforms)) (add-forms (first-form-to-lisp forms cvector pv) sforms))))))) @@ -903,10 +906,10 @@ (values `(lambda (pv-cell cvector) (declare (type ,cvector-type cvector)) - #'(lambda (instance initargs) - (declare #.*optimize-speed*) - (iis-body ,@body) - initargs)) + (lambda (instance initargs) + (declare #.*optimize-speed*) + (iis-body ,@body) + initargs)) (list pv-cell (coerce cvector cvector-type))))) diff --git a/pcl/fngen.lisp b/pcl/fngen.lisp index 4e2357902cf9e2c1fcdc4fab8a13559e20d63041..34c34a27c219c2a5e5dd1d64755ad40798003a6f 100644 --- a/pcl/fngen.lisp +++ b/pcl/fngen.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fngen.lisp,v 1.8 1999/05/30 23:14:00 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fngen.lisp,v 1.9 2002/08/26 02:23:14 pmai Exp $") ;;; (in-package :pcl) @@ -151,45 +151,44 @@ (let ((walk-form-expand-macros-p t)) (walk-form lambda nil - #'(lambda (f c e) - (declare (ignore e)) - (if (neq c :eval) - f - (let ((converted (funcall test-converter f))) - (values converted (neq converted f)))))))) + (lambda (f c e) + (declare (ignore e)) + (if (neq c :eval) + f + (let ((converted (funcall test-converter f))) + (values converted (neq converted f)))))))) (defun compute-code (lambda code-converter) (let ((walk-form-expand-macros-p t) (gensyms ())) (values (walk-form lambda nil - #'(lambda (f c e) - (declare (ignore e)) - (if (neq c :eval) - f - (multiple-value-bind (converted gens) - (funcall code-converter f) - (when gens (setq gensyms (append gensyms gens))) - (values converted (neq converted f)))))) + (lambda (f c e) + (declare (ignore e)) + (if (neq c :eval) + f + (multiple-value-bind (converted gens) + (funcall code-converter f) + (when gens (setq gensyms (append gensyms gens))) + (values converted (neq converted f)))))) gensyms))) (defun compute-constants (lambda constant-converter) - (let ((walk-form-expand-macros-p t)) ; doesn't matter here. - (macrolet ((appending () - `(let ((result ())) - (values #'(lambda (value) (setq result (append result value))) - #'(lambda ()result))))) - (gathering1 (appending) - (walk-form lambda - nil - #'(lambda (f c e) - (declare (ignore e)) - (if (neq c :eval) - f - (let ((consts (funcall constant-converter f))) - (if consts - (progn (gather1 consts) (values f t)) - f))))))))) + (let ((walk-form-expand-macros-p t) ; doesn't matter here. + (collected ())) + (walk-form lambda + nil + (lambda (f c e) + (declare (ignore e)) + (if (eq c :eval) + (let ((consts (funcall constant-converter f))) + (if consts + (progn + (setq collected (append collected consts)) + (values f t)) + f)) + f))) + collected)) ;;; @@ -197,12 +196,13 @@ ;;; (defmacro precompile-function-generators (&optional system) (let ((index -1)) - `(progn ,@(gathering1 (collecting) - (dolist (fgen *fgens*) + `(progn ,@(let ((collected ())) + (dolist (fgen *fgens* (nreverse collected)) (when (or (null (fgen-system fgen)) (eq (fgen-system fgen) system)) - (when system (setf (svref fgen 4) system)) - (gather1 + (when system + (setf (svref fgen 4) system)) + (push (make-top-level-form `(precompile-function-generators ,system ,(incf index)) '(load) @@ -211,7 +211,8 @@ ',(fgen-gensyms fgen) (function ,(fgen-generator-lambda fgen)) ',(fgen-generator-lambda fgen) - ',system))))))))) + ',system)) + collected))))))) (defun load-function-generator (test gensyms generator generator-lambda system) (store-fgen (make-fgen test gensyms generator generator-lambda system))) diff --git a/pcl/init.lisp b/pcl/init.lisp index f51f811f68c038d3b0b74d9a4247da427ccf6ade..a5f09304c96560efe11a5e469d42833b9d526f0f 100644 --- a/pcl/init.lisp +++ b/pcl/init.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.12 2002/08/23 18:31:06 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.13 2002/08/26 02:23:14 pmai Exp $") ;;; ;;; This file defines the initialization and related protocols. ;;; @@ -115,7 +115,7 @@ (class-slots (class-of previous))))) (dolist (slotd current-slotds) (if (and (not (memq (slot-definition-name slotd) previous-slot-names)) - (eq (slot-definition-allocation slotd) ':instance)) + (eq (slot-definition-allocation slotd) :instance)) (push (slot-definition-name slotd) added-slots))) (check-initargs-1 (class-of current) initargs @@ -137,7 +137,7 @@ (defmethod shared-initialize ((instance slot-object) slot-names &rest initargs) - (when (eq slot-names 't) + (when (eq slot-names t) (return-from shared-initialize (call-initialize-function (initialize-info-shared-initialize-t-function @@ -182,12 +182,12 @@ (when (memq initarg slot-initargs) (setf (slot-value-using-class class instance slotd) val) - (return 't)))) + (return t)))) ;; Try to initialize the slot from its initform. (if (and slot-names - (or (eq slot-names 't) + (or (eq slot-names t) (memq slot-name slot-names)) - (or (and (not std-p) (eq slot-names 't)) + (or (and (not std-p) (eq slot-names t)) (not (slot-boundp-using-class class instance slotd)))) (let ((initfunction (slot-definition-initfunction slotd))) (when initfunction @@ -208,12 +208,12 @@ (check-initargs-2-list initargs class legal error-p))))) (defun check-initargs-values (class call-list) - (let ((methods (mapcan #'(lambda (call) - (if (consp call) - (copy-list (compute-applicable-methods - (gdefinition (car call)) - (cdr call))) - (list call))) + (let ((methods (mapcan (lambda (call) + (if (consp call) + (copy-list (compute-applicable-methods + (gdefinition (car call)) + (cdr call))) + (list call))) call-list)) (legal (apply #'append (mapcar #'slot-definition-initargs (class-slots class))))) diff --git a/pcl/iterate.lisp b/pcl/iterate.lisp deleted file mode 100644 index 0f736bb2ed1dd7a2167fa2e46751028cdc05c98c..0000000000000000000000000000000000000000 --- a/pcl/iterate.lisp +++ /dev/null @@ -1,1264 +0,0 @@ -;;;-*- Package: ITERATE; Syntax: Common-Lisp; Base: 10 -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. -;;; All rights reserved. -;;; -;;; Use and copying of this software and preparation of derivative works -;;; based upon this software are permitted. Any distribution of this -;;; software or derivative works must comply with all applicable United -;;; States export control laws. -;;; -;;; This software is made available AS IS, and Xerox Corporation makes no -;;; warranty about the software, its performance or its conformity to any -;;; specification. -;;; -;;; Any person obtaining a copy of this software is requested to send their -;;; name and post office or electronic mail address to: -;;; CommonLoops Coordinator -;;; Xerox PARC -;;; 3333 Coyote Hill Rd. -;;; Palo Alto, CA 94304 -;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) -;;; -;;; Suggestions, comments and requests for improvements are also welcome. -;;; ************************************************************************* -;;; - -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/iterate.lisp,v 1.7 1999/05/30 23:14:01 pw Exp $") -;;; -;;; Original source {pooh/n}<pooh>vanmelle>lisp>iterate;4 created 27-Sep-88 12:35:33 - -(defpackage "ITERATE" (:use :common-lisp :walker) - (:export "ITERATE" "ITERATE*" "GATHERING" "GATHER" "WITH-GATHERING" - "INTERVAL" "ELEMENTS" "LIST-ELEMENTS" "LIST-TAILS" - "PLIST-ELEMENTS" "EACHTIME" "WHILE" "UNTIL" - "COLLECTING" "JOINING" "MAXIMIZING" "MINIMIZING" "SUMMING" - "*ITERATE-WARNINGS*")) - -(in-package "ITERATE") - -(defvar *iterate-warnings* :any "Controls whether warnings are issued for iterate/gather forms that aren't optimized. -NIL => never; :USER => those resulting from user code; T => always, even if it's the iteration macro that's suboptimal." - ) - -;;; ITERATE macro - - -(defmacro iterate (clauses &body body &environment env) - (optimize-iterate-form clauses body env)) - -(defun - simple-expand-iterate-form - (clauses body) - - ;; Expand ITERATE. This is the "formal semantics" expansion, which we never - ;; use. - (let* - ((block-name (gensym)) - (bound-var-lists (mapcar #'(lambda (clause) - (let ((names (first clause))) - (if (listp names) - names - (list names)))) - clauses)) - (generator-vars (mapcar #'(lambda (clause) - (declare (ignore clause)) - (gensym)) - clauses))) - `(block ,block-name - (let* - ,(mapcan #'(lambda (gvar clause var-list) - ; For each clause, bind a - ; generator temp to the clause, - ; then bind the specified - ; var(s) - (cons (list gvar (second clause)) - (copy-list var-list))) - generator-vars clauses bound-var-lists) - - ;; Note bug in formal semantics: there can be declarations in the head - ;; of BODY; they go here, rather than inside loop - (loop - ,@(mapcar - #'(lambda (var-list gen-var) - ; Set each bound variable (or - ; set of vars) to the result of - ; calling the corresponding - ; generator - `(multiple-value-setq - ,var-list - (funcall ,gen-var #'(lambda nil (return-from - ,block-name))))) - bound-var-lists generator-vars) - ,@body))))) - -(defparameter *iterate-temp-vars-list* - '(iterate-temp-1 iterate-temp-2 iterate-temp-3 iterate-temp-4 - iterate-temp-5 iterate-temp-6 iterate-temp-7 iterate-temp-8) - "Temp var names used by ITERATE expansions.") - -(defun - optimize-iterate-form - (clauses body iterate-env) - (let* - ((temp-vars *iterate-temp-vars-list*) - (block-name (gensym)) - (finish-form `(return-from ,block-name)) - (bound-vars (mapcan #'(lambda (clause) - (let ((names (first clause))) - (if (listp names) - (copy-list names) - (list names)))) - clauses)) - iterate-decls generator-decls update-forms bindings leftover-body) - (do ((tail bound-vars (cdr tail))) - ((null tail)) - ; Check for duplicates - (when (member (car tail) - (cdr tail)) - (warn "Variable appears more than once in ITERATE: ~S" (car tail)))) - (flet - ((get-iterate-temp nil - - ;; Make temporary var. Note that it is ok to re-use these symbols - ;; in each iterate, because they are not used within BODY. - (or (pop temp-vars) - (gensym)))) - (dolist (clause clauses) - (cond - ((or (not (consp clause)) - (not (consp (cdr clause)))) - (warn "Bad syntax in ITERATE: clause not of form (var iterator): ~S" - clause)) - (t - (unless (null (cddr clause)) - (warn - "Probable parenthesis error in ITERATE clause--more than 2 elements: ~S" - clause)) - (multiple-value-bind - (let-body binding-type let-bindings localdecls otherdecls extra-body) - (expand-into-let (second clause) - 'iterate iterate-env) - - ;; We have expanded the generator clause and parsed it into its LET - ;; pieces. - (prog* - ((vars (first clause)) - gen-args renamed-vars) - (setq vars (if (listp vars) - (copy-list vars) - (list vars))) - ; VARS is now a (fresh) list of - ; all iteration vars bound in - ; this clause - (cond - ((eq let-body :abort) - ; Already issued a warning - ; about malformedness - ) - ((null (setq let-body (function-lambda-p let-body 1))) - ; Not of the expected form - (let ((generator (second clause))) - (cond ((and (consp generator) - (fboundp (car generator))) - ; It looks ok--a macro or - ; function here--so the guy who - ; wrote it just didn't do it in - ; an optimizable way - (maybe-warn :definition "Could not optimize iterate clause ~S because generator not of form (LET[*] ... (FUNCTION (LAMBDA (finish) ...)))" - generator)) - (t ; Perhaps it's just a - ; misspelling? Probably user - ; error - (maybe-warn :user - "Iterate operator in clause ~S is not fboundp." - generator))) - (setq let-body :abort))) - (t - - ;; We have something of the form #'(LAMBDA (finisharg) ...), - ;; possibly with some LET bindings around it. LET-BODY = - ;; ((finisharg) ...). - (setq let-body (cdr let-body)) - (setq gen-args (pop let-body)) - (when let-bindings - - ;; The first transformation we want to perform is - ;; "LET-eversion": turn (let* ((generator (let (..bindings..) - ;; #'(lambda ...)))) ..body..) into (let* (..bindings.. - ;; (generator #'(lambda ...))) ..body..). This - ;; transformation is valid if nothing in body refers to any - ;; of the bindings, something we can assure by - ;; alpha-converting the inner let (substituting new names for - ;; each var). Of course, none of those vars can be special, - ;; but we already checked for that above. - (multiple-value-setq (let-bindings renamed-vars) - (rename-let-bindings let-bindings binding-type - iterate-env leftover-body #'get-iterate-temp)) - (setq leftover-body nil) - ; If there was any leftover - ; from previous, it is now - ; consumed - ) - - ;; The second transformation is substituting the body of the - ;; generator (LAMBDA (finish-arg) . gen-body) for its appearance - ;; in the update form (funcall generator #'(lambda () - ;; finish-form)), then simplifying that form. The requirement - ;; for this part is that the generator body not refer to any - ;; variables that are bound between the generator binding and the - ;; appearance in the loop body. The only variables bound in that - ;; interval are generator temporaries, which have unique names so - ;; are no problem, and the iteration variables remaining for - ;; subsequent clauses. We'll discover the story as we walk the - ;; body. - (multiple-value-bind - (finishdecl other rest) - (parse-declarations let-body gen-args) - (declare (ignore finishdecl)) - ; Pull out declares, if any, - ; separating out the one(s) - ; referring to the finish arg, - ; which we will throw away - (when other - ; Combine remaining decls with - ; decls extracted from the LET, - ; if any - (setq otherdecls (nconc otherdecls other))) - (setq let-body (cond - (otherdecls - ; There are interesting - ; declarations, so have to keep - ; it wrapped. - `(let nil (declare ,@otherdecls) - ,@rest)) - ((null (cdr rest)) - ; Only one form left - (first rest)) - (t `(progn ,@rest))))) - (unless (eq (setq let-body (iterate-transform-body let-body - iterate-env renamed-vars - (first gen-args) - finish-form bound-vars clause)) - :abort) - - ;; Skip the rest if transformation failed. Warning has - ;; already been issued. - - ;; Note possible further optimization: if LET-BODY expanded - ;; into (prog1 oldvalue prepare-for-next-iteration), as so - ;; many do, then we could in most cases split the PROG1 into - ;; two pieces: do the (setq var oldvalue) here, and do the - ;; prepare-for-next-iteration at the bottom of the loop. - ;; This does a slight optimization of the PROG1 and also - ;; rearranges the code in a way that a reasonably clever - ;; compiler might detect how to get rid of redundant - ;; variables altogether (such as happens with INTERVAL and - ;; LIST-TAILS); that would make the whole thing closer to - ;; what you might have coded by hand. However, to do this - ;; optimization, we need to assure that (a) the - ;; prepare-for-next-iteration refers freely to no vars other - ;; than the internal vars we have extracted from the LET, and - ;; (b) that the code has no side effects. These are both - ;; true for all the iterators defined by this module, but how - ;; shall we represent side-effect info and/or tap into the - ;; compiler's knowledge of same? - (when localdecls - ; There were declarations for - ; the generator locals--have to - ; keep them for later, and - ; rename the vars mentioned - (setq - generator-decls - (nconc - generator-decls - (mapcar - #'(lambda - (decl) - (let ((head (car decl))) - (cons head (if (eq head 'type) - (cons (second decl) - (sublis renamed-vars - (cddr decl))) - (sublis renamed-vars - (cdr decl)))))) - localdecls))))))) - - ;; Finished analyzing clause now. LET-BODY is the form which, when - ;; evaluated, returns updated values for the iteration variable(s) - ;; VARS. - (when (eq let-body :abort) - - ;; Some punt case: go with the formal semantics: bind a var to - ;; the generator, then call it in the update section - (let - ((gvar (get-iterate-temp)) - (generator (second clause))) - (setq - let-bindings - (list (list gvar generator))) - (setq let-body `(funcall ,gvar #'(lambda nil ,finish-form))))) - (push (mv-setq (copy-list vars) - let-body) - update-forms) - (dolist (v vars) - (declare (ignore v)) - ; Pop off the vars we have now - ; bound from the list of vars - ; to watch out for--we'll bind - ; them right now - (pop bound-vars)) - (setq bindings - (nconc bindings let-bindings - (cond (extra-body - ; There was some computation to - ; do after the bindings--here's - ; our chance - (cons (list (first vars) - `(progn ,@extra-body nil)) - (rest vars))) - (t vars)))))))))) - (do ((tail body (cdr tail))) - ((not (and (consp tail) - (consp (car tail)) - (eq (caar tail) - 'declare))) - - ;; TAIL now points at first non-declaration. If there were - ;; declarations, pop them off so they appear in the right place - (unless (eq tail body) - (setq iterate-decls (ldiff body tail)) - (setq body tail)))) - `(block ,block-name - (let* ,bindings ,@(and generator-decls - `((declare ,@generator-decls))) - ,@iterate-decls - ,@leftover-body - (loop ,@(nreverse update-forms) - ,@body))))) - -(defun expand-into-let (clause parent-name env) - - ;; Return values: Body, LET[*], bindings, localdecls, otherdecls, extra - ;; body, where BODY is a single form. If multiple forms in a LET, the - ;; preceding forms are returned as extra body. Returns :ABORT if it - ;; issued a punt warning. - (prog ((expansion clause) - expandedp binding-type let-bindings let-body) - expand - (multiple-value-setq (expansion expandedp) - (macroexpand-1 expansion env)) - (cond ((not (consp expansion)) - ; Shouldn't happen - ) - ((symbolp (setq binding-type (first expansion))) - (case binding-type - ((let let*) - (setq let-bindings (second expansion)) - ; List of variable bindings - (setq let-body (cddr expansion)) - (go handle-let)))) - ((and (consp binding-type) - (eq (car binding-type) - 'lambda) - (not (find-if #'(lambda (x) - (member x lambda-list-keywords) - ) - (setq let-bindings (second binding-type))) - ) - (eql (length (second expansion)) - (length let-bindings)) - (null (cddr expansion))) - ; A simple LAMBDA form can be - ; treated as LET - (setq let-body (cddr binding-type)) - (setq let-bindings (mapcar #'list let-bindings (second - expansion)) - ) - (setq binding-type 'let) - (go handle-let))) - - ;; Fall thru if not a LET - (cond (expandedp ; try expanding again - (go expand)) - (t ; Boring--return form as the - ; body - (return expansion))) - handle-let - (return (let ((locals (variables-from-let let-bindings)) - extra-body specials) - (multiple-value-bind - (localdecls otherdecls let-body) - (parse-declarations let-body locals) - (cond ((setq specials (extract-special-bindings - locals localdecls)) - (maybe-warn (cond ((find-if #'variable-globally-special-p - specials) - ; This could be the fault of a - ; user proclamation - :user) - (t :definition)) - - "Couldn't optimize ~S because expansion of ~S binds specials ~(~S ~)" - parent-name clause specials) - :abort) - (t (values (cond ((not (consp let-body)) - - ; Null body of LET? unlikely, - ; but someone else will likely - ; complain - nil) - ((null (cdr let-body)) - - ; A single expression, which we - ; hope is (function - ; (lambda...)) - (first let-body)) - (t - - ;; More than one expression. These are forms to - ;; evaluate after the bindings but before the - ;; generator form is returned. Save them to - ;; evaluate in the next convenient place. Note that - ;; this is ok, as there is no construct that can - ;; cause a LET to return prematurely (without - ;; returning also from some surrounding construct). - (setq extra-body - (butlast let-body)) - (car (last let-body)))) - binding-type let-bindings localdecls - otherdecls extra-body)))))))) - -(defun variables-from-let (bindings) - - ;; Return a list of the variables bound in the first argument to LET[*]. - (mapcar #'(lambda (binding) - (if (consp binding) - (first binding) - binding)) - bindings)) - -(defun iterate-transform-body (let-body iterate-env renamed-vars finish-arg - finish-form bound-vars clause) - - -;;; This is the second major transformation for a single iterate clause. -;;; LET-BODY is the body of the iterator after we have extracted its local -;;; variables and declarations. We have two main tasks: (1) Substitute -;;; internal temporaries for occurrences of the LET variables; the alist -;;; RENAMED-VARS specifies this transformation. (2) Substitute evaluation of -;;; FINISH-FORM for any occurrence of (funcall FINISH-ARG). Along the way, we -;;; check for forms that would invalidate these transformations: occurrence of -;;; FINISH-ARG outside of a funcall, and free reference to any element of -;;; BOUND-VARS. CLAUSE & TYPE are the original ITERATE clause and its type -;;; (ITERATE or ITERATE*), for purpose of error messages. On success, we -;;; return the transformed body; on failure, :ABORT. - - (walk-form let-body iterate-env - #'(lambda (form context env) - (declare (ignore context)) - - ;; Need to substitute RENAMED-VARS, as well as turn - ;; (FUNCALL finish-arg) into the finish form - (cond ((symbolp form) - (let (renaming) - (cond ((and (eq form finish-arg) - (variable-same-p form env - iterate-env)) - ; An occurrence of the finish - ; arg outside of FUNCALL - ; context--I can't handle this - (maybe-warn :definition "Couldn't optimize iterate form because generator ~S does something with its FINISH arg besides FUNCALL it." - (second clause)) - (return-from iterate-transform-body - :abort)) - ((and (setq renaming (assoc form - renamed-vars - )) - (variable-same-p form env - iterate-env)) - ; Reference to one of the vars - ; we're renaming - (cdr renaming)) - ((and (member form bound-vars) - (variable-same-p form env - iterate-env)) - ; FORM is a var that is bound - ; in this same ITERATE, or - ; bound later in this ITERATE*. - ; This is a conflict. - (maybe-warn :user "Couldn't optimize iterate form because generator ~S is closed over ~S, in conflict with a subsequent iteration variable." - (second clause) - form) - (return-from iterate-transform-body - :abort)) - (t form)))) - ((and (consp form) - (eq (first form) - 'funcall) - (eq (second form) - finish-arg) - (variable-same-p (second form) - env iterate-env)) - ; (FUNCALL finish-arg) => - ; finish-form - (unless (null (cddr form)) - (maybe-warn :definition - "Generator for ~S applied its finish arg to > 0 arguments ~S--ignored." - (second clause) - (cddr form))) - finish-form) - (t form))))) - -(defun - parse-declarations - (tail locals) - - ;; Extract the declarations from the head of TAIL and divide them into 2 - ;; classes: declares about variables in the list LOCALS, and all other - ;; declarations. Returns 3 values: those 2 lists plus the remainder of TAIL. - (let - (localdecls otherdecls form) - (loop - (unless (and tail (consp (setq form (car tail))) - (eq (car form) - 'declare)) - (return (values localdecls otherdecls tail))) - (mapc - #'(lambda - (decl) - (case (first decl) - ((inline notinline optimize) - ; These don't talk about vars - (push decl otherdecls)) - (t ; Assume all other kinds are - ; for vars - (let* ((vars (if (eq (first decl) - 'type) - (cddr decl) - (cdr decl))) - (l (intersection locals vars)) - other) - (cond - ((null l) - ; None talk about LOCALS - (push decl otherdecls)) - ((null (setq other (set-difference vars l))) - ; All talk about LOCALS - (push decl localdecls)) - (t ; Some of each - (let ((head (cons 'type (and (eq (first decl) - 'type) - (list (second decl)))))) - (push (append head other) - otherdecls) - (push (append head l) - localdecls)))))))) - (cdr form)) - (pop tail)))) - -(defun extract-special-bindings (vars decls) - - ;; Return the subset of VARS that are special, either globally or - ;; because of a declaration in DECLS - (let ((specials (remove-if-not #'variable-globally-special-p vars))) - (dolist (d decls) - (when (eq (car d) - 'special) - (setq specials (union specials (intersection vars - (cdr d)))))) - specials)) - -(defun function-lambda-p (form &optional nargs) - - ;; If FORM is #'(LAMBDA bindings . body) and bindings is of length - ;; NARGS, return the lambda expression - (let (args body) - (and (consp form) - (eq (car form) - 'function) - (consp (setq form (cdr form))) - (null (cdr form)) - (consp (setq form (car form))) - (eq (car form) - 'lambda) - (consp (setq body (cdr form))) - (listp (setq args (car body))) - (or (null nargs) - (eql (length args) - nargs)) - form))) - -(defun - rename-let-bindings - (let-bindings binding-type env leftover-body &optional tempvarfn) - - ;; Perform the alpha conversion required for "LET eversion" of (LET[*] - ;; LET-BINDINGS . body)--rename each of the variables to an internal name. - ;; Returns 2 values: a new set of LET bindings and the alist of old var names - ;; to new (so caller can walk the body doing the rest of the renaming). - ;; BINDING-TYPE is one of LET or LET*. LEFTOVER-BODY is optional list of - ;; forms that must be eval'ed before the first binding happens. ENV is the - ;; macro expansion environment, in case we have to walk a LET*. TEMPVARFN is - ;; a function of no args to return a temporary var; if omitted, we use - ;; GENSYM. - (let - (renamed-vars) - (values (mapcar #'(lambda (binding) - (let ((valueform (cond ((not (consp binding)) - - ; No initial value - nil) - ((or (eq binding-type - 'let) - (null renamed-vars)) - - ; All bindings are in parallel, - ; so none can refer to others - (second binding)) - (t - ; In a LET*, have to substitute - ; vars in the 2nd and - ; subsequent initialization - ; forms - (rename-variables - (second binding) - renamed-vars env)))) - (newvar (if tempvarfn - (funcall tempvarfn) - (gensym)))) - (push (cons (if (consp binding) - (first binding) - binding) - newvar) - renamed-vars) - ; Add new variable to the list - ; AFTER we have walked the - ; initial value form - (when leftover-body - - - ;; Previous clause had some computation to do after - ;; its bindings. Here is the first opportunity to - ;; do it - (setq valueform `(progn ,@leftover-body - ,valueform)) - (setq leftover-body nil)) - (list newvar valueform))) - let-bindings) - renamed-vars))) - -(defun rename-variables (form alist env) - - ;; Walks FORM, renaming occurrences of the key variables in ALIST with - ;; their corresponding values. ENV is FORM's environment, so we can - ;; make sure we are talking about the same variables. - (walk-form form env - #'(lambda (form context subenv) - (declare (ignore context)) - (let (pair) - (cond ((and (symbolp form) - (setq pair (assoc form alist)) - (variable-same-p form subenv env)) - (cdr pair)) - (t form)))))) - -(defun - mv-setq - (vars expr) - - ;; Produces (MULTIPLE-VALUE-SETQ vars expr), except that I'll optimize some - ;; of the simple cases for benefit of compilers that don't, and I don't care - ;; what the value is, and I know that the variables need not be set in - ;; parallel, since they can't be used free in EXPR - (cond - ((null vars) - ; EXPR is a side-effect - expr) - ((not (consp vars)) - ; This is an error, but I'll - ; let MULTIPLE-VALUE-SETQ - ; report it - `(multiple-value-setq ,vars ,expr)) - ((and (listp expr) - (eq (car expr) - 'values)) - - ;; (mv-setq (a b c) (values x y z)) can be reduced to a parallel setq - ;; (psetq returns nil, but I don't care about returned value). Do this - ;; even for the single variable case so that we catch (mv-setq (a) (values - ;; x y)) - (pop expr) - ; VALUES - `(setq ,@(mapcon #'(lambda (tail) - (list (car tail) - (cond ((or (cdr tail) - (null (cdr expr))) - ; One result expression for - ; this var - (pop expr)) - (t ; More expressions than vars, - ; so arrange to evaluate all - ; the rest now. - (cons 'prog1 expr))))) - vars))) - ((null (cdr vars)) - ; Simple one variable case - `(setq ,(car vars) - ,expr)) - (t ; General case--I know nothing - `(multiple-value-setq ,vars ,expr)))) - -(defun variable-same-p (var env1 env2) - (eq (variable-lexical-p var env1) - (variable-lexical-p var env2))) - -(defun maybe-warn (type &rest warn-args) - - ;; Issue a warning about not being able to optimize this thing. TYPE - ;; is one of :DEFINITION, meaning the definition is at fault, and - ;; :USER, meaning the user's code is at fault. - (when (case *iterate-warnings* - ((nil) nil) - ((:user) (eq type :user)) - (t t)) - (apply #'warn warn-args))) - - -;; Sample iterators - - -(defmacro - interval - (&whole whole &key from downfrom to downto above below by type) - (cond - ((and from downfrom) - (error "Can't use both FROM and DOWNFROM in ~S" whole)) - ((cdr (remove nil (list to downto above below))) - (error "Can't use more than one limit keyword in ~S" whole)) - (t - (let* - ((down (or downfrom downto above)) - (limit (or to downto above below)) - (inc (cond ((null by) - 1) - ((constantp by) - ; Can inline this increment - by)))) - `(let - ((from ,(or from downfrom 0)) - ,@(and limit `((to ,limit))) - ,@(and (null inc) - `((by ,by)))) - ,@(and type `((declare (type ,type from ,@(and limit '(to)) - ,@(and (null inc) - `(by)))))) - #'(lambda - (finish) - ,@(cond ((null limit) - ; We won't use the FINISH arg - '((declare (ignore finish))))) - (prog1 ,(cond (limit ; Test the limit. If ok, - ; return current value and - ; increment, else quit - `(if (,(cond (above '>) - (below '<) - (down '>=) - (t '<=)) - from to) - from - (funcall finish))) - (t ; No test - 'from)) - (setq from (,(if down - '- - '+) - from - ,(or inc 'by)))))))))) - -(defmacro list-elements (list &key (by '#'cdr)) - `(let ((tail ,list)) - #'(lambda (finish) - (prog1 (if (endp tail) - (funcall finish) - (first tail)) - (setq tail (funcall ,by tail)))))) - -(defmacro list-tails (list &key (by '#'cdr)) - `(let ((tail ,list)) - #'(lambda (finish) - (prog1 (if (endp tail) - (funcall finish) - tail) - (setq tail (funcall ,by tail)))))) - -(defmacro - elements - (sequence) - "Generates successive elements of SEQUENCE, with second value being the index. Use (ELEMENTS (THE type arg)) if you care about the type." - (let* - ((type (and (consp sequence) - (eq (first sequence) - 'the) - (second sequence))) - (accessor (if type - (sequence-accessor type) - 'elt)) - (listp (eq type 'list))) - - ;; If type is given via THE, we may be able to generate a good accessor here - ;; for the benefit of implementations that aren't smart about (ELT (THE - ;; STRING FOO)). I'm not bothering to keep the THE inside the body, - ;; however, since I assume any compiler that would understand (AREF (THE - ;; SIMPLE-ARRAY S)) would also understand that (AREF S) is the same when I - ;; bound S to (THE SIMPLE-ARRAY foo) and never modified it. - - ;; If sequence is declared to be a list, it's better to cdr down it, so we - ;; have some extra cases here. Normally folks would write LIST-ELEMENTS, - ;; but maybe they wanted to get the index for free... - `(let* ((index 0) - (s ,sequence) - ,@(and (not listp) - '((size (length s))))) - #'(lambda (finish) - (values (cond ,(if listp - '((not (endp s)) - (pop s)) - `((< index size) - (,accessor s index))) - (t (funcall finish))) - (prog1 index - (setq index (1+ index)))))))) - -(defmacro - plist-elements - (plist) - "Generates each time 2 items, the indicator and the value." - `(let ((tail ,plist)) - #'(lambda (finish) - (values (if (endp tail) - (funcall finish) - (first tail)) - (prog1 (if (endp (setq tail (cdr tail))) - (funcall finish) - (first tail)) - (setq tail (cdr tail))))))) - -(defun sequence-accessor (type) - - ;; returns the function with which most efficiently to make accesses to - ;; a sequence of type TYPE. - (case (if (consp type) - ; e.g., (VECTOR FLOAT *) - (car type) - type) - ((array simple-array vector) 'aref) - (simple-vector 'svref) - (string 'char) - (simple-string 'schar) - (bit-vector 'bit) - (simple-bit-vector 'sbit) - (t 'elt))) - - -;; These "iterators" may be withdrawn - - -(defmacro eachtime (expr) - `#'(lambda (finish) - (declare (ignore finish)) - ,expr)) - -(defmacro while (expr) - `#'(lambda (finish) - (unless ,expr (funcall finish)))) - -(defmacro until (expr) - `#'(lambda (finish) - (when ,expr (funcall finish)))) - - ; GATHERING macro - - -(defmacro gathering (clauses &body body &environment env) - (or (optimize-gathering-form clauses body env) - (simple-expand-gathering-form clauses body env))) - -(defmacro with-gathering (clauses gather-body &body use-body) - "Binds the variables specified in CLAUSES to the result of (GATHERING clauses gather-body) and evaluates the forms in USE-BODY inside that contour." - - ;; We may optimize this a little better later for those compilers that - ;; don't do a good job on (m-v-bind vars (... (values ...)) ...). - `(multiple-value-bind ,(mapcar #'car clauses) - (gathering ,clauses ,gather-body) - ,@use-body)) - -(defun - simple-expand-gathering-form - (clauses body env) - (declare (ignore env)) - - ;; The "formal semantics" of GATHERING. We use this only in cases that can't - ;; be optimized. - (let - ((acc-names (mapcar #'first (if (symbolp clauses) - ; Shorthand using anonymous - ; gathering site - (setq clauses `((*anonymous-gathering-site* - (,clauses)))) - clauses))) - (realizer-names (mapcar #'(lambda (binding) - (declare (ignore binding)) - (gensym)) - clauses))) - `(multiple-value-call - #'(lambda - ,(mapcan #'list acc-names realizer-names) - (flet ((gather (value &optional (accumulator *anonymous-gathering-site*) - ) - (funcall accumulator value))) - ,@body - (values ,@(mapcar #'(lambda (rname) - `(funcall ,rname)) - realizer-names)))) - ,@(mapcar #'second clauses)))) - -(defvar *active-gatherers* nil - "List of GATHERING bindings currently active during macro expansion)") - -(defvar *anonymous-gathering-site* nil "Variable used in formal expansion of an abbreviated GATHERING form (one with anonymous gathering site)." - ) - -(defun - optimize-gathering-form - (clauses body gathering-env) - (let* - (acc-info leftover-body top-bindings finish-forms top-decls) - (dolist (clause (if (symbolp clauses) - ; A shorthand - `((*anonymous-gathering-site* (,clauses))) - clauses)) - (multiple-value-bind - (let-body binding-type let-bindings localdecls otherdecls extra-body) - (expand-into-let (second clause) - 'gathering gathering-env) - (prog* - ((acc-var (first clause)) - renamed-vars accumulator realizer) - (when (and (consp let-body) - (eq (car let-body) - 'values) - (consp (setq let-body (cdr let-body))) - (setq accumulator (function-lambda-p (car let-body))) - (consp (setq let-body (cdr let-body))) - (setq realizer (function-lambda-p (car let-body) - 0)) - (null (cdr let-body))) - - ;; Macro returned something of the form (VALUES #'(lambda (value) - ;; ...) #'(lambda () ...)), a function to accumulate values and a - ;; function to realize the result. - (when binding-type - - ;; Gatherer expanded into a LET - (cond (otherdecls (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion carries declarations about more than the bound variables: ~S" - (second clause) - `(declare ,@otherdecls)) - (go punt))) - (when let-bindings - - ;; The first transformation we want to perform is a - ;; variant of "LET-eversion": turn (mv-bind (acc real) - ;; (let (..bindings..) (values #'(lambda ...) #'(lambda - ;; ...))) ..body..) into (let* (..bindings.. (acc - ;; #'(lambda ...)) (real #'(lambda ...))) ..body..). This - ;; transformation is valid if nothing in body refers to - ;; any of the bindings, something we can assure by - ;; alpha-converting the inner let (substituting new names - ;; for each var). Of course, none of those vars can be - ;; special, but we already checked for that above. - (multiple-value-setq (let-bindings renamed-vars) - (rename-let-bindings let-bindings binding-type - gathering-env leftover-body)) - (setq top-bindings (nconc top-bindings let-bindings)) - (setq leftover-body nil) - ; If there was any leftover - ; from previous, it is now - ; consumed - )) - (setq leftover-body (nconc leftover-body extra-body)) - ; Computation to do after these - ; bindings - (push (cons acc-var (rename-and-capture-variables accumulator - renamed-vars gathering-env)) - acc-info) - (setq realizer (rename-variables realizer renamed-vars - gathering-env)) - (push (cond ((null (cdddr realizer)) - ; Simple (LAMBDA () expr) => - ; expr - (third realizer)) - (t ; There could be declarations - ; or something, so leave as a - ; LET - (cons 'let (cdr realizer)))) - finish-forms) - (unless (null localdecls) - ; Declarations about the LET - ; variables also has to - ; percolate up - (setq top-decls (nconc top-decls (sublis renamed-vars - localdecls)))) - (return)) - (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion is not of the form (VALUES #'(LAMBDA ...) #'(LAMBDA () ...))" - (second clause)) - punt - (let - ((gs (gensym)) - (expansion `(multiple-value-list ,(second clause)))) - ; Slow way--bind gensym to the - ; macro expansion, and we will - ; funcall it in the body - (push (list acc-var gs) - acc-info) - (push `(funcall (cadr ,gs)) - finish-forms) - (setq - top-bindings - (nconc - top-bindings - (list (list gs (cond (leftover-body - `(progn ,@(prog1 leftover-body - (setq leftover-body nil)) - ,expansion)) - (t expansion)))))))))) - (setq body (walk-gathering-body body gathering-env acc-info)) - (cond ((eq body :abort) - ; Couldn't finish expansion - nil) - (t `(let* ,top-bindings - ,@(and top-decls `((declare ,@top-decls))) - ,body - ,(cond ((null (cdr finish-forms)) - ; just a single value - (car finish-forms)) - (t `(values ,@(reverse finish-forms))))))))) - -(defun rename-and-capture-variables (form alist env) - - ;; Walks FORM, renaming occurrences of the key variables in ALIST with - ;; their corresponding values, and capturing any other free variables. - ;; Returns a list of the new form and the list of other closed-over - ;; vars. ENV is FORM's environment, so we can make sure we are talking - ;; about the same variables. - (let (closed) - (list (walk-form - form env - #'(lambda (form context subenv) - (declare (ignore context)) - (let (pair) - (cond ((or (not (symbolp form)) - (not (variable-same-p form subenv - env))) - ; non-variable or one that has - ; been rebound - form) - ((setq pair (assoc form alist)) - ; One to rename - (cdr pair)) - (t ; var is free - (pushnew form closed) - form))))) - closed))) - -(defun - walk-gathering-body - (body gathering-env acc-info) - - ;; Walk the body of (GATHERING (...) . BODY) in environment GATHERING-ENV. - ;; ACC-INFO is a list of information about each of the gathering "bindings" - ;; in the form, in the form (var gatheringfn freevars env) - (let - ((*active-gatherers* (nconc (mapcar #'car acc-info) - *active-gatherers*))) - - ;; *ACTIVE-GATHERERS* tells us what vars are currently legal as GATHER - ;; targets. This is so that when we encounter a GATHER not belonging to us - ;; we can know whether to warn about it. - (walk-form - (cons 'progn body) - gathering-env - #'(lambda - (form context env) - (declare (ignore context)) - (let (info site) - (cond ((consp form) - (cond - ((not (eq (car form) - 'gather)) - ; We only care about GATHER - (when (and (eq (car form) - 'function) - (eq (cadr form) - 'gather)) - ; Passed as functional--can't - ; macroexpand - (maybe-warn :user - "Can't optimize GATHERING because of reference to #'GATHER." - ) - (return-from walk-gathering-body :abort)) - form) - ((setq info (assoc (setq site (if (null (cddr form)) - - ' - *anonymous-gathering-site* - (third form))) - acc-info)) - ; One of ours--expand (GATHER - ; value var). INFO = (var - ; gatheringfn freevars env) - (unless (null (cdddr form)) - (warn "Extra arguments (> 2) in ~S discarded." form) - ) - (let ((fn (second info))) - (cond ((symbolp fn) - ; Unoptimized case--just call - ; the gatherer. FN is the - ; gensym that we bound to the - ; list of two values returned - ; from the gatherer. - `(funcall (car ,fn) - ,(second form))) - (t ; FN = (lambda (value) ...) - (dolist (s (third info)) - (unless (or (variable-same-p s env - gathering-env) - (and (variable-special-p - s env) - (variable-special-p - s gathering-env))) - - - ;; Some var used free in the LAMBDA form has been - ;; rebound between here and the parent GATHERING - ;; form, so can't substitute the lambda. Ok if it's - ;; a special reference both here and in the LAMBDA, - ;; because then it's not closed over. - (maybe-warn :user "Can't optimize GATHERING because the expansion closes over the variable ~S, which is rebound around a GATHER for it." - s) - (return-from walk-gathering-body - :abort))) - - - ;; Return ((lambda (value) ...) actual-value). In - ;; many cases we could simplify this further by - ;; substitution, but we'd have to be careful (for - ;; example, we would need to alpha-convert any LET - ;; we found inside). Any decent compiler will do it - ;; for us. - (list fn (second form)))))) - ((and (setq info (member site *active-gatherers*)) - (or (eq site '*anonymous-gathering-site*) - (variable-same-p site env (fourth info)))) - ; Some other GATHERING will - ; take care of this form, so - ; pass it up for now. - ; Environment check is to make - ; sure nobody shadowed it - ; between here and there - form) - (t ; Nobody's going to handle it - (if (eq site '*anonymous-gathering-site*) - ; More likely that she forgot - ; to mention the site than - ; forget to write an anonymous - ; gathering. - (warn "There is no gathering site specified in ~S." - form) - (warn - "The site ~S in ~S is not defined in an enclosing GATHERING form." - site form)) - ; Turn it into something else - ; so we don't warn twice in the - ; nested case - `(%orphaned-gather ,@(cdr form))))) - ((and (symbolp form) - (setq info (assoc form acc-info)) - (variable-same-p form env gathering-env)) - ; A variable reference to a - ; gather binding from - ; environment TEM - (maybe-warn :user "Can't optimize GATHERING because site variable ~S is used outside of a GATHER form." - form) - (return-from walk-gathering-body :abort)) - (t form))))))) - - -;; Sample gatherers - - -(defmacro - collecting - (&key initial-value) - `(let* ((head ,initial-value) - (tail ,(and initial-value `(last head)))) - (values #'(lambda (value) - (if (null head) - (setq head (setq tail (list value))) - (setq tail (cdr (rplacd tail (list value)))))) - #'(lambda nil head)))) - -(defmacro joining (&key initial-value) - `(let ((result ,initial-value)) - (values #'(lambda (value) - (setq result (nconc result value))) - #'(lambda nil result)))) - -(defmacro - maximizing - (&key initial-value) - `(let ((result ,initial-value)) - (values - #'(lambda (value) - (when ,(cond ((and (constantp initial-value) - (not (null (eval initial-value)))) - ; Initial value is given and we - ; know it's not NIL, so leave - ; out the null check - '(> value result)) - (t '(or (null result) - (> value result)))) - (setq result value))) - #'(lambda nil result)))) - -(defmacro - minimizing - (&key initial-value) - `(let ((result ,initial-value)) - (values - #'(lambda (value) - (when ,(cond ((and (constantp initial-value) - (not (null (eval initial-value)))) - ; Initial value is given and we - ; know it's not NIL, so leave - ; out the null check - '(< value result)) - (t '(or (null result) - (< value result)))) - (setq result value))) - #'(lambda nil result)))) - -(defmacro summing (&key (initial-value 0)) - `(let ((sum ,initial-value)) - (values #'(lambda (value) - (setq sum (+ sum value))) - #'(lambda nil sum)))) - - ; Easier to read expanded code - ; if PROG1 gets left alone - - -(define-walker-template prog1 (nil return walker::repeat (eval))) - diff --git a/pcl/macros.lisp b/pcl/macros.lisp index f19dafd9d490c635803f05e63e433ccfdb91bdc1..4424a059d05b0b43f47df257eb54658b32ac936c 100644 --- a/pcl/macros.lisp +++ b/pcl/macros.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/macros.lisp,v 1.17 2002/08/24 13:46:52 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/macros.lisp,v 1.18 2002/08/26 02:23:14 pmai Exp $") ;;; ;;; Macros global variable definitions, and other random support stuff used ;;; by the rest of the system. @@ -113,7 +113,7 @@ (loop (cond ((not (listp form)) (return-from outer nil)) ((eq (car form) 'declare) - (return-from inner 't)) + (return-from inner t)) (t (multiple-value-bind (newform macrop) (macroexpand-1 form environment) @@ -166,17 +166,6 @@ (progn (setf ,alist (cons (,make-entry-fn ,key) ,alist)) (car ,alist))))) -(defmacro collecting-once (&key initial-value) - `(let* ((head ,initial-value) - (tail ,(and initial-value `(last head)))) - (values #'(lambda (value) - (if (null head) - (setq head (setq tail (list value))) - (unless (memq value head) - (setq tail - (cdr (rplacd tail (list value))))))) - #'(lambda nil head)))) - (defmacro doplist ((key val) plist &body body &environment env) (multiple-value-bind (doc decls bod) (extract-declarations body env) @@ -352,33 +341,6 @@ (setf (find-class-cell-predicate (find-class-cell symbol)) new-value) (error "~S is not a legal class name." symbol))) -(defmacro gathering1 (gatherer &body body) - `(gathering ((.gathering1. ,gatherer)) - (macrolet ((gather1 (x) `(gather ,x .gathering1.))) - ,@body))) - - -;;; -;;; These are augmented definitions of list-elements and list-tails from -;;; iterate.lisp. These versions provide the extra :by keyword which can -;;; be used to specify the step function through the list. -;;; -(defmacro *list-elements (list &key (by #'cdr)) - `(let ((tail ,list)) - #'(lambda (finish) - (if (endp tail) - (funcall finish) - (prog1 (car tail) - (setq tail (funcall ,by tail))))))) - -(defmacro *list-tails (list &key (by #'cdr)) - `(let ((tail ,list)) - #'(lambda (finish) - (prog1 (if (endp tail) - (funcall finish) - tail) - (setq tail (funcall ,by tail)))))) - (defmacro function-funcall (form &rest args) `(funcall (the function ,form) ,@args)) @@ -391,7 +353,7 @@ (defvar *redefined-functions* nil) (defmacro original-definition (name) - `(get ,name ':definition-before-pcl)) + `(get ,name :definition-before-pcl)) (defun redefine-function (name new) (pushnew name *redefined-functions*) diff --git a/pcl/methods.lisp b/pcl/methods.lisp index fb2e0f6d019053d3f44af2156c7488f2f1cdc635..17ace2a815257fd8137b452bf4901022dd3afb8f 100644 --- a/pcl/methods.lisp +++ b/pcl/methods.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.14 2001/03/13 15:49:48 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.15 2002/08/26 02:23:15 pmai Exp $") ;;; (in-package :pcl) @@ -444,12 +444,12 @@ (when original (add-named-method function-name () - (make-list nrequireds :initial-element 't) + (make-list nrequireds :initial-element t) arglist (list :function - #'(lambda (args next-methods) - (declare (ignore next-methods)) - (apply original args))))) + (lambda (args next-methods) + (declare (ignore next-methods)) + (apply original args))))) generic-function)))) @@ -523,10 +523,10 @@ ;; in the usual sort of way. For efficiency don't bother to ;; keep specialized-argument-positions sorted, rather depend ;; on our caller to do that. - (iterate ((type-spec (list-elements (method-specializers method))) - (pos (interval :from 0))) - (unless (eq type-spec *the-class-t*) - (pushnew pos specialized-argument-positions))) + (loop for type-spec in (method-specializers method) + and pos from 0 + unless (eq type-spec *the-class-t*) do + (pushnew pos specialized-argument-positions)) ;; Finally merge the values for this method into the values ;; for the exisiting methods and return them. Note that if ;; num-of-requireds is NIL it means this is the first method @@ -537,12 +537,10 @@ specialized-argument-positions))) (defun make-discriminating-function-arglist (number-required-arguments restp) - (nconc (gathering ((args (collecting))) - (iterate ((i (interval :from 0 :below number-required-arguments))) - (gather (intern (format nil "Discriminating Function Arg ~D" i)) - args))) + (nconc (loop for i below number-required-arguments + collect (intern (format nil "Discriminating Function Arg ~D" i))) (when restp - `(&rest ,(intern "Discriminating Function &rest Arg"))))) + (list '&rest (intern "Discriminating Function &rest Arg"))))) ;;; @@ -670,10 +668,10 @@ (types-from-arguments generic-function classes 'class-eq))) (defun proclaim-incompatible-superclasses (classes) - (setq classes (mapcar #'(lambda (class) - (if (symbolp class) - (find-class class) - class)) + (setq classes (mapcar (lambda (class) + (if (symbolp class) + (find-class class) + class)) classes)) (dolist (class classes) (dolist (other-class classes) @@ -737,7 +735,7 @@ (make-internal-reader-method-function 'standard-generic-function 'arg-info) t))) - #'(lambda (&rest args) (funcall mf args nil)))) + (lambda (&rest args) (funcall mf args nil)))) (defun types-from-arguments (generic-function arguments &optional type-modifier) (multiple-value-bind (nreq applyp metatypes nkeys arg-info) @@ -757,7 +755,7 @@ (defun get-wrappers-from-classes (nkeys wrappers classes metatypes) (let* ((w wrappers) (w-tail w) (mt-tail metatypes)) (dolist (class (if (listp classes) classes (list classes))) - (unless (eq 't (car mt-tail)) + (unless (eq t (car mt-tail)) (let ((c-w (class-wrapper class))) (unless c-w (return-from get-wrappers-from-classes nil)) (if (eql nkeys 1) @@ -783,13 +781,13 @@ :constant-value))) (defun default-secondary-dispatch-function (generic-function) - #'(lambda (&rest args) - #+copy-&rest-arg (setq args (copy-list args)) - (let ((methods (compute-applicable-methods generic-function args))) - (if methods - (let ((emf (get-effective-method-function generic-function methods))) - (invoke-emf emf args)) - (apply #'no-applicable-method generic-function args))))) + (lambda (&rest args) + #+copy-&rest-arg (setq args (copy-list args)) + (let ((methods (compute-applicable-methods generic-function args))) + (if methods + (let ((emf (get-effective-method-function generic-function methods))) + (invoke-emf emf args)) + (apply #'no-applicable-method generic-function args))))) (defun list-eq (x y) (loop (when (atom x) (return (eq x y))) @@ -820,8 +818,8 @@ (defun update-all-c-a-m-gf-info (c-a-m-gf) (let ((methods (generic-function-methods c-a-m-gf))) (if (and *old-c-a-m-gf-methods* - (every #'(lambda (old-method) - (member old-method methods)) + (every (lambda (old-method) + (member old-method methods)) *old-c-a-m-gf-methods*)) (let ((gfs-to-do nil) (gf-classes-to-do nil)) @@ -832,11 +830,11 @@ (pushnew (specializer-object specl) gfs-to-do) (pushnew (specializer-class specl) gf-classes-to-do))))) (map-all-generic-functions - #'(lambda (gf) - (when (or (member gf gfs-to-do) - (dolist (class gf-classes-to-do nil) - (member class (class-precedence-list (class-of gf))))) - (update-c-a-m-gf-info gf))))) + (lambda (gf) + (when (or (member gf gfs-to-do) + (dolist (class gf-classes-to-do nil) + (member class (class-precedence-list (class-of gf))))) + (update-c-a-m-gf-info gf))))) (map-all-generic-functions #'update-c-a-m-gf-info)) (setq *old-c-a-m-gf-methods* methods))) @@ -980,8 +978,8 @@ (eq spec *the-class-structure-object*))) (let ((sc (class-direct-subclasses spec))) (when sc - (mapcan #'(lambda (class) - (mec-all-classes-internal class precompute-p)) + (mapcan (lambda (class) + (mec-all-classes-internal class precompute-p)) sc)))))) (defun mec-all-classes (spec precompute-p) @@ -1004,8 +1002,8 @@ (list nil) (let* ((car-all-classes (mec-all-classes (car spec-list) precompute-p)) (all-class-lists (mec-all-class-lists (cdr spec-list) precompute-p))) - (mapcan #'(lambda (list) - (mapcar #'(lambda (c) (cons c list)) car-all-classes)) + (mapcan (lambda (list) + (mapcar (lambda (c) (cons c list)) car-all-classes)) all-class-lists)))) (defun make-emf-cache (generic-function valuep cache classes-list new-class) @@ -1036,7 +1034,7 @@ (defmacro class-test (arg class) (cond ((eq class *the-class-t*) - 't) + t) ((eq class *the-class-slot-object*) `(not (lisp:typep (lisp:class-of ,arg) 'lisp:built-in-class))) ((eq class *the-class-std-object*) @@ -1062,19 +1060,19 @@ (defmacro scase (arg &rest clauses) ; This is case, but without gensyms `(let ((.case-arg. ,arg)) - (cond ,@(mapcar #'(lambda (clause) - (list* (cond ((null (car clause)) - nil) - ((consp (car clause)) - (if (null (cdar clause)) - `(eql .case-arg. ',(caar clause)) - `(member .case-arg. ',(car clause)))) - ((member (car clause) '(t otherwise)) - `t) - (t - `(eql .case-arg. ',(car clause)))) - nil - (cdr clause))) + (cond ,@(mapcar (lambda (clause) + (list* (cond ((null (car clause)) + nil) + ((consp (car clause)) + (if (null (cdar clause)) + `(eql .case-arg. ',(caar clause)) + `(member .case-arg. ',(car clause)))) + ((member (car clause) '(t otherwise)) + `t) + (t + `(eql .case-arg. ',(car clause)))) + nil + (cdr clause))) clauses)))) (defmacro mcase (arg &rest clauses) `(scase ,arg ,@clauses)) @@ -1084,49 +1082,49 @@ (precedence (arg-info-precedence arg-info))) (generate-discrimination-net-internal generic-function methods types - #'(lambda (methods known-types) - (if (or sorted-p - (block one-order-p - (let ((sorted-methods nil)) - (map-all-orders - (copy-list methods) precedence - #'(lambda (methods) - (when sorted-methods (return-from one-order-p nil)) - (setq sorted-methods methods))) - (setq methods sorted-methods)) - t)) - `(methods ,methods ,known-types) - `(unordered-methods ,methods ,known-types))) - #'(lambda (position type true-value false-value) - (let ((arg (dfun-arg-symbol position))) - (if (eq (car type) 'eql) - (let* ((false-case-p (and (consp false-value) - (or (eq (car false-value) 'scase) - (eq (car false-value) 'mcase)) - (eq arg (cadr false-value)))) - (false-clauses (if false-case-p - (cddr false-value) - `((t ,false-value)))) - (case-sym (if (and (dnet-methods-p true-value) - (if false-case-p - (eq (car false-value) 'mcase) - (dnet-methods-p false-value))) - 'mcase - 'scase)) - (type-sym `(,(cadr type)))) - `(,case-sym ,arg - (,type-sym ,true-value) - ,@false-clauses)) - `(if ,(let ((arg (dfun-arg-symbol position))) - (case (car type) - (class `(class-test ,arg ,(cadr type))) - (class-eq `(class-eq-test ,arg ,(cadr type))))) - ,true-value - ,false-value)))) + (lambda (methods known-types) + (if (or sorted-p + (block one-order-p + (let ((sorted-methods nil)) + (map-all-orders + (copy-list methods) precedence + (lambda (methods) + (when sorted-methods (return-from one-order-p nil)) + (setq sorted-methods methods))) + (setq methods sorted-methods)) + t)) + `(methods ,methods ,known-types) + `(unordered-methods ,methods ,known-types))) + (lambda (position type true-value false-value) + (let ((arg (dfun-arg-symbol position))) + (if (eq (car type) 'eql) + (let* ((false-case-p (and (consp false-value) + (or (eq (car false-value) 'scase) + (eq (car false-value) 'mcase)) + (eq arg (cadr false-value)))) + (false-clauses (if false-case-p + (cddr false-value) + `((t ,false-value)))) + (case-sym (if (and (dnet-methods-p true-value) + (if false-case-p + (eq (car false-value) 'mcase) + (dnet-methods-p false-value))) + 'mcase + 'scase)) + (type-sym `(,(cadr type)))) + `(,case-sym ,arg + (,type-sym ,true-value) + ,@false-clauses)) + `(if ,(let ((arg (dfun-arg-symbol position))) + (case (car type) + (class `(class-test ,arg ,(cadr type))) + (class-eq `(class-eq-test ,arg ,(cadr type))))) + ,true-value + ,false-value)))) #'identity))) (defun class-from-type (type) - (if (or (atom type) (eq (car type) 't)) + (if (or (atom type) (eq (car type) t)) *the-class-t* (case (car type) (and (dolist (type (cdr type) *the-class-t*) @@ -1145,29 +1143,29 @@ (classes-list nil)) (generate-discrimination-net-internal gf methods nil - #'(lambda (methods known-types) - (when methods - (when classes-list-p - (push (mapcar #'class-from-type known-types) classes-list)) - (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p methods)))) - (map-all-orders - methods precedence - #'(lambda (methods) - (get-secondary-dispatch-function1 - gf methods known-types - nil caching-p no-eql-specls-p)))))) - #'(lambda (position type true-value false-value) - (declare (ignore position type true-value false-value)) - nil) - #'(lambda (type) - (if (and (consp type) (eq (car type) 'eql)) - `(class-eq ,(class-of (cadr type))) - type))) + (lambda (methods known-types) + (when methods + (when classes-list-p + (push (mapcar #'class-from-type known-types) classes-list)) + (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p methods)))) + (map-all-orders + methods precedence + (lambda (methods) + (get-secondary-dispatch-function1 + gf methods known-types + nil caching-p no-eql-specls-p)))))) + (lambda (position type true-value false-value) + (declare (ignore position type true-value false-value)) + nil) + (lambda (type) + (if (and (consp type) (eq (car type) 'eql)) + `(class-eq ,(class-of (cadr type))) + type))) classes-list)) ; we know that known-type implies neither new-type nor `(not ,new-type) (defun augment-type (new-type known-type) - (if (or (eq known-type 't) + (if (or (eq known-type t) (eq (car new-type) 'eql)) new-type (let ((so-far (if (and (consp known-type) (eq (car known-type) 'and)) @@ -1175,9 +1173,9 @@ (list known-type)))) (unless (eq (car new-type) 'not) (setq so-far - (mapcan #'(lambda (type) - (unless (*subtypep new-type type) - (list type))) + (mapcan (lambda (type) + (unless (*subtypep new-type type) + (list type))) so-far))) (if (null so-far) new-type @@ -1193,7 +1191,7 @@ (if p-tail (let* ((position (car p-tail)) (known-type (or (nth position types) t))) - (if (eq (nth position metatypes) 't) + (if (eq (nth position metatypes) t) (do-column (cdr p-tail) contenders (cons (cons position known-type) known-types)) (do-methods p-tail contenders @@ -1250,10 +1248,10 @@ (defvar *case-table-limit* 10) (defun compute-mcase-parameters (case-list) - (unless (eq 't (caar (last case-list))) + (unless (eq t (caar (last case-list))) (error "The key for the last case arg to mcase was not T")) (let* ((eq-p (dolist (case case-list t) - (unless (or (eq (car case) 't) + (unless (or (eq (car case) t) (symbolp (caar case))) (return nil)))) (len (1- (length case-list))) @@ -1269,7 +1267,7 @@ (list eq-p type))) (defmacro mlookup (key info default &optional eq-p type) - (unless (or (eq eq-p 't) (null eq-p)) + (unless (or (eq eq-p t) (null eq-p)) (error "Invalid eq-p argument")) (ecase type (:simple @@ -1321,15 +1319,15 @@ (case (car form) (mcase (let* ((mp (compute-mcase-parameters (cddr form))) - (list (mapcar #'(lambda (clause) - (let ((key (car clause)) - (meth (cadr clause))) - (cons (if (consp key) (car key) key) - (methods-converter - meth generic-function)))) + (list (mapcar (lambda (clause) + (let ((key (car clause)) + (meth (cadr clause))) + (cons (if (consp key) (car key) key) + (methods-converter + meth generic-function)))) (cddr form))) (default (car (last list)))) - (list (list* ':mcase mp (nbutlast list)) + (list (list* :mcase mp (nbutlast list)) (cdr default)))) (t (default-constant-converter form)))))) @@ -1349,11 +1347,11 @@ (defun convert-table (constant method-alist wrappers) (cond ((and (consp constant) - (eq (car constant) ':mcase)) - (let ((alist (mapcar #'(lambda (k+m) - (cons (car k+m) - (convert-methods (cdr k+m) - method-alist wrappers))) + (eq (car constant) :mcase)) + (let ((alist (mapcar (lambda (k+m) + (cons (car k+m) + (convert-methods (cdr k+m) + method-alist wrappers))) (cddr constant))) (mp (cadr constant))) (ecase (cadr mp) @@ -1399,29 +1397,29 @@ ,(make-emf-call metatypes applyp 'emf)))) #'net-test-converter #'net-code-converter - #'(lambda (form) - (net-constant-converter form generic-function))) - #'(lambda (method-alist wrappers) - (let* ((alist (list nil)) - (alist-tail alist)) - (dolist (constant constants) - (let* ((a (or (dolist (a alist nil) - (when (eq (car a) constant) - (return a))) - (cons constant - (or (convert-table - constant method-alist wrappers) - (convert-methods - constant method-alist wrappers))))) - (new (list a))) - (setf (cdr alist-tail) new) - (setf alist-tail new))) - (let ((function (apply cfunction (mapcar #'cdr (cdr alist))))) - (if function-p - function - (make-fast-method-call - :function (set-function-name function `(sdfun-method ,name)) - :arg-info fmc-arg-info)))))))))) + (lambda (form) + (net-constant-converter form generic-function))) + (lambda (method-alist wrappers) + (let* ((alist (list nil)) + (alist-tail alist)) + (dolist (constant constants) + (let* ((a (or (dolist (a alist nil) + (when (eq (car a) constant) + (return a))) + (cons constant + (or (convert-table + constant method-alist wrappers) + (convert-methods + constant method-alist wrappers))))) + (new (list a))) + (setf (cdr alist-tail) new) + (setf alist-tail new))) + (let ((function (apply cfunction (mapcar #'cdr (cdr alist))))) + (if function-p + function + (make-fast-method-call + :function (set-function-name function `(sdfun-method ,name)) + :arg-info fmc-arg-info)))))))))) (defvar *show-make-unordered-methods-emf-calls* nil) @@ -1429,12 +1427,12 @@ (when *show-make-unordered-methods-emf-calls* (format t "~&make-unordered-methods-emf ~s~%" (generic-function-name generic-function))) - #'(lambda (&rest args) - #+copy-&rest-arg (setq args (copy-list args)) - (let* ((types (types-from-arguments generic-function args 'eql)) - (smethods (sort-applicable-methods generic-function methods types)) - (emf (get-effective-method-function generic-function smethods))) - (invoke-emf emf args)))) + (lambda (&rest args) + #+copy-&rest-arg (setq args (copy-list args)) + (let* ((types (types-from-arguments generic-function args 'eql)) + (smethods (sort-applicable-methods generic-function methods types)) + (emf (get-effective-method-function generic-function smethods))) + (invoke-emf emf args)))) ;;; @@ -1464,7 +1462,7 @@ ;;; ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) ;;; (let ((std (call-next-method))) -;;; #'(lambda (arg) +;;; (lambda (arg) ;;; (print (list 'call-to-gf gf arg)) ;;; (funcall std arg)))) ;;; @@ -1491,7 +1489,7 @@ ;;; itself in accordance with this protocol: ;;; ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) -;;; #'(lambda (arg) +;;; (lambda (arg) ;;; (cond (<some condition> ;;; <store some info in the generic function> ;;; (set-funcallable-instance-function @@ -1504,11 +1502,11 @@ ;;; Whereas this code would not be legal: ;;; ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) -;;; #'(lambda (arg) +;;; (lambda (arg) ;;; (cond (<some condition> ;;; (set-funcallable-instance-function ;;; gf -;;; #'(lambda (a) ..)) +;;; (lambda (a) ..)) ;;; (funcall gf arg)) ;;; (t ;;; <call-a-method-of-gf>)))) @@ -1586,9 +1584,9 @@ (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters) (analyze-lambda-list ll) (declare (ignore nreq nopt keysp restp allow-other-keys-p keywords)) - (remove-if #'(lambda (s) - (or (memq s keyword-parameters) - (eq s '&allow-other-keys))) + (remove-if (lambda (s) + (or (memq s keyword-parameters) + (eq s '&allow-other-keys))) ll))) @@ -1639,7 +1637,7 @@ (cond ((eq arg '&optional) (setq state 'optional)) ((eq arg '&rest) (setq state 'rest)) ((eq arg '&key) (setq state 'key)) - ((eq arg '&allow-other-keys) (setq allow-other-keys 't)) + ((eq arg '&allow-other-keys) (setq allow-other-keys t)) ((memq arg lambda-list-keywords)) (t (ecase state diff --git a/pcl/pkg.lisp b/pcl/pkg.lisp index 7d4dea718f8308224c6ad721c8d222396de90c35..13e027f7396c3c7e89819ea63ebd979c630bf6df 100644 --- a/pcl/pkg.lisp +++ b/pcl/pkg.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/pkg.lisp,v 1.19 2002/08/24 16:20:25 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/pkg.lisp,v 1.20 2002/08/26 02:23:15 pmai Exp $") ;;; ;;; CMUCL 18a: Jan-1998 -- Changing to DEFPACKAGE. @@ -42,14 +42,7 @@ "VARIABLE-DECLARATION" "MACROEXPAND-ALL")) -(defpackage "ITERATE" (:use :common-lisp :walker) - (:export "ITERATE" "ITERATE*" "GATHERING" "GATHER" "WITH-GATHERING" - "INTERVAL" "ELEMENTS" "LIST-ELEMENTS" "LIST-TAILS" - "PLIST-ELEMENTS" "EACHTIME" "WHILE" "UNTIL" - "COLLECTING" "JOINING" "MAXIMIZING" "MINIMIZING" "SUMMING" - "*ITERATE-WARNINGS*")) - -(defpackage "PCL" (:use :common-lisp :walker :iterate) +(defpackage "PCL" (:use :common-lisp :walker) (:shadow "FIND-CLASS" "CLASS-NAME" "CLASS-OF" "CLASS" "BUILT-IN-CLASS" "STRUCTURE-CLASS" "STANDARD-CLASS") diff --git a/pcl/slots-boot.lisp b/pcl/slots-boot.lisp index 371ea967504e783eae7f800f96bf37e6fad34bca..cbf37af37defd3daa456764cbb6cbe13b4d20fc2 100644 --- a/pcl/slots-boot.lisp +++ b/pcl/slots-boot.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots-boot.lisp,v 1.9 2002/08/13 21:13:58 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots-boot.lisp,v 1.10 2002/08/26 02:23:15 pmai Exp $") ;;; (in-package :pcl) @@ -85,8 +85,8 @@ (defun make-structure-slot-boundp-function (slotd) (let* ((reader (slot-definition-internal-reader-function slotd)) - (fun #'(lambda (object) - (not (eq (funcall reader object) *slot-unbound*))))) + (fun (lambda (object) + (not (eq (funcall reader object) *slot-unbound*))))) (declare (type function reader)) fun)) @@ -120,21 +120,21 @@ (set-function-name (etypecase index (fixnum (if fsc-p - #'(lambda (instance) - (let ((value (%instance-ref (fsc-instance-slots instance) index))) - (if (eq value *slot-unbound*) - (slot-unbound (class-of instance) instance slot-name) - value))) - #'(lambda (instance) - (let ((value (%instance-ref (std-instance-slots instance) index))) - (if (eq value *slot-unbound*) - (slot-unbound (class-of instance) instance slot-name) - value))))) - (cons #'(lambda (instance) - (let ((value (cdr index))) - (if (eq value *slot-unbound*) - (slot-unbound (class-of instance) instance slot-name) - value))))) + (lambda (instance) + (let ((value (%instance-ref (fsc-instance-slots instance) index))) + (if (eq value *slot-unbound*) + (slot-unbound (class-of instance) instance slot-name) + value))) + (lambda (instance) + (let ((value (%instance-ref (std-instance-slots instance) index))) + (if (eq value *slot-unbound*) + (slot-unbound (class-of instance) instance slot-name) + value))))) + (cons (lambda (instance) + (let ((value (cdr index))) + (if (eq value *slot-unbound*) + (slot-unbound (class-of instance) instance slot-name) + value))))) `(reader ,slot-name))) (defun make-optimized-std-writer-method-function (fsc-p slot-name index) @@ -142,13 +142,13 @@ (set-function-name (etypecase index (fixnum (if fsc-p - #'(lambda (nv instance) - (setf (%instance-ref (fsc-instance-slots instance) index) nv)) - #'(lambda (nv instance) - (setf (%instance-ref (std-instance-slots instance) index) nv)))) - (cons #'(lambda (nv instance) - (declare (ignore instance)) - (setf (cdr index) nv)))) + (lambda (nv instance) + (setf (%instance-ref (fsc-instance-slots instance) index) nv)) + (lambda (nv instance) + (setf (%instance-ref (std-instance-slots instance) index) nv)))) + (cons (lambda (nv instance) + (declare (ignore instance)) + (setf (cdr index) nv)))) `(writer ,slot-name))) (defun make-optimized-std-boundp-method-function (fsc-p slot-name index) @@ -156,38 +156,38 @@ (set-function-name (etypecase index (fixnum (if fsc-p - #'(lambda (instance) - (not (eq (%instance-ref (fsc-instance-slots instance) - index) - *slot-unbound*))) - #'(lambda (instance) - (not (eq (%instance-ref (std-instance-slots instance) - index) - *slot-unbound*))))) - (cons #'(lambda (instance) - (declare (ignore instance)) - (not (eq (cdr index) *slot-unbound*))))) + (lambda (instance) + (not (eq (%instance-ref (fsc-instance-slots instance) + index) + *slot-unbound*))) + (lambda (instance) + (not (eq (%instance-ref (std-instance-slots instance) + index) + *slot-unbound*))))) + (cons (lambda (instance) + (declare (ignore instance)) + (not (eq (cdr index) *slot-unbound*))))) `(boundp ,slot-name))) (defun make-optimized-structure-slot-value-using-class-method-function (function) (declare (type function function)) - #'(lambda (class object slotd) - (let ((value (funcall function object))) - (if (eq value *slot-unbound*) - (slot-unbound class object (slot-definition-name slotd)) - value)))) + (lambda (class object slotd) + (let ((value (funcall function object))) + (if (eq value *slot-unbound*) + (slot-unbound class object (slot-definition-name slotd)) + value)))) (defun make-optimized-structure-setf-slot-value-using-class-method-function (function) (declare (type function function)) - #'(lambda (nv class object slotd) - (declare (ignore class slotd)) - (funcall function nv object))) + (lambda (nv class object slotd) + (declare (ignore class slotd)) + (funcall function nv object))) (defun make-optimized-structure-slot-boundp-using-class-method-function (function) (declare (type function function)) - #'(lambda (class object slotd) - (declare (ignore class slotd)) - (not (eq (funcall function object) *slot-unbound*)))) + (lambda (class object slotd) + (declare (ignore class slotd)) + (not (eq (funcall function object) *slot-unbound*)))) (defun get-optimized-std-slot-value-using-class-method-function (class slotd name) (if (structure-class-p class) @@ -219,26 +219,26 @@ (declare #.*optimize-speed*) (etypecase index (fixnum (if fsc-p - #'(lambda (class instance slotd) - (declare (ignore slotd)) - (unless (fsc-instance-p instance) (error "not fsc")) - (let ((value (%instance-ref (fsc-instance-slots instance) index))) - (if (eq value *slot-unbound*) - (slot-unbound class instance slot-name) - value))) - #'(lambda (class instance slotd) - (declare (ignore slotd)) - (unless (std-instance-p instance) (error "not std")) - (let ((value (%instance-ref (std-instance-slots instance) index))) - (if (eq value *slot-unbound*) - (slot-unbound class instance slot-name) - value))))) - (cons #'(lambda (class instance slotd) - (declare (ignore slotd)) - (let ((value (cdr index))) - (if (eq value *slot-unbound*) - (slot-unbound class instance slot-name) - value)))))) + (lambda (class instance slotd) + (declare (ignore slotd)) + (unless (fsc-instance-p instance) (error "not fsc")) + (let ((value (%instance-ref (fsc-instance-slots instance) index))) + (if (eq value *slot-unbound*) + (slot-unbound class instance slot-name) + value))) + (lambda (class instance slotd) + (declare (ignore slotd)) + (unless (std-instance-p instance) (error "not std")) + (let ((value (%instance-ref (std-instance-slots instance) index))) + (if (eq value *slot-unbound*) + (slot-unbound class instance slot-name) + value))))) + (cons (lambda (class instance slotd) + (declare (ignore slotd)) + (let ((value (cdr index))) + (if (eq value *slot-unbound*) + (slot-unbound class instance slot-name) + value)))))) (defun make-optimized-std-setf-slot-value-using-class-method-function (fsc-p slot-name index) @@ -246,15 +246,15 @@ (declare (ignore slot-name)) (etypecase index (fixnum (if fsc-p - #'(lambda (nv class instance slotd) - (declare (ignore class slotd)) - (setf (%instance-ref (fsc-instance-slots instance) index) nv)) - #'(lambda (nv class instance slotd) - (declare (ignore class slotd)) - (setf (%instance-ref (std-instance-slots instance) index) nv)))) - (cons #'(lambda (nv class instance slotd) - (declare (ignore class instance slotd)) - (setf (cdr index) nv))))) + (lambda (nv class instance slotd) + (declare (ignore class slotd)) + (setf (%instance-ref (fsc-instance-slots instance) index) nv)) + (lambda (nv class instance slotd) + (declare (ignore class slotd)) + (setf (%instance-ref (std-instance-slots instance) index) nv)))) + (cons (lambda (nv class instance slotd) + (declare (ignore class instance slotd)) + (setf (cdr index) nv))))) (defun make-optimized-std-slot-boundp-using-class-method-function (fsc-p slot-name index) @@ -262,32 +262,32 @@ (declare (ignore slot-name)) (etypecase index (fixnum (if fsc-p - #'(lambda (class instance slotd) - (declare (ignore class slotd)) - (not (eq (%instance-ref (fsc-instance-slots instance) - index) - *slot-unbound* ))) - #'(lambda (class instance slotd) - (declare (ignore class slotd)) - (not (eq (%instance-ref (std-instance-slots instance) - index) - *slot-unbound* ))))) - (cons #'(lambda (class instance slotd) - (declare (ignore class instance slotd)) - (not (eq (cdr index) *slot-unbound*)))))) + (lambda (class instance slotd) + (declare (ignore class slotd)) + (not (eq (%instance-ref (fsc-instance-slots instance) + index) + *slot-unbound* ))) + (lambda (class instance slotd) + (declare (ignore class slotd)) + (not (eq (%instance-ref (std-instance-slots instance) + index) + *slot-unbound* ))))) + (cons (lambda (class instance slotd) + (declare (ignore class instance slotd)) + (not (eq (cdr index) *slot-unbound*)))))) (defun get-accessor-from-svuc-method-function (class slotd sdfun name) (macrolet ((emf-funcall (emf &rest args) `(invoke-effective-method-function ,emf nil ,@args))) (set-function-name (case name - (reader #'(lambda (instance) (emf-funcall sdfun class instance slotd))) - (writer #'(lambda (nv instance) (emf-funcall sdfun nv class instance slotd))) - (boundp #'(lambda (instance) (emf-funcall sdfun class instance slotd)))) + (reader (lambda (instance) (emf-funcall sdfun class instance slotd))) + (writer (lambda (nv instance) (emf-funcall sdfun nv class instance slotd))) + (boundp (lambda (instance) (emf-funcall sdfun class instance slotd)))) `(,name ,(class-name class) ,(slot-definition-name slotd))))) (defun make-internal-reader-method-function (class-name slot-name) - (list* ':method-spec `(internal-reader-method ,class-name ,slot-name) + (list* :method-spec `(internal-reader-method ,class-name ,slot-name) (make-method-function (lambda (instance) (let ((wrapper (get-instance-wrapper-or-nil instance))) @@ -323,10 +323,10 @@ (instance-read-internal .pv. instance-slots 1 (slot-value instance slot-name)))))))) - (setf (getf (getf initargs ':plist) ':slot-name-lists) + (setf (getf (getf initargs :plist) :slot-name-lists) (list (list nil slot-name))) - (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol) - (list* ':method-spec `(reader-method ,class-name ,slot-name) + (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol) + (list* :method-spec `(reader-method ,class-name ,slot-name) initargs))) (defun make-std-writer-method-function (class-name slot-name) @@ -340,10 +340,10 @@ (instance-write-internal .pv. instance-slots 1 nv (setf (slot-value instance slot-name) nv)))))))) - (setf (getf (getf initargs ':plist) ':slot-name-lists) + (setf (getf (getf initargs :plist) :slot-name-lists) (list nil (list nil slot-name))) - (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol) - (list* ':method-spec `(writer-method ,class-name ,slot-name) + (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol) + (list* :method-spec `(writer-method ,class-name ,slot-name) initargs))) (defun make-std-boundp-method-function (class-name slot-name) @@ -357,10 +357,10 @@ (instance-boundp-internal .pv. instance-slots 1 (slot-boundp instance slot-name)))))))) - (setf (getf (getf initargs ':plist) ':slot-name-lists) + (setf (getf (getf initargs :plist) :slot-name-lists) (list (list nil slot-name))) - (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol) - (list* ':method-spec `(boundp-method ,class-name ,slot-name) + (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol) + (list* :method-spec `(boundp-method ,class-name ,slot-name) initargs))) (defun initialize-internal-slot-gfs (slot-name &optional type) diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index add1d32d2a14aecc525002c0e9e667bcb90ee248..e10a2a0f683b1d2d7b9eb9a4b4bea6623cc2d6e9 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.31 2002/08/19 16:43:15 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.32 2002/08/26 02:23:15 pmai Exp $") ;;; (in-package :pcl) @@ -233,10 +233,11 @@ (with-slots (direct-methods) specializer (or (cdr direct-methods) (setf (cdr direct-methods) - (gathering1 (collecting-once) - (dolist (m (car direct-methods)) - (gather1 (method-generic-function m)))))))) - + (loop for method in (car direct-methods) + for generic-function = (method-generic-function method) + unless (member generic-function collected :test #'eq) + collect generic-function into collected + finally (return collected)))))) ;;; @@ -282,31 +283,33 @@ (when entry (or (cdr entry) (setf (cdr entry) - (gathering1 (collecting-once) - (dolist (m (car entry)) - (gather1 (method-generic-function m))))))))) + (loop for method in (car entry) + for generic-function = (method-generic-function method) + unless (member generic-function collected :test #'eq) + collect generic-function into collected + finally (return collected))))))) (defun map-specializers (function) - (map-all-classes #'(lambda (class) - (funcall function (class-eq-specializer class)) - (funcall function class))) - (maphash #'(lambda (object methods) - (declare (ignore methods)) - (intern-eql-specializer object)) + (map-all-classes (lambda (class) + (funcall function (class-eq-specializer class)) + (funcall function class))) + (maphash (lambda (object methods) + (declare (ignore methods)) + (intern-eql-specializer object)) *eql-specializer-methods*) - (maphash #'(lambda (object specl) - (declare (ignore object)) - (funcall function specl)) + (maphash (lambda (object specl) + (declare (ignore object)) + (funcall function specl)) *eql-specializer-table*) nil) (defun map-all-generic-functions (function) (let ((all-generic-functions (make-hash-table :test 'eq))) - (map-specializers #'(lambda (specl) - (dolist (gf (specializer-direct-generic-functions specl)) - (unless (gethash gf all-generic-functions) - (setf (gethash gf all-generic-functions) t) - (funcall function gf)))))) + (map-specializers (lambda (specl) + (dolist (gf (specializer-direct-generic-functions specl)) + (unless (gethash gf all-generic-functions) + (setf (gethash gf all-generic-functions) t) + (funcall function gf)))))) nil) (defmethod shared-initialize :after ((specl class-eq-specializer) slot-names &key) @@ -465,20 +468,21 @@ (setq direct-slots (if direct-slots-p (setf (slot-value class 'direct-slots) - (mapcar #'(lambda (pl) (make-direct-slotd class pl)) direct-slots)) + (mapcar (lambda (pl) (make-direct-slotd class pl)) direct-slots)) (slot-value class 'direct-slots))) (if direct-default-initargs-p (setf (plist-value class 'direct-default-initargs) direct-default-initargs) (setq direct-default-initargs (plist-value class 'direct-default-initargs))) (setf (plist-value class 'class-slot-cells) - (gathering1 (collecting) - (dolist (dslotd direct-slots) + (let ((collected ())) + (dolist (dslotd direct-slots (nreverse collected)) (when (eq (slot-definition-allocation dslotd) class) (let ((initfunction (slot-definition-initfunction dslotd))) - (gather1 (cons (slot-definition-name dslotd) - (if initfunction - (funcall initfunction) - *slot-unbound*)))))))) + (push (cons (slot-definition-name dslotd) + (if initfunction + (funcall initfunction) + *slot-unbound*)) + collected)))))) (setq predicate-name (if predicate-name-p (setf (slot-value class 'predicate-name) (car predicate-name)) @@ -505,8 +509,8 @@ &rest initargs &key) (map-dependents class - #'(lambda (dependent) - (apply #'update-dependent class dependent initargs)))) + (lambda (dependent) + (apply #'update-dependent class dependent initargs)))) (defmethod shared-initialize :after ((class structure-class) @@ -529,15 +533,15 @@ (if direct-slots-p (setf (slot-value class 'direct-slots) (setq direct-slots - (mapcar #'(lambda (pl) - (when defstruct-p - (let* ((slot-name (getf pl :name)) - (acc-name (format nil "~s structure class ~a" - name slot-name)) - (accessor (intern acc-name))) - (setq pl (list* :defstruct-accessor-symbol accessor - pl)))) - (make-direct-slotd class pl)) + (mapcar (lambda (pl) + (when defstruct-p + (let* ((slot-name (getf pl :name)) + (acc-name (format nil "~s structure class ~a" + name slot-name)) + (accessor (intern acc-name))) + (setq pl (list* :defstruct-accessor-symbol accessor + pl)))) + (make-direct-slotd class pl)) direct-slots))) (setq direct-slots (slot-value class 'direct-slots))) (when defstruct-p @@ -550,45 +554,45 @@ (:predicate nil) (:conc-name ,conc-name) (:constructor ,constructor ())) - ,@(mapcar #'(lambda (slot) - `(,(slot-definition-name slot) - *slot-unbound*)) + ,@(mapcar (lambda (slot) + `(,(slot-definition-name slot) + *slot-unbound*)) direct-slots))) - (reader-names (mapcar #'(lambda (slotd) - (intern (format nil "~A~A reader" conc-name - (slot-definition-name slotd)))) + (reader-names (mapcar (lambda (slotd) + (intern (format nil "~A~A reader" conc-name + (slot-definition-name slotd)))) direct-slots)) - (writer-names (mapcar #'(lambda (slotd) - (intern (format nil "~A~A writer" conc-name - (slot-definition-name slotd)))) + (writer-names (mapcar (lambda (slotd) + (intern (format nil "~A~A writer" conc-name + (slot-definition-name slotd)))) direct-slots)) (readers-init - (mapcar #'(lambda (slotd reader-name) - (let ((accessor - (slot-definition-defstruct-accessor-symbol slotd))) - `(defun ,reader-name (obj) - (declare (type ,name obj)) - (,accessor obj)))) + (mapcar (lambda (slotd reader-name) + (let ((accessor + (slot-definition-defstruct-accessor-symbol slotd))) + `(defun ,reader-name (obj) + (declare (type ,name obj)) + (,accessor obj)))) direct-slots reader-names)) (writers-init - (mapcar #'(lambda (slotd writer-name) - (let ((accessor - (slot-definition-defstruct-accessor-symbol slotd))) - `(defun ,writer-name (nv obj) - (declare (type ,name obj)) - (setf (,accessor obj) nv)))) + (mapcar (lambda (slotd writer-name) + (let ((accessor + (slot-definition-defstruct-accessor-symbol slotd))) + `(defun ,writer-name (nv obj) + (declare (type ,name obj)) + (setf (,accessor obj) nv)))) direct-slots writer-names)) (defstruct-form `(progn ,defstruct ,@readers-init ,@writers-init))) (unless (structure-type-p name) (eval defstruct-form)) - (mapc #'(lambda (dslotd reader-name writer-name) - (let* ((reader (gdefinition reader-name)) - (writer (when (fboundp writer-name) - (gdefinition writer-name)))) - (setf (slot-value dslotd 'internal-reader-function) reader) - (setf (slot-value dslotd 'internal-writer-function) writer))) + (mapc (lambda (dslotd reader-name writer-name) + (let* ((reader (gdefinition reader-name)) + (writer (when (fboundp writer-name) + (gdefinition writer-name)))) + (setf (slot-value dslotd 'internal-reader-function) reader) + (setf (slot-value dslotd 'internal-writer-function) writer))) direct-slots reader-names writer-names) (setf (slot-value class 'defstruct-form) defstruct-form) (setf (slot-value class 'defstruct-constructor) constructor)))) @@ -718,10 +722,8 @@ (cond ((null owrapper) (make-wrapper nslots class)) ((and (equal nlayout olayout) - (not - (iterate ((o (list-elements owrapper-class-slots)) - (n (list-elements nwrapper-class-slots))) - (unless (eq (car o) (car n)) (return t))))) + (every (lambda (o n) (eq (car o) (car n))) + owrapper-class-slots nwrapper-class-slots)) owrapper) (t ;; @@ -745,18 +747,15 @@ (update-pv-table-cache-info class))))) (defun compute-class-slots (eslotds) - (gathering1 (collecting) - (dolist (eslotd eslotds) - (gather1 - (assoc (slot-definition-name eslotd) - (class-slot-cells (slot-definition-allocation eslotd))))))) + (loop for eslotd in eslotds + for name = (slot-definition-name eslotd) + and allocation = (slot-definition-allocation eslotd) + collect (assoc name (class-slot-cells allocation)))) (defun compute-layout (cpl instance-eslotds) - (let* ((names - (gathering1 (collecting) - (dolist (eslotd instance-eslotds) - (when (eq (slot-definition-allocation eslotd) :instance) - (gather1 (slot-definition-name eslotd)))))) + (let* ((names (loop for eslotd in instance-eslotds + when (eq (slot-definition-allocation eslotd) :instance) + collect (slot-definition-name eslotd))) (order ())) (labels ((rwalk (tail) (when tail @@ -782,9 +781,9 @@ (setf (gethash gf gf-table) t)) (mapc #'collect-gfs (class-direct-superclasses class)))) (collect-gfs class) - (maphash #'(lambda (gf ignore) - (declare (ignore ignore)) - (update-gf-dfun class gf)) + (maphash (lambda (gf ignore) + (declare (ignore ignore)) + (update-gf-dfun class gf)) gf-table))))) (defun update-inits (class inits) @@ -842,9 +841,9 @@ (if entry (push d (cdr entry)) (push (list name d) name-dslotds-alist)))))) - (mapcar #'(lambda (direct) - (compute-effective-slot-definition class - (nreverse (cdr direct)))) + (mapcar (lambda (direct) + (compute-effective-slot-definition class + (nreverse (cdr direct)))) name-dslotds-alist))) (defmethod compute-slots :around ((class std-class)) @@ -868,11 +867,10 @@ eslotds)) (defmethod compute-slots ((class structure-class)) - (mapcan #'(lambda (superclass) - (mapcar #'(lambda (dslotd) - (compute-effective-slot-definition class - (list dslotd))) - (class-direct-slots superclass))) + (mapcan (lambda (superclass) + (mapcar (lambda (dslotd) + (compute-effective-slot-definition class (list dslotd))) + (class-direct-slots superclass))) (reverse (slot-value class 'class-precedence-list)))) (defmethod compute-slots :around ((class structure-class)) @@ -920,7 +918,7 @@ allocp t)) (setq initargs (append (slot-definition-initargs slotd) initargs)) (let ((slotd-type (slot-definition-type slotd))) - (setq type (cond ((eq type 't) slotd-type) + (setq type (cond ((eq type t) slotd-type) ((*subtypep type slotd-type) type) (t `(and ,type ,slotd-type))))))) (list :name name @@ -1069,7 +1067,7 @@ ;; sure we never change an OBSOLETE into a FLUSH since OBSOLETE ;; means do what FLUSH does and then some. ;; - (when (eq state 't) + (when (eq state t) (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) class))) (setf (wrapper-instance-slots-layout nwrapper) @@ -1079,7 +1077,7 @@ (without-interrupts (update-lisp-class-layout class nwrapper) (setf (slot-value class 'wrapper) nwrapper) - (invalidate-wrapper owrapper ':flush nwrapper)))))) + (invalidate-wrapper owrapper :flush nwrapper)))))) (defun flush-cache-trap (owrapper nwrapper instance) (declare (ignore owrapper)) @@ -1103,7 +1101,7 @@ (without-interrupts (update-lisp-class-layout class nwrapper) (setf (slot-value class 'wrapper) nwrapper) - (invalidate-wrapper owrapper ':obsolete nwrapper) + (invalidate-wrapper owrapper :obsolete nwrapper) class))) (defmethod make-instances-obsolete ((class symbol)) @@ -1179,28 +1177,28 @@ ;; -- --> shared -- ;; ;; Go through all the old local slots. - ;; - (iterate ((name (list-elements olayout)) - (opos (interval :from 0))) - (let ((npos (posq name nlayout))) - (if npos - (setf (instance-ref nslots npos) (instance-ref oslots opos)) - (progn - (push name discarded) - (unless (eq (instance-ref oslots opos) *slot-unbound*) - (setf (getf plist name) (instance-ref oslots opos))))))) + ;; + (loop for name in olayout and opos from 0 + as npos = (posq name nlayout) + if npos do + (setf (instance-ref nslots npos) + (instance-ref oslots opos)) + else do + (push name discarded) + (unless (eq (instance-ref oslots opos) *slot-unbound*) + (setf (getf plist name) + (instance-ref oslots opos)))) ;; ;; Go through all the old shared slots. ;; - (iterate ((oclass-slot-and-val (list-elements oclass-slots))) - (let ((name (car oclass-slot-and-val)) - (val (cdr oclass-slot-and-val))) - (let ((npos (posq name nlayout))) - (if npos - (setf (instance-ref nslots npos) (cdr oclass-slot-and-val)) - (progn (push name discarded) - (unless (eq val *slot-unbound*) - (setf (getf plist name) val))))))) + (loop for (name . val) in oclass-slots + for npos = (posq name nlayout) + if npos do + (setf (instance-ref nslots npos) val) + else do + (push name discarded) + (unless (eq val *slot-unbound*) + (setf (getf plist name) val))) ;; ;; Go through all the new local slots to compute the added slots. ;; @@ -1245,22 +1243,20 @@ ;; "The values of local slots specified by both the class Cto and ;; Cfrom are retained. If such a local slot was unbound, it remains ;; unbound." - ;; - (iterate ((new-slot (list-elements new-layout)) - (new-position (interval :from 0))) - (let ((old-position (posq new-slot old-layout))) - (when old-position - (setf (instance-ref new-slots new-position) - (instance-ref old-slots old-position))))) - + ;; + (loop for new-slot in new-layout and new-position from 0 + for old-position = (posq new-slot old-layout) + when old-position do + (setf (instance-ref new-slots new-position) + (instance-ref old-slots old-position))) ;; ;; "The values of slots specified as shared in the class Cfrom and ;; as local in the class Cto are retained." ;; - (iterate ((slot-and-val (list-elements old-class-slots))) - (let ((position (posq (car slot-and-val) new-layout))) - (when position - (setf (instance-ref new-slots position) (cdr slot-and-val))))) + (loop for (name . val) in old-class-slots + for new-position = (posq name new-layout) + when new-position do + (setf (instance-ref new-slots new-position) val)) ;; Make the copy point to the old instance's storage, and make the ;; old instance point to the new storage. @@ -1331,7 +1327,7 @@ (defmethod validate-superclass ((c slot-class) (f forward-referenced-class)) - 't) + t) ;;; diff --git a/pcl/structure-class.lisp b/pcl/structure-class.lisp index 613e98bbb3d711d64e5dbdc7e58f2dfb9db26a3d..c33722a5a9547d241d324c7fd89bb99cb5b46ddd 100644 --- a/pcl/structure-class.lisp +++ b/pcl/structure-class.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/structure-class.lisp,v 1.3 1999/05/30 23:14:09 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/structure-class.lisp,v 1.4 2002/08/26 02:23:15 pmai Exp $") ;;; (in-package 'pcl) @@ -123,9 +123,9 @@ (setq direct-slots (if direct-slots-p (setf (slot-value class 'direct-slots) - (mapcar #'(lambda (pl) - (apply #'make-direct-slotd class - :conc-name conc-name pl)) + (mapcar (lambda (pl) + (apply #'make-direct-slotd class + :conc-name conc-name pl)) direct-slots)) (slot-value class 'direct-slots))) (when from-defclass-p @@ -192,37 +192,37 @@ (remove-if #'slot-definition-internal-reader-function direct-slots))) (reader-names - (mapcar #'(lambda (slotd) - (intern (format nil "~A~A reader" conc-name - (slot-definition-name slotd)) - package)) + (mapcar (lambda (slotd) + (intern (format nil "~A~A reader" conc-name + (slot-definition-name slotd)) + package)) direct-slots-needing-internals)) (writer-names - (mapcar #'(lambda (slotd) - (intern (format nil "~A~A writer" conc-name - (slot-definition-name slotd)) - package)) + (mapcar (lambda (slotd) + (intern (format nil "~A~A writer" conc-name + (slot-definition-name slotd)) + package)) direct-slots-needing-internals)) (defstruct-accessor-names (mapcar #'slot-definition-defstruct-accessor-symbol direct-slots-needing-internals)) (readers-init - (mapcar #'(lambda (defstruct-accessor reader-name) - `(progn - (force-compile ',defstruct-accessor) - (defun ,reader-name (obj) - (declare (type ,name obj) #.*optimize-speed*) - (,defstruct-accessor obj)) - (force-compile ',reader-name))) + (mapcar (lambda (defstruct-accessor reader-name) + `(progn + (force-compile ',defstruct-accessor) + (defun ,reader-name (obj) + (declare (type ,name obj) #.*optimize-speed*) + (,defstruct-accessor obj)) + (force-compile ',reader-name))) defstruct-accessor-names reader-names)) (writers-init - (mapcar #'(lambda (defstruct-accessor writer-name) - `(progn - (force-compile ',defstruct-accessor) - (defun ,writer-name (nv obj) - (declare (type ,name obj) #.*optimize-speed*) - (setf (,defstruct-accessor obj) nv)) - (force-compile ',writer-name))) + (mapcar (lambda (defstruct-accessor writer-name) + `(progn + (force-compile ',defstruct-accessor) + (defun ,writer-name (nv obj) + (declare (type ,name obj) #.*optimize-speed*) + (setf (,defstruct-accessor obj) nv)) + (force-compile ',writer-name))) defstruct-accessor-names writer-names)) (defstruct-extras-form `(progn @@ -234,19 +234,19 @@ ,@writers-init))) (declare (type package package)) (eval defstruct-extras-form) - (mapc #'(lambda (dslotd reader-name writer-name) - (setf (slot-value dslotd 'internal-reader-function) - (gdefinition reader-name)) - (setf (slot-value dslotd 'internal-writer-function) - (gdefinition writer-name))) + (mapc (lambda (dslotd reader-name writer-name) + (setf (slot-value dslotd 'internal-reader-function) + (gdefinition reader-name)) + (setf (slot-value dslotd 'internal-writer-function) + (gdefinition writer-name))) direct-slots-needing-internals reader-names writer-names))) (defmethod reinitialize-instance :after ((class structure-class) &rest initargs &key) (map-dependents class - #'(lambda (dependent) - (apply #'update-dependent class dependent initargs)))) + (lambda (dependent) + (apply #'update-dependent class dependent initargs)))) (defmethod direct-slot-definition-class ((class structure-class) initargs) (declare (ignore initargs)) @@ -261,11 +261,11 @@ (defmethod compute-slots ((class structure-class)) - (mapcan #'(lambda (superclass) - (mapcar #'(lambda (dslotd) - (compute-effective-slot-definition - class (slot-definition-name dslotd) (list dslotd))) - (class-direct-slots superclass))) + (mapcan (lambda (superclass) + (mapcar (lambda (dslotd) + (compute-effective-slot-definition + class (slot-definition-name dslotd) (list dslotd))) + (class-direct-slots superclass))) (reverse (slot-value class 'class-precedence-list)))) (defmethod compute-slots :around ((class structure-class)) @@ -320,18 +320,18 @@ (defun make-structure-instance-reader-method-function (slot-name) (declare #.*optimize-speed*) - #'(lambda (instance) - (structure-instance-slot-value instance slot-name))) + (lambda (instance) + (structure-instance-slot-value instance slot-name))) (defun make-structure-instance-writer-method-function (slot-name) (declare #.*optimize-speed*) - #'(lambda (nv instance) - (setf (structure-instance-slot-value instance slot-name) nv))) + (lambda (nv instance) + (setf (structure-instance-slot-value instance slot-name) nv))) (defun make-structure-instance-boundp-method-function (slot-name) (declare #.*optimize-speed*) - #'(lambda (instance) - (structure-instance-slot-boundp instance slot-name))) + (lambda (instance) + (structure-instance-slot-boundp instance slot-name))) (defmethod wrapper-fetcher ((class structure-class)) 'wrapper-for-structure) diff --git a/pcl/user-instances.lisp b/pcl/user-instances.lisp index e961f38df67c433d385cfec59a6759c00a399f32..ef254dc2b81b83e5f71c8d55d15a27dfd151be2d 100644 --- a/pcl/user-instances.lisp +++ b/pcl/user-instances.lisp @@ -20,7 +20,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/user-instances.lisp,v 1.3 1999/05/30 23:14:09 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/user-instances.lisp,v 1.4 2002/08/26 02:23:16 pmai Exp $") ;;; (in-package 'pcl) @@ -284,39 +284,39 @@ (defun make-user-vector-instance-reader-method-function (slot-name) (declare #.*optimize-speed*) - #'(lambda (instance) - (user-instance-slot-value instance slot-name))) + (lambda (instance) + (user-instance-slot-value instance slot-name))) (defun make-user-vector-instance-writer-method-function (slot-name) (declare #.*optimize-speed*) - #'(lambda (nv instance) - (setf (user-instance-slot-value instance slot-name) nv))) + (lambda (nv instance) + (setf (user-instance-slot-value instance slot-name) nv))) (defun make-user-vector-instance-boundp-method-function (slot-name) (declare #.*optimize-speed*) - #'(lambda (instance) - (user-instance-slot-boundp instance slot-name))) + (lambda (instance) + (user-instance-slot-boundp instance slot-name))) (defun make-optimized-user-reader-method-function (slot-name index) (declare #.*optimize-speed*) (progn slot-name) - #'(lambda (instance) - (let ((value (%svref (user-vector-instance-slots instance) index))) - (if (eq value *slot-unbound*) - (slot-unbound (class-of instance) instance slot-name) - value)))) + (lambda (instance) + (let ((value (%svref (user-vector-instance-slots instance) index))) + (if (eq value *slot-unbound*) + (slot-unbound (class-of instance) instance slot-name) + value)))) (defun make-optimized-user-writer-method-function (index) (declare #.*optimize-speed*) - #'(lambda (nv instance) - (setf (%svref (user-vector-instance-slots instance) index) nv))) + (lambda (nv instance) + (setf (%svref (user-vector-instance-slots instance) index) nv))) (defun make-optimized-user-boundp-method-function (index) (declare #.*optimize-speed*) - #'(lambda (instance) - (not (eq (%svref (user-vector-instance-slots instance) index) - *slot-unbound*)))) + (lambda (instance) + (not (eq (%svref (user-vector-instance-slots instance) index) + *slot-unbound*)))) @@ -443,11 +443,11 @@ (declare (type index first-dimension)) (walk-dimensions (mapcar #'min (cdr new-dimensions) (cdr old-dimensions)) - #'(lambda (post-indices) - (copy-array-contents old-array new-array - :key key - :length first-dimension - :post-indices post-indices))))) + (lambda (post-indices) + (copy-array-contents old-array new-array + :key key + :length first-dimension + :post-indices post-indices))))) new-array)))) (defun copy-array-contents @@ -620,11 +620,11 @@ (copy-any-array item :key - #'(lambda (item) - (if (user-vector-instance-p item) - (let ((dummy (dummy-print-instance-of item))) - (push dummy dummy-print-instances-used) - dummy) + (lambda (item) + (if (user-vector-instance-p item) + (let ((dummy (dummy-print-instance-of item))) + (push dummy dummy-print-instances-used) + dummy) item)) :dimensions (mapcar #'1+ (array-dimensions item))) diff --git a/pcl/vector.lisp b/pcl/vector.lisp index 7f3bd6a95638cf4659d6ab8c30821735d318d394..2a0e6efad0aa92b31090b8f3045392976ed71cc7 100644 --- a/pcl/vector.lisp +++ b/pcl/vector.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.16 2002/08/19 16:52:09 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.17 2002/08/26 02:23:16 pmai Exp $") ;;; ;;; Permutation vectors. ;;; @@ -169,21 +169,22 @@ location))))))) (defun compute-pv (slot-name-lists wrappers) - (unless (listp wrappers) (setq wrappers (list wrappers))) (let* ((not-simple-p-cell (list nil)) (elements - (gathering1 (collecting) - (iterate ((slot-names (list-elements slot-name-lists))) - (when slot-names - (let* ((wrapper (pop wrappers)) - (std-p (typep wrapper 'wrapper)) - (class (wrapper-class* wrapper)) - (class-slots (and std-p (wrapper-class-slots wrapper)))) - (dolist (slot-name (cdr slot-names)) - (gather1 - (when std-p - (compute-pv-slot slot-name wrapper class - class-slots not-simple-p-cell)))))))))) + (loop with wrappers = (if (listp wrappers) wrappers (list wrappers)) + for slot-names in slot-name-lists + when slot-names + nconc (loop with wrapper = (pop wrappers) + with stdp = (typep wrapper 'wrapper) + and class = (wrapper-class* wrapper) + with class-slots + = (and stdp (wrapper-class-slots wrapper)) + for slot-name in (cdr slot-names) + collect + (when stdp + (compute-pv-slot slot-name wrapper class + class-slots + not-simple-p-cell)))))) (if (car not-simple-p-cell) (make-permutation-vector (cons t elements)) (or (gethash elements *pvs*) @@ -194,7 +195,7 @@ (declare (ignore call-list wrappers)) #|| (map 'vector - #'(lambda (call) + (lambda (call) (compute-emf-from-wrappers call wrappers)) call-list) ||# @@ -206,19 +207,19 @@ (destructuring-bind (gf-name nreq restp arg-info) call (if (eq gf-name 'make-instance) (error "should not get here") ; there is another mechanism for this. - #'(lambda (&rest args) - (if (not (eq *boot-state* 'complete)) - (apply (gdefinition gf-name) args) - (let* ((gf (gdefinition gf-name)) - (arg-info (arg-info-reader gf)) - (classes '?) - (types '?) - (emf (cache-miss-values-internal gf arg-info - wrappers classes types - 'caching))) - (update-all-pv-tables call wrappers emf) - #+copy-&rest-arg (setq args (copy-list args)) - (invoke-emf emf args)))))))) + (lambda (&rest args) + (if (not (eq *boot-state* 'complete)) + (apply (gdefinition gf-name) args) + (let* ((gf (gdefinition gf-name)) + (arg-info (arg-info-reader gf)) + (classes '?) + (types '?) + (emf (cache-miss-values-internal gf arg-info + wrappers classes types + 'caching))) + (update-all-pv-tables call wrappers emf) + #+copy-&rest-arg (setq args (copy-list args)) + (invoke-emf emf args)))))))) ||# (defun make-permutation-vector (indexes) @@ -282,26 +283,27 @@ (std-p (typep cwrapper 'wrapper)) (class-slots (and std-p (wrapper-class-slots cwrapper))) (class-slot-p-cell (list nil)) - (new-values (mapcar #'(lambda (slot-name) - (cons slot-name - (when std-p - (compute-pv-slot - slot-name cwrapper class - class-slots class-slot-p-cell)))) + (new-values (mapcar (lambda (slot-name) + (cons slot-name + (when std-p + (compute-pv-slot + slot-name cwrapper class + class-slots class-slot-p-cell)))) slot-names)) (pv-tables nil)) (dolist (slot-name slot-names) (map-pv-table-references-of slot-name - #'(lambda (pv-table pv-offset-list) - (declare (ignore pv-offset-list)) - (pushnew pv-table pv-tables)))) + (lambda (pv-table pv-offset-list) + (declare (ignore pv-offset-list)) + (pushnew pv-table pv-tables)))) (dolist (pv-table pv-tables) (let* ((cache (pv-table-cache pv-table)) (slot-name-lists (pv-table-slot-name-lists pv-table)) (pv-size (pv-table-pv-size pv-table)) (pv-map (make-array pv-size :initial-element nil))) - (let ((map-index 1)(param-index 0)) + (let ((map-index 1) + (param-index 0)) (dolist (slot-name-list slot-name-lists) (dolist (slot-name (cdr slot-name-list)) (let ((a (assoc slot-name new-values))) @@ -310,10 +312,10 @@ (incf map-index)) (incf param-index))) (when cache - (map-cache #'(lambda (wrappers pv-cell) - (setf (car pv-cell) - (update-slots-in-pv wrappers (car pv-cell) - cwrapper pv-size pv-map))) + (map-cache (lambda (wrappers pv-cell) + (setf (car pv-cell) + (update-slots-in-pv wrappers (car pv-cell) + cwrapper pv-size pv-map))) cache)))))) (defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map) @@ -598,8 +600,8 @@ (non-required-args (nthcdr nreq args)) (required-args (ldiff args non-required-args)) (call-spec (list (car gf-call-form) nreq restp - (mapcar #'(lambda (form) - (optimize-gf-call-internal form slots env)) + (mapcar (lambda (form) + (optimize-gf-call-internal form slots env)) (if all-args-p args required-args)))) @@ -656,16 +658,16 @@ (defmacro instance-read-internal (pv slots pv-offset default &optional type) (unless (member type '(nil :instance :class :default)) (error "Illegal type argument to ~S: ~S" 'instance-read-internal type)) - (if (eq type ':default) + (if (eq type :default) default (let* ((index (gensym)) (value index)) `(locally (declare #.*optimize-speed*) (let ((,index (pvref ,pv ,pv-offset))) (setq ,value (typecase ,index - ,@(when (or (null type) (eq type ':instance)) + ,@(when (or (null type) (eq type :instance)) `((fixnum (%instance-ref ,slots ,index)))) - ,@(when (or (null type) (eq type ':class)) + ,@(when (or (null type) (eq type :class)) `((cons (cdr ,index)))) (t ',*slot-unbound*))) (if (eq ,value ',*slot-unbound*) @@ -678,7 +680,7 @@ `(instance-read-internal .pv. ,(slot-vector-symbol position) ,pv-offset (accessor-slot-value ,parameter ,slot-name) ,(if (generate-fast-class-slot-access-p class slot-name) - ':class ':instance)))) + :class :instance)))) (defmacro instance-reader (pv-offset parameter position gf-name class) (declare (ignore class)) @@ -691,15 +693,15 @@ &optional type) (unless (member type '(nil :instance :class :default)) (error "Illegal type argument to ~S: ~S" 'instance-write-internal type)) - (if (eq type ':default) + (if (eq type :default) default (let* ((index (gensym))) `(locally (declare #.*optimize-speed*) (let ((,index (pvref ,pv ,pv-offset))) (typecase ,index - ,@(when (or (null type) (eq type ':instance)) + ,@(when (or (null type) (eq type :instance)) `((fixnum (setf (%instance-ref ,slots ,index) ,new-value)))) - ,@(when (or (null type) (eq type ':class)) + ,@(when (or (null type) (eq type :class)) `((cons (setf (cdr ,index) ,new-value)))) (t ,default))))))) @@ -710,7 +712,7 @@ ,pv-offset ,new-value (accessor-set-slot-value ,parameter ,slot-name ,new-value) ,(if (generate-fast-class-slot-access-p class slot-name) - ':class ':instance)))) + :class :instance)))) (defmacro instance-writer (pv-offset parameter position gf-name class new-value) (declare (ignore class)) @@ -723,15 +725,15 @@ &optional type) (unless (member type '(nil :instance :class :default)) (error "Illegal type argument to ~S: ~S" 'instance-boundp-internal type)) - (if (eq type ':default) + (if (eq type :default) default (let* ((index (gensym))) `(locally (declare #.*optimize-speed*) (let ((,index (pvref ,pv ,pv-offset))) (typecase ,index - ,@(when (or (null type) (eq type ':instance)) + ,@(when (or (null type) (eq type :instance)) `((fixnum (not (eq (%instance-ref ,slots ,index) ',*slot-unbound*))))) - ,@(when (or (null type) (eq type ':class)) + ,@(when (or (null type) (eq type :class)) `((cons (not (eq (cdr ,index) ',*slot-unbound*))))) (t ,default))))))) @@ -741,7 +743,7 @@ `(instance-boundp-internal .pv. ,(slot-vector-symbol position) ,pv-offset (accessor-slot-boundp ,parameter ,slot-name) ,(if (generate-fast-class-slot-access-p class slot-name) - ':class ':instance)))) + :class :instance)))) ;;; ;;; This magic function has quite a job to do indeed. @@ -763,8 +765,8 @@ (multiple-value-bind (slots calls) (mutate-slots-and-calls slots calls) (let* ((slot-name-lists - (mapcar #'(lambda (parameter-entry) - (cons nil (mapcar #'car (cdr parameter-entry)))) + (mapcar (lambda (parameter-entry) + (cons nil (mapcar #'car (cdr parameter-entry)))) slots)) (call-list (mapcar #'car calls))) @@ -772,22 +774,22 @@ (dolist (arg (cdr call)) (when (integerp arg) (setf (car (nth arg slot-name-lists)) t)))) - (setq slot-name-lists (mapcar #'(lambda (r+snl) - (when (or (car r+snl) (cdr r+snl)) - r+snl)) + (setq slot-name-lists (mapcar (lambda (r+snl) + (when (or (car r+snl) (cdr r+snl)) + r+snl)) slot-name-lists)) (let ((cvt (apply #'vector (let ((i -1)) - (mapcar #'(lambda (r+snl) - (when r+snl (incf i))) + (mapcar (lambda (r+snl) + (when r+snl (incf i))) slot-name-lists))))) - (setq call-list (mapcar #'(lambda (call) - (cons (car call) - (mapcar #'(lambda (arg) - (if (integerp arg) - (svref cvt arg) - arg)) - (cdr call)))) + (setq call-list (mapcar (lambda (call) + (cons (car call) + (mapcar (lambda (arg) + (if (integerp arg) + (svref cvt arg) + arg)) + (cdr call)))) call-list))) (values slot-name-lists call-list)))) @@ -830,11 +832,11 @@ (symbol-or-cons-lessp (car a) (car b)))))))) (defun sort-slots (slots) - (mapcar #'(lambda (parameter-entry) - (cons (car parameter-entry) - (sort (cdr parameter-entry) ;slot entries - #'symbol-or-cons-lessp - :key #'car))) + (mapcar (lambda (parameter-entry) + (cons (car parameter-entry) + (sort (cdr parameter-entry) ;slot entries + #'symbol-or-cons-lessp + :key #'car))) slots)) (defun sort-calls (calls) @@ -848,21 +850,21 @@ (defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol) &body body) - (with-gathering ((slot-vars (collecting)) - (pv-parameters (collecting))) - (iterate ((slots (list-elements slot-name-lists)) - (required-parameter (list-elements required-parameters)) - (i (interval :from 0))) - (when slots - (gather required-parameter pv-parameters) - (gather (slot-vector-symbol i) slot-vars))) - `(pv-binding1 (.pv. .calls. ,pv-table-symbol ,pv-parameters ,slot-vars) - ,@body))) + (loop for slot-names in slot-name-lists + and required-parameter in required-parameters + and i of-type fixnum from 0 + when slot-names + collect required-parameter into pv-parameters + and collect (slot-vector-symbol i) into slot-vars + finally + (return `(pv-binding1 (.pv. .calls. ,pv-table-symbol + ,pv-parameters ,slot-vars) + ,@body)))) (defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) &body body) `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters) - (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) + (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) slot-vars pv-parameters)) ,@body))) @@ -958,14 +960,19 @@ `(list* :function #',method-lambda ',initargs) (let* ((lambda-list (car lmf-params)) - (nreq 0)(restp nil)(args nil)) + (nreq 0) + (restp nil) + (args nil)) (dolist (arg lambda-list) (when (member arg '(&optional &rest &key)) - (setq restp t)(return nil)) - (when (eq arg '&aux) (return nil)) - (incf nreq)(push arg args)) + (setq restp t) + (return nil)) + (when (eq arg '&aux) + (return nil)) + (incf nreq) + (push arg args)) (setq args (nreverse args)) - (setf (getf (getf initargs ':plist) ':arg-info) (cons nreq restp)) + (setf (getf (getf initargs :plist) :arg-info) (cons nreq restp)) (make-method-initargs-form-internal1 initargs (cddr lmf) args lmf-params restp))))) @@ -977,23 +984,23 @@ (let* ((rest-arg (when restp '.rest-arg.)) (args+rest-arg (if restp (append req-args (list rest-arg)) req-args))) `(list* :fast-function - #'(lambda (.pv-cell. .next-method-call. ,@args+rest-arg) - ,@outer-decls - .pv-cell. .next-method-call. - (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters) - &rest forms) - (declare (ignore pv-table-symbol pv-parameters)) - `(let ((,pv (car .pv-cell.)) - (,calls (cdr .pv-cell.))) - (declare ,(make-pv-type-declaration pv) - ,(make-calls-type-declaration calls)) - ,pv ,calls - ,@forms))) - (fast-lexical-method-functions - (,(car lmf-params) .next-method-call. ,req-args ,rest-arg - ,@(cdddr lmf-params)) - ,@inner-decls - ,@body))) + (lambda (.pv-cell. .next-method-call. ,@args+rest-arg) + ,@outer-decls + .pv-cell. .next-method-call. + (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters) + &rest forms) + (declare (ignore pv-table-symbol pv-parameters)) + `(let ((,pv (car .pv-cell.)) + (,calls (cdr .pv-cell.))) + (declare ,(make-pv-type-declaration pv) + ,(make-calls-type-declaration calls)) + ,pv ,calls + ,@forms))) + (fast-lexical-method-functions + (,(car lmf-params) .next-method-call. ,req-args ,rest-arg + ,@(cdddr lmf-params)) + ,@inner-decls + ,@body))) ',initargs)))) ;use arrays and hash tables and the fngen stuff to make this much better. @@ -1003,28 +1010,28 @@ (defun method-function-from-fast-function (fmf) (declare (type function fmf)) (let* ((method-function nil) (pv-table nil) - (arg-info (method-function-get fmf ':arg-info)) + (arg-info (method-function-get fmf :arg-info)) (nreq (car arg-info)) (restp (cdr arg-info))) (setq method-function - #'(lambda (method-args next-methods) - (unless pv-table - (setq pv-table (method-function-pv-table fmf))) - (let* ((pv-cell (when pv-table - (get-method-function-pv-cell - method-function method-args pv-table))) - (nm (car next-methods)) - (nms (cdr next-methods)) - (nmc (when nm - (make-method-call :function (if (std-instance-p nm) - (method-function nm) - nm) - :call-method-args (list nms))))) - (if restp - (let* ((rest (nthcdr nreq method-args)) - (args (ldiff method-args rest))) - (apply fmf pv-cell nmc (nconc args (list rest)))) - (apply fmf pv-cell nmc method-args))))) + (lambda (method-args next-methods) + (unless pv-table + (setq pv-table (method-function-pv-table fmf))) + (let* ((pv-cell (when pv-table + (get-method-function-pv-cell + method-function method-args pv-table))) + (nm (car next-methods)) + (nms (cdr next-methods)) + (nmc (when nm + (make-method-call :function (if (std-instance-p nm) + (method-function nm) + nm) + :call-method-args (list nms))))) + (if restp + (let* ((rest (nthcdr nreq method-args)) + (args (ldiff method-args rest))) + (apply fmf pv-cell nmc (nconc args (list rest)))) + (apply fmf pv-cell nmc method-args))))) (let* ((fname (method-function-get fmf :name)) (name `(,(or (get (car fname) 'method-sym) (setf (get (car fname) 'method-sym) diff --git a/pcl/walk.lisp b/pcl/walk.lisp index b7eeba3ff22b839289b9d1687e4220d1ff6ecb68..b358342e040cc4a4f0d67698be530b5f2e584e82 100644 --- a/pcl/walk.lisp +++ b/pcl/walk.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/walk.lisp,v 1.21 2001/05/05 23:34:47 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/walk.lisp,v 1.22 2002/08/26 02:23:16 pmai Exp $") ;;; ;;; A simple code walker, based IN PART on: (roll the credits) ;;; Larry Masinter's Masterscope @@ -182,12 +182,12 @@ :default env :variables variables :functions - (append (mapcar #'(lambda (f) - (cons (car f) (c::make-functional :lexenv env))) + (append (mapcar (lambda (f) + (cons (car f) (c::make-functional :lexenv env))) functions) - (mapcar #'(lambda (m) - (list* (car m) 'c::macro - (coerce (cadr m) 'function))) + (mapcar (lambda (m) + (list* (car m) 'c::macro + (coerce (cadr m) 'function))) macros))))) (defun environment-function (env fn) @@ -470,9 +470,9 @@ (defun WALK-FORM (form &optional environment (walk-function - #'(lambda (subform context env) - (declare (ignore context env)) - subform))) + (lambda (subform context env) + (declare (ignore context env)) + subform))) (walker-environment-bind (new-env environment :walk-function walk-function) (walk-form-internal form :eval new-env))) @@ -499,48 +499,48 @@ form &optional environment (walk-function - #'(lambda (subform context env) - (declare (ignore context env)) - subform))) + (lambda (subform context env) + (declare (ignore context env)) + subform))) (if (eq whole (env-walk-form environment)) (let ((outer-walk-function (env-walk-function environment))) (throw whole (walk-form form environment - #'(lambda (f c e) - ;; First loop to make sure the inner walk function - ;; has done all it wants to do with this form. - ;; Basically, what we are doing here is providing - ;; the same contract walk-form-internal normally - ;; provides to the inner walk function. - (let ((inner-result nil) - (inner-no-more-p nil) - (outer-result nil) - (outer-no-more-p nil)) - (loop - (multiple-value-setq (inner-result inner-no-more-p) - (funcall walk-function f c e)) - (cond (inner-no-more-p (return)) - ((not (eq inner-result f))) - ((not (consp inner-result)) (return)) - ((get-walker-template (car inner-result)) (return)) - (t - (multiple-value-bind (expansion macrop) - (walker-environment-bind - (new-env e :walk-form inner-result) - (macroexpand-1 inner-result new-env)) - (if macrop - (setq inner-result expansion) - (return))))) - (setq f inner-result)) - (multiple-value-setq (outer-result outer-no-more-p) - (funcall outer-walk-function - inner-result - c - e)) - (values outer-result - (and inner-no-more-p outer-no-more-p))))))) + (lambda (f c e) + ;; First loop to make sure the inner walk function + ;; has done all it wants to do with this form. + ;; Basically, what we are doing here is providing + ;; the same contract walk-form-internal normally + ;; provides to the inner walk function. + (let ((inner-result nil) + (inner-no-more-p nil) + (outer-result nil) + (outer-no-more-p nil)) + (loop + (multiple-value-setq (inner-result inner-no-more-p) + (funcall walk-function f c e)) + (cond (inner-no-more-p (return)) + ((not (eq inner-result f))) + ((not (consp inner-result)) (return)) + ((get-walker-template (car inner-result)) (return)) + (t + (multiple-value-bind (expansion macrop) + (walker-environment-bind + (new-env e :walk-form inner-result) + (macroexpand-1 inner-result new-env)) + (if macrop + (setq inner-result expansion) + (return))))) + (setq f inner-result)) + (multiple-value-setq (outer-result outer-no-more-p) + (funcall outer-walk-function + inner-result + c + e)) + (values outer-result + (and inner-no-more-p outer-no-more-p))))))) (walk-form form environment walk-function))) ;;; @@ -712,7 +712,7 @@ (relist-internal x args nil))) (defun relist* (x &rest args) - (relist-internal x args 't)) + (relist-internal x args t)) (defun relist-internal (x args *p) (if (null (cdr args)) @@ -874,8 +874,8 @@ (walked-body (walk-declarations body - #'(lambda (real-body real-env) - (walk-tagbody-1 real-body context real-env)) + (lambda (real-body real-env) + (walk-tagbody-1 real-body context real-env)) new-env))) (if block-name (relist* @@ -908,7 +908,7 @@ (body (cdddr form))) (walk-form-internal `(let () - (declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x)) + (declare (special ,@(mapcar (lambda (x) (if (listp x) (car x) x)) bindings))) (flet ((.let-if-dummy. () ,@body)) (if ,test @@ -919,11 +919,11 @@ (defun walk-multiple-value-setq (form context env) (let ((vars (cadr form))) - (if (some #'(lambda (var) - (variable-symbol-macro-p var env)) + (if (some (lambda (var) + (variable-symbol-macro-p var env)) vars) - (let* ((temps (mapcar #'(lambda (var) (declare (ignore var)) (gensym)) vars)) - (sets (mapcar #'(lambda (var temp) `(setq ,var ,temp)) vars temps)) + (let* ((temps (mapcar (lambda (var) (declare (ignore var)) (gensym)) vars)) + (sets (mapcar (lambda (var temp) `(setq ,var ,temp)) vars temps)) (expanded `(multiple-value-bind ,temps ,(caddr form) ,@sets)) @@ -943,14 +943,14 @@ (walked-body (walk-declarations body - #'(lambda (real-body real-env) - (setq walked-bindings - (walk-bindings-1 bindings - old-env - new-env - context - nil)) - (walk-repeat-eval real-body real-env)) + (lambda (real-body real-env) + (setq walked-bindings + (walk-bindings-1 bindings + old-env + new-env + context + nil)) + (walk-repeat-eval real-body real-env)) new-env))) (relist* form mvb walked-bindings mv-form walked-body)))) @@ -1055,9 +1055,9 @@ (walker-environment-bind (new-env old-env :lexical-variables - (append (mapcar #'(lambda (binding) - `(,(car binding) - :macro . ,(cadr binding))) + (append (mapcar (lambda (binding) + `(,(car binding) + :macro . ,(cadr binding))) bindings) (env-lexical-variables old-env))) (relist* form 'symbol-macrolet bindings @@ -1220,21 +1220,21 @@ (terpri) (let ((copy-of-form (copy-tree form)) (result (walk-form form nil - #'(lambda (x y env) - (format t "~&Form: ~S ~3T Context: ~A" x y) - (when (symbolp x) - (let ((lexical (variable-lexical-p x env)) - (special (variable-special-p x env))) - (when lexical - (format t ";~3T") - (format t "lexically bound")) - (when special - (format t ";~3T") - (format t "declared special")) - (when (boundp x) - (format t ";~3T") - (format t "bound: ~S " (eval x))))) - x)))) + (lambda (x y env) + (format t "~&Form: ~S ~3T Context: ~A" x y) + (when (symbolp x) + (let ((lexical (variable-lexical-p x env)) + (special (variable-special-p x env))) + (when lexical + (format t ";~3T") + (format t "lexically bound")) + (when special + (format t ";~3T") + (format t "declared special")) + (when (boundp x) + (format t ";~3T") + (format t "bound: ~S " (eval x))))) + x)))) (cond ((not (equal result copy-of-form)) (format t "~%Warning: Result not EQUAL to copy of start.")) ((not (eq result form)) @@ -1412,13 +1412,13 @@ (let ((the-lexical-variables ())) (walk-form '(let ((a 1) (b 2)) - #'(lambda (x) (list a b x y))) + (lambda (x) (list a b x y))) () - #'(lambda (form context env) - (when (and (symbolp form) - (variable-lexical-p form env)) - (push form the-lexical-variables)) - form)) + (lambda (form context env) + (when (and (symbolp form) + (variable-lexical-p form env)) + (push form the-lexical-variables)) + form)) (or (and (= (length the-lexical-variables) 3) (member 'a the-lexical-variables) (member 'b the-lexical-variables)