X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcache.lisp;h=1f4af309b557ef2d9a8eb3be1cdd6fa086148ab9;hb=ed7ba4dad8a79726fdfeba5aa12e276ea852c540;hp=cde6f9b51eb33c93dc8210ae233408d847815a87;hpb=4eb1a6d3ad2b7dcc19ac0ec979a1eb1eb049659a;p=sbcl.git

diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp
index cde6f9b..1f4af30 100644
--- a/src/pcl/cache.lisp
+++ b/src/pcl/cache.lisp
@@ -189,7 +189,7 @@
 #+sb-show
 (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))
@@ -201,7 +201,7 @@
 	      (setq head (cache-vector-ref head 0))
 	      (incf free))
 	(format t
-		"~&There  ~4D are caches of size ~4D. (~D free  ~3D%)"
+		"~&There are  ~4D caches of size  ~4D. (~D free  ~3D%)"
 		allocated
 		size
 		free
@@ -323,16 +323,16 @@
        :length length
        :class (sb-kernel:make-standard-class :name name :pcl-class class))))))
 
-;;; The following variable may be set to a standard-class that has
+;;; The following variable may be set to a STANDARD-CLASS that has
 ;;; already been created by the lisp code and which is to be redefined
-;;; by PCL. This allows standard-classes to be defined and used for
+;;; by PCL. This allows STANDARD-CLASSes to be defined and used for
 ;;; type testing and dispatch before PCL is loaded.
 (defvar *pcl-class-boot* nil)
 
 ;;; In SBCL, as in CMU CL, the layouts (a.k.a wrappers) for built-in
 ;;; and structure classes already exist when PCL is initialized, so we
 ;;; don't necessarily always make a wrapper. Also, we help maintain
-;;; the mapping between cl:class and pcl::class objects.
+;;; the mapping between CL:CLASS and PCL::CLASS objects.
 (defun make-wrapper (length class)
   (cond
    ((typep class 'std-class)
@@ -735,8 +735,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))))
 
@@ -757,32 +757,49 @@
   (or (nth arg-number (the list *slot-vector-symbols*))
       (intern (format nil ".SLOTS~A." arg-number) *pcl-package*)))
 
+;; FIXME: There ought to be a good way to factor out the idiom:
+;;
+;; (dotimes (i (length metatypes))
+;;   (push (dfun-arg-symbol i) lambda-list))
+;;
+;; used in the following six functions into common code that we can
+;; declare inline or something.  --njf 2001-12-20
 (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)))
+  (let ((lambda-list nil))
+    (dotimes (i (length metatypes))
+      (push (dfun-arg-symbol i) lambda-list))
     (when applyp
-      (gather1 '&rest)
-      (gather1 '.dfun-rest-arg.))))
+      (push '&rest lambda-list)
+      (push '.dfun-rest-arg. lambda-list))
+    (nreverse lambda-list)))
 
 (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)))
+  (let ((lambda-list nil))
+    (dotimes (i (length metatypes))
+      (push (dfun-arg-symbol i) lambda-list))
+    ;; FIXME: This is translated directly from the old PCL code.
+    ;; It didn't have a (PUSH '.DFUN-REST-ARG. LAMBDA-LIST) or
+    ;; something similar, so we don't either.  It's hard to see how
+    ;; this could be correct, since &REST wants an argument after
+    ;; it.  This function works correctly because the caller
+    ;; magically tacks on something after &REST.  The calling functions
+    ;; (in dlisp.lisp) should be fixed and this function rewritten.
+    ;; --njf 2001-12-20
     (when applyp
-      (gather1 '&rest))))
-
+      (push '&rest lambda-list))
+    (nreverse lambda-list)))
+
+;; FIXME: The next four functions suffer from having a `.DFUN-REST-ARG.'
+;; in their lambda lists, but no corresponding `&REST' symbol.  We assume
+;; this should be the case by analogy with the previous two functions.
+;; It works, and I don't know why.  Check the calling functions and
+;; fix these too.  --njf 2001-12-20
 (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 nil))
+           (dotimes (i (length metatypes))
+             (push (dfun-arg-symbol i) required))
+           (nreverse required))))
     `(,(if (eq emf-type 'fast-method-call)
 	   'invoke-effective-method-function-fast
 	   'invoke-effective-method-function)
@@ -790,36 +807,34 @@
 
 (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 nil))
+           (dotimes (i (length metatypes))
+             (push (dfun-arg-symbol i) required))
+           (nreverse required))))
     (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 nil))
+           (dotimes (i (length metatypes))
+             (push (dfun-arg-symbol i) required))
+           (nreverse required))))
     (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)))
+  (let ((lambda-list nil))
+    (push '.pv-cell. lambda-list)
+    (push '.next-method-call. lambda-list)
+    (dotimes (i (length metatypes))
+      (push (dfun-arg-symbol i) lambda-list))
     (when applyp
-      (gather1 '.dfun-rest-arg.))))
+      (push '.dfun-rest-arg. lambda-list))
+    (nreverse lambda-list)))
+
 
 ;;;; a comment from some PCL implementor:
 ;;;;     Its too bad Common Lisp compilers freak out when you have a
@@ -1003,12 +1018,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)))
 
@@ -1068,7 +1083,7 @@
 		 (sep (when home (line-separation home i))))
 	    (when (and sep (> sep limit))
 	      (error "bad cache ~S ~@
-		      value at location ~D: ~D lines from its home. The limit is ~D."
+		      value at location ~W: ~W lines from its home. The limit is ~W."
 		     cache location sep limit))))
 	(setq location (next-location location))))))
 
@@ -1348,8 +1363,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))
 		   sb-pcl::*free-caches*)
 	  l)
 	#'>