(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
(unless (boundp '*the-class-t*)
(setq *the-class-t* nil))
-;;; Note that for SBCL, as for CMU CL, the WRAPPER of a built-in or
-;;; structure class will be some other kind of SB-KERNEL:LAYOUT, but
-;;; this shouldn't matter, since the only two slots that WRAPPER adds
-;;; are meaningless in those cases.
-(defstruct (wrapper
- (:include sb-kernel:layout
- ;; KLUDGE: In CMU CL, the initialization default
- ;; for LAYOUT-INVALID was NIL. In SBCL, that has
- ;; changed to :UNINITIALIZED, but PCL code might
- ;; still expect NIL for the initialization
- ;; default of WRAPPER-INVALID. Instead of trying
- ;; to find out, I just overrode the LAYOUT
- ;; default here. -- WHN 19991204
- (invalid nil))
- (:conc-name %wrapper-)
- (:constructor make-wrapper-internal)
- (:copier nil))
- (instance-slots-layout nil :type list)
- (class-slots nil :type list))
-#-sb-fluid (declaim (sb-ext:freeze-type wrapper))
-
(defmacro wrapper-class (wrapper)
`(sb-kernel:class-pcl-class (sb-kernel:layout-class ,wrapper)))
(defmacro wrapper-no-of-instance-slots (wrapper)
(found
(unless (sb-kernel:class-pcl-class found)
(setf (sb-kernel:class-pcl-class found) class))
- (assert (eq (sb-kernel:class-pcl-class found) class))
+ (aver (eq (sb-kernel:class-pcl-class found) class))
(let ((layout (sb-kernel:class-layout found)))
- (assert layout)
+ (aver layout)
layout))
(t
(make-wrapper-internal
: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)
(let ((found (cl:find-class (slot-value class 'name))))
(unless (sb-kernel:class-pcl-class found)
(setf (sb-kernel:class-pcl-class found) class))
- (assert (eq (sb-kernel:class-pcl-class found) class))
+ (aver (eq (sb-kernel:class-pcl-class found) class))
found))
(t
(sb-kernel:make-standard-class :pcl-class class))))
(layout (sb-kernel:class-layout found)))
(unless (sb-kernel:class-pcl-class found)
(setf (sb-kernel:class-pcl-class found) class))
- (assert (eq (sb-kernel:class-pcl-class found) class))
- (assert layout)
+ (aver (eq (sb-kernel:class-pcl-class found) class))
+ (aver layout)
layout))))
;;; FIXME: The immediately following macros could become inline functions.
(values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
cache-size
line-size
- (the fixnum (floor cache-size line-size))))
+ (the (values fixnum t) (floor cache-size line-size))))
(let* ((line-size (power-of-two-ceiling (if valuep (1+ nkeys) nkeys)))
(cache-size (if (typep nlines-or-cache-vector 'fixnum)
(the fixnum
(values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
(the fixnum (1+ cache-size))
line-size
- (the fixnum (floor cache-size line-size))))))
+ (the (values fixnum t) (floor cache-size line-size))))))
\f
;;; the various implementations of computing a primary cache location from
;;; wrappers. Because some implementations of this must run fast there are
;;; ENSURING that the result is a fixnum
;;; MASK the result against the mask argument.
-;;; COMPUTE-PRIMARY-CACHE-LOCATION
-;;;
;;; The basic functional version. This is used by the cache miss code to
;;; compute the primary location of an entry.
(defun compute-primary-cache-location (field mask wrappers)
(incf i))
(the fixnum (1+ (logand mask location))))))
-;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION
-;;;
;;; This version is called on a cache line. It fetches the wrappers
;;; from the cache line and determines the primary location. Various
;;; parts of the cache filling code call this to determine whether it
(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 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)))
+
\f
;;;; a comment from some PCL implementor:
;;;; Its too bad Common Lisp compilers freak out when you have a
(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))))))
projects / sbcl.git / blobdiff