X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=51c4b979f65f133e70800160efd31e50f1916630;hb=a8f0175b16a00f5fc83eb8d8a718ae7fc5497514;hp=8a44336374ce1856e7de083c90ff9b8ad9e5f1f2;hpb=39ca94ec421224c78cb01f7d2d7b49321c66a2d4;p=sbcl.git

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 8a44336..51c4b97 100644
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -103,10 +103,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*))
@@ -156,19 +156,20 @@ And so, we are saved.
 (defmacro precompile-dfun-constructors (&optional system)
   (let ((*precompiling-lap* t))
     `(progn
-       ,@(gathering1 (collecting)
+       ,@(let (collect)
 	   (dolist (generator-entry *dfun-constructors*)
 	     (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
-                  `(load-precompiled-dfun-constructor
-                    ',(car generator-entry)
-                    ',(car args-entry)
-                    ',system
-                    ,(apply (fdefinition (car generator-entry))
-                            (car args-entry)))))))))))
+		 (push `(load-precompiled-dfun-constructor
+                         ',(car generator-entry)
+                         ',(car args-entry)
+                         ',system
+                         ,(apply (fdefinition (car generator-entry))
+                                 (car args-entry)))
+                       collect))))
+           (nreverse collect)))))
 
 ;;; When all the methods of a generic function are automatically
 ;;; generated reader or writer methods a number of special
@@ -377,9 +378,9 @@ And so, we are saved.
     (when (use-dispatch-dfun-p generic-function)
       (return-from make-checking-dfun (make-dispatch-dfun generic-function))))
   (multiple-value-bind (nreq applyp metatypes nkeys)
-      (get-generic-function-info generic-function)
+      (get-generic-fun-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)
@@ -400,9 +401,9 @@ And so, we are saved.
 (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)
-		    (invoke-emf function args))
+    (if (every (lambda (mt) (eq mt t)) metatypes)
+	(values (lambda (&rest args)
+		  (invoke-emf function args))
 		nil (default-method-only-dfun-info))
 	(let ((cache (make-final-ordinary-dfun-internal
 		      generic-function nil #'checking-limit-fn
@@ -411,16 +412,16 @@ And so, we are saved.
 
 (defun use-default-method-only-dfun-p (generic-function)
   (multiple-value-bind (nreq applyp metatypes nkeys)
-      (get-generic-function-info generic-function)
+      (get-generic-fun-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)))
+	    (method-function-get fmf :slot-name-lists)))
 	;; KLUDGE: As of sbcl-0.6.4, it's very important for
 	;; efficiency to know the type of the sequence argument to
 	;; quantifiers (SOME/NOTANY/etc.) at compile time, but
@@ -438,11 +439,13 @@ And so, we are saved.
 (defun make-caching-dfun (generic-function &optional cache)
   (unless cache
     (when (use-constant-value-dfun-p generic-function)
-      (return-from make-caching-dfun (make-constant-value-dfun generic-function)))
+      (return-from make-caching-dfun
+	(make-constant-value-dfun generic-function)))
     (when (use-dispatch-dfun-p generic-function)
-      (return-from make-caching-dfun (make-dispatch-dfun generic-function))))
+      (return-from make-caching-dfun
+	(make-dispatch-dfun generic-function))))
   (multiple-value-bind (nreq applyp metatypes nkeys)
-      (get-generic-function-info generic-function)
+      (get-generic-fun-info generic-function)
     (declare (ignore nreq))
     (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2)))
 	   (dfun-info (caching-dfun-info cache)))
@@ -465,7 +468,7 @@ And so, we are saved.
 
 (defun insure-caching-dfun (gf)
   (multiple-value-bind (nreq applyp metatypes nkeys)
-      (get-generic-function-info gf)
+      (get-generic-fun-info gf)
     (declare (ignore nreq nkeys))
     (when (and metatypes
 	       (not (null (car metatypes)))
@@ -475,7 +478,7 @@ And so, we are saved.
 
 (defun use-constant-value-dfun-p (gf &optional boolean-values-p)
   (multiple-value-bind (nreq applyp metatypes nkeys)
-      (get-generic-function-info gf)
+      (get-generic-fun-info gf)
     (declare (ignore nreq metatypes nkeys))
     (let* ((early-p (early-gf-p gf))
 	   (methods (if early-p
@@ -485,24 +488,24 @@ 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)
   (multiple-value-bind (nreq applyp metatypes nkeys)
-      (get-generic-function-info generic-function)
+      (get-generic-fun-info generic-function)
     (declare (ignore nreq applyp))
     (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2)))
 	   (dfun-info (constant-value-dfun-info cache)))
@@ -547,27 +550,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))
 
 (defparameter *cache-lookup-cost* 1)
@@ -610,11 +613,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))
 
@@ -750,18 +753,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))))
 
@@ -798,14 +801,14 @@ 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))
@@ -885,8 +888,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))
@@ -963,23 +966,19 @@ And so, we are saved.
 ;;;	       an :instance slot, this is the index number of that slot
 ;;;	       in the object argument.
 (defun cache-miss-values (gf args state)
-  (if (null (if (early-gf-p gf)
-		(early-gf-methods gf)
-		(generic-function-methods gf)))
-      (apply #'no-applicable-method gf args)
-      (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
-	  (get-generic-function-info gf)
-	(declare (ignore nreq applyp nkeys))
-	(with-dfun-wrappers (args metatypes)
-	  (dfun-wrappers invalid-wrapper-p wrappers classes types)
-	  (error-need-at-least-n-args gf (length metatypes))
-	  (multiple-value-bind (emf methods accessor-type index)
-	      (cache-miss-values-internal
-	       gf arg-info wrappers classes types state)
-	    (values emf methods
-		    dfun-wrappers
-		    invalid-wrapper-p
-		    accessor-type index))))))
+  (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
+      (get-generic-fun-info gf)
+    (declare (ignore nreq applyp nkeys))
+    (with-dfun-wrappers (args metatypes)
+      (dfun-wrappers invalid-wrapper-p wrappers classes types)
+      (error-need-at-least-n-args gf (length metatypes))
+      (multiple-value-bind (emf methods accessor-type index)
+          (cache-miss-values-internal
+           gf arg-info wrappers classes types state)
+        (values emf methods
+                dfun-wrappers
+                invalid-wrapper-p
+                accessor-type index)))))
 
 (defun cache-miss-values-internal (gf arg-info wrappers classes types state)
   (let* ((for-accessor-p (eq state 'accessor))
@@ -1089,39 +1088,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)))
 
@@ -1159,13 +1158,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)
@@ -1436,14 +1435,14 @@ And so, we are saved.
 					    function-p)
   (if (null methods)
       (if function-p
-	  #'(lambda (method-alist wrappers)
-	      (declare (ignore method-alist wrappers))
-	      #'(sb-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))
+	    #'(sb-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*)
@@ -1509,8 +1508,8 @@ And so, we are saved.
     (let ((dfun (if early-p
 		    (or dfun (make-initial-dfun generic-function))
 		    (compute-discriminating-function generic-function))))
-      (set-funcallable-instance-function generic-function dfun)
-      (set-function-name generic-function gf-name)
+      (set-funcallable-instance-fun generic-function dfun)
+      (set-fun-name generic-function gf-name)
       (when (and ocache (not (eq ocache cache))) (free-cache ocache))
       dfun)))
 
@@ -1570,19 +1569,19 @@ 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 ~D 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 ~W dfuns of type ~S."
+		  (cadr type+count+sizes) (car type+count+sizes))
+	  (format t "~%   ~S~%" (caddr type+count+sizes)))
 	*dfun-count*)
   (values))
 |#
@@ -1590,8 +1589,8 @@ And so, we are saved.
 (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))