(make-instance 'c19)
177:
- reported by Stig E Sandoe 8 Jun 2002 on sbcl-devel:
- ;;; I am a bit unsure about SBCL's warnings with some of my code.
- ;;; ASDF seems to die on warnings and SBCL seems to generate one
- ;;; out of nothing. I've tried to turn it into an example
- ;;; (that can be LOADed or COMPILEd to reproduce warnings):
- (in-package :cl-user)
- (defclass a () ())
- (defclass b () ())
- (defclass c (b) ())
- (defgeneric get-price (obj1 obj2))
- (defmethod get-price (obj1 obj2)
- 0)
- (defmethod get-price ((obj1 a) (obj2 b))
- 20)
- (defmethod get-price ((obj1 a) (obj2 c))
- (* 3 (call-next-method)))
- (print (get-price (make-instance 'a) (make-instance 'c)))
- ;;; In the GET-PRICE where I call CALL-NEXT-METHOD, it starts to
- ;;; generate real WARNINGS:
- ;;; stig@palomba(9:02)[~] 690> sbcl
- ;;; This is SBCL 0.7.4, an implementation of ANSI Common Lisp.
- ;;; ...
- ;;; * (load "call-next")
- ;;; ; in: LAMBDA NIL
- ;;; ; (CALL-NEXT-METHOD)
- ;;; ; --> SB-PCL::CALL-NEXT-METHOD-BODY IF IF
- ;;; ; --> SB-PCL::INVOKE-EFFECTIVE-METHOD-FUNCTION LOCALLY COND IF COND IF
- ;;; PROGN
- ;;; ; --> LET WHEN COND IF PROGN SETF LET* MULTIPLE-VALUE-BIND LET FUNCALL
- ;;; ; --> SB-C::%FUNCALL BLOCK SETF SB-KERNEL:%SVSET SB-KERNEL:%ASET LET*
- ;;; ; --> SB-KERNEL:HAIRY-DATA-VECTOR-SET MULTIPLE-VALUE-BIND
- ;;; MULTIPLE-VALUE-CALL
- ;;; ; --> FUNCTION
- ;;; ; ==>
- ;;; ; (SB-KERNEL:DATA-VECTOR-SET (TRULY-THE (SIMPLE-ARRAY T 1) ARRAY)
- ;;; ; SB-INT:INDEX
- ;;; ; SB-C::NEW-VALUE)
- ;;; ;
- ;;; ; caught WARNING:
- ;;; ; Result is a A, not a NUMBER.
- ;;; ...
- ;;; ; compilation unit finished
- ;;; ; caught 4 WARNING conditions
+ (fixed in sbcl-0.7.4.24)
DEFUNCT CATEGORIES OF BUGS
#-sb-fluid (declaim (sb-ext:freeze-type fast-instance-boundp))
(eval-when (:compile-toplevel :load-toplevel :execute)
-
-(defvar *allow-emf-call-tracing-p* nil)
-(defvar *enable-emf-call-tracing-p* #-testing nil #+testing t)
-
-) ; EVAL-WHEN
+ (defvar *allow-emf-call-tracing-p* nil)
+ (defvar *enable-emf-call-tracing-p* #-sb-show nil #+sb-show t))
\f
;;;; effective method functions
(trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
(invoke-fast-method-call ,emf ,@required-args+rest-arg)))
+;;; KLUDGE: an opaque-to-the-compiler IDENTITY function to hide code
+;;; from the too-easily-bewildered compiler type checker
+(defun trust-me-i-know-what-i-am-doing (x)
+ x)
+
(defmacro invoke-effective-method-function (emf restp
&rest required-args+rest-arg)
(unless (constantp restp)
(error "The RESTP argument is not constant."))
+ ;; FIXME: The RESTP handling here is confusing and maybe slightly
+ ;; broken if RESTP evaluates to a non-self-evaluating form. E.g. if
+ ;; (INVOKE-EFFECTIVE-METHOD-FUNCTION EMF '(ERROR "gotcha") ...)
+ ;; then TRACE-EMF-CALL-CALL-INTERNAL might die on a gotcha error.
(setq restp (eval restp))
- `(locally
-
- ;; In sbcl-0.6.11.43, the compiler would issue bogus warnings
- ;; about type mismatches in unreachable code when we
- ;; macroexpanded the GET-SLOTS-OR-NIL expressions here and
- ;; byte-compiled the code. GET-SLOTS-OR-NIL is now an inline
- ;; function instead of a macro, which seems sufficient to solve
- ;; the problem all by itself (probably because of some quirk in
- ;; the relative order of expansion and type inference) but we
- ;; also use overkill by NOTINLINEing GET-SLOTS-OR-NIL, because it
- ;; looks as though (1) inlining isn't that much of a win anyway,
- ;; and (2a) once you miss the FAST-METHOD-CALL clause you're
- ;; going to be slow anyway, but (2b) code bloat still hurts even
- ;; when it's off the critical path.
- (declare (notinline get-slots-or-nil))
-
+ `(progn
(trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
(cond ((typep ,emf 'fast-method-call)
- (invoke-fast-method-call ,emf ,@required-args+rest-arg))
+ (invoke-fast-method-call ,emf ,@required-args+rest-arg))
+ ;; "What," you may wonder, "do these next two clauses do?"
+ ;; In that case, you are not a PCL implementor, for they
+ ;; considered this to be self-documenting.:-| Or CSR, for
+ ;; that matter, since he can also figure it out by looking
+ ;; at it without breaking stride. For the rest of us,
+ ;; though: From what the code is doing with .SLOTS. and
+ ;; whatnot, evidently it's implementing SLOT-VALUEish and
+ ;; GET-SLOT-VALUEish things. Then we can reason backwards
+ ;; and conclude that setting EMF to a FIXNUM is an
+ ;; optimized way to represent these slot access operations.
,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
`(((typep ,emf 'fixnum)
(let* ((.slots. (get-slots-or-nil
(let ((.new-value. ,(car required-args+rest-arg))
(.slots. (get-slots-or-nil
,(car required-args+rest-arg))))
- (when .slots.
- (setf (clos-slots-ref .slots. ,emf) .new-value.))))))
- #||
- ,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
- `(((typep ,emf 'fast-instance-boundp)
- (let ((.slots. (get-slots-or-nil
- ,(car required-args+rest-arg))))
- (and .slots.
- (not (eq (clos-slots-ref
- .slots. (fast-instance-boundp-index ,emf))
- +slot-unbound+)))))))
- ||#
+ ;; KLUDGE: As of sbcl-0.7.4.20 or so, there's not
+ ;; enough information available either at
+ ;; macroexpansion time or at compile time to
+ ;; exclude the possibility that a two-argument
+ ;; CALL-NEXT-METHOD might be a FIXNUM-encoded slot
+ ;; writer, and when the compiler sees into this
+ ;; macroexpansion, it can tell that the type
+ ;; of this clause -- just in case of being
+ ;; a slot writer -- doesn't match the type
+ ;; needed for CALL-NEXT-METHOD, and complain.
+ ;; (E.g. in
+ ;; (defmethod get-price ((obj1 a) (obj2 c))
+ ;; (* 3 (call-next-method)))
+ ;; in the original bug report from Stig Erik
+ ;; Sandoe. As a quick hack to make the bogus
+ ;; warning go away we use this
+ ;; opaque-to-the-compiler IDENTITY operation to
+ ;; hide any possible type mismatch.)
+ (trust-me-i-know-what-i-am-doing
+ (when .slots.
+ (setf (clos-slots-ref .slots. ,emf) .new-value.)))))))
+ ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN
+ ;; ...) clause here to handle SLOT-BOUNDish stuff. Since
+ ;; there was no explanation and presumably the code is 10+
+ ;; years stale, I simply deleted it. -- WHN)
(t
(etypecase ,emf
(method-call
`(if ,cnm-args
(bind-args ((,@',args
,@',(when rest-arg
- `(&rest ,rest-arg)))
+ `(&rest ,rest-arg)))
,cnm-args)
,call)
,call))))
projects / sbcl.git / commitdiff