#+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))
(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
;; that they will now update directly to NWRAPPER. This
;; corresponds to a 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))
(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))))
\f
(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)
(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 (let ((reversed-required nil))
+ (dotimes (i (length metatypes))
+ (push (dfun-arg-symbol i) reversed-required))
+ (nreverse reversed-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 ((reversed-lambda-list nil))
+ (push '.pv-cell. reversed-lambda-list)
+ (push '.next-method-call. reversed-lambda-list)
+ (dotimes (i (length metatypes))
+ (push (dfun-arg-symbol i) reversed-lambda-list))
(when applyp
- (gather1 '.dfun-rest-arg.))))
+ (push '.dfun-rest-arg. reversed-lambda-list))
+ (nreverse reversed-lambda-list)))
\f
;;;; a comment from some PCL implementor:
;;;; Its too bad Common Lisp compilers freak out when you have a
(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)))
(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))))))
;;; KLUDGE: Isn't something very similar going on in precom1.lisp? Do
;;; we need it both here and there? Why? -- WHN 19991203
(eval-when (:load-toplevel)
- (dolist (n-size '((1 513)(3 257)(3 129)(14 128)(6 65)(2 64)(7 33)(16 32)
- (16 17)(32 16)(64 9)(64 8)(6 5)(128 4)(35 2)))
+ (dolist (n-size '((1 513) (3 257) (3 129) (14 128) (6 65)
+ (2 64) (7 33) (16 32) (16 17) (32 16)
+ (64 9) (64 8) (6 5) (128 4) (35 2)))
(let ((n (car n-size))
(size (cadr n-size)))
(mapcar #'free-cache-vector
(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)
#'>
projects / sbcl.git / blobdiff