(pv-cell (cons pv calls))
(new-cache (fill-cache cache pv-wrappers pv-cell)))
(unless (eq new-cache cache)
- (setf (pv-table-cache pv-table) new-cache)
- (free-cache cache))
+ (setf (pv-table-cache pv-table) new-cache))
pv-cell))))
(defun make-pv-type-declaration (var)
`(locally (declare #.*optimize-speed*)
(let ((,index (pvref ,pv ,pv-offset)))
(setq ,value (typecase ,index
+ ;; FIXME: the line marked by KLUDGE below
+ ;; (and the analogous spot in
+ ;; INSTANCE-WRITE-INTERNAL) is there purely
+ ;; to suppress a type mismatch warning that
+ ;; propagates through to user code.
+ ;; Presumably SLOTS at this point can never
+ ;; actually be NIL, but the compiler seems
+ ;; to think it could, so we put this here
+ ;; to shut it up. (see also mail Rudi
+ ;; Schlatte sbcl-devel 2003-09-21) -- CSR,
+ ;; 2003-11-30
,@(when (or (null type) (eq type :instance))
- `((fixnum (clos-slots-ref ,slots ,index))))
+ `((fixnum
+ (and ,slots ; KLUDGE
+ (clos-slots-ref ,slots ,index)))))
,@(when (or (null type) (eq type :class))
`((cons (cdr ,index))))
(t +slot-unbound+)))
(let ((,index (pvref ,pv ,pv-offset)))
(typecase ,index
,@(when (or (null type) (eq type :instance))
- `((fixnum (setf (clos-slots-ref ,slots ,index)
- ,new-value))))
+ `((fixnum (and ,slots
+ (setf (clos-slots-ref ,slots ,index)
+ ,new-value)))))
,@(when (or (null type) (eq type :class))
`((cons (setf (cdr ,index) ,new-value))))
(t ,default)))))))
`(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters)
(let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
slot-vars pv-parameters))
- ,@body)))
+ (declare (ignorable ,@(mapcar #'identity slot-vars)))
+ ,@body)))
;;; This gets used only when the default MAKE-METHOD-LAMBDA is
;;; overridden.
;;; body given, or return NIL if no %METHOD-NAME declaration is found.
(defun body-method-name (body)
(multiple-value-bind (real-body declarations documentation)
- (parse-body body nil)
- (declare (ignore documentation real-body))
+ (parse-body body)
+ (declare (ignore real-body documentation))
(let ((name-decl (get-declaration '%method-name declarations)))
(and name-decl
(destructuring-bind (name) name-decl
req-args)))
`(list*
:fast-function
- (named-lambda
- ,(or (body-method-name body) '.method.) ; function name
+ (,(if (body-method-name body) 'named-lambda 'lambda)
+ ,@(when (body-method-name body)
+ (list (body-method-name body))) ; function name
(.pv-cell. .next-method-call. ,@args+rest-arg) ; function args
;; body of the function
(declare (ignorable .pv-cell. .next-method-call.))