(fixed in 0.8.2.51, but a test case would be good)
-276:
- (defmethod fee ((x fixnum))
- (setq x (/ x 2))
- x)
- (fee 1) => type error
-
- (taken from CLOCC)
-
278:
a.
(defun foo ()
(let ((tsos (make-string-output-stream))
(ssos (make-string-output-stream)))
(let ((*print-circle* t)
- (*trace-output* tsos)
- (*standard-output* ssos))
+ (*trace-output* tsos)
+ (*standard-output* ssos))
(prin1 *tangle* *standard-output*))
(let ((string (get-output-stream-string ssos)))
(unless (string= string "(#1=[FOO 4] #S(BAR) #1#)")
;; In sbcl-0.8.10.48 STRING was "(#1=[FOO 4] #2# #1#)".:-(
- (error "oops: ~S" string))))
+ (error "oops: ~S" string)))))
It might be straightforward to fix this by turning the
*CIRCULARITY-HASH-TABLE* and *CIRCULARITY-COUNTER* variables into
per-stream slots, but (1) it would probably be sort of messy faking
Fixing this should also fix a subset of #328 -- update the
description with a new test-case then.
+
+337: MAKE-METHOD and user-defined method classes
+ (reported by Bruno Haible sbcl-devel 2004-06-11)
+
+ In the presence of
+
+(defclass user-method (standard-method) (myslot))
+(defmacro def-user-method (name &rest rest)
+ (let* ((lambdalist-position (position-if #'listp rest))
+ (qualifiers (subseq rest 0 lambdalist-position))
+ (lambdalist (elt rest lambdalist-position))
+ (body (subseq rest (+ lambdalist-position 1)))
+ (required-part
+ (subseq lambdalist 0 (or
+ (position-if
+ (lambda (x) (member x lambda-list-keywords))
+ lambdalist)
+ (length lambdalist))))
+ (specializers (mapcar #'find-class
+ (mapcar (lambda (x) (if (consp x) (second x) t))
+ required-part)))
+ (unspecialized-required-part
+ (mapcar (lambda (x) (if (consp x) (first x) x)) required-part))
+ (unspecialized-lambdalist
+ (append unspecialized-required-part
+ (subseq lambdalist (length required-part)))))
+ `(PROGN
+ (ADD-METHOD #',name
+ (MAKE-INSTANCE 'USER-METHOD
+ :QUALIFIERS ',qualifiers
+ :LAMBDA-LIST ',unspecialized-lambdalist
+ :SPECIALIZERS ',specializers
+ :FUNCTION
+ (LAMBDA (ARGUMENTS NEXT-METHODS-LIST)
+ (FLET ((NEXT-METHOD-P () NEXT-METHODS-LIST)
+ (CALL-NEXT-METHOD (&REST NEW-ARGUMENTS)
+ (UNLESS NEW-ARGUMENTS (SETQ NEW-ARGUMENTS ARGUMENTS))
+ (IF (NULL NEXT-METHODS-LIST)
+ (ERROR "no next method for arguments ~:S" ARGUMENTS)
+ (FUNCALL (SB-PCL:METHOD-FUNCTION
+ (FIRST NEXT-METHODS-LIST))
+ NEW-ARGUMENTS (REST NEXT-METHODS-LIST)))))
+ (APPLY #'(LAMBDA ,unspecialized-lambdalist ,@body) ARGUMENTS)))))
+ ',name)))
+
+ (progn
+ (defgeneric test-um03 (x))
+ (defmethod test-um03 ((x integer))
+ (list* 'integer x (not (null (next-method-p))) (call-next-method)))
+ (def-user-method test-um03 ((x rational))
+ (list* 'rational x (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um03 ((x real))
+ (list 'real x (not (null (next-method-p)))))
+ (test-um03 17))
+ works, but
+
+ a.(progn
+ (defgeneric test-um10 (x))
+ (defmethod test-um10 ((x integer))
+ (list* 'integer x (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um10 ((x rational))
+ (list* 'rational x (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um10 ((x real))
+ (list 'real x (not (null (next-method-p)))))
+ (defmethod test-um10 :after ((x real)))
+ (def-user-method test-um10 :around ((x integer))
+ (list* 'around-integer x
+ (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um10 :around ((x rational))
+ (list* 'around-rational x
+ (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um10 :around ((x real))
+ (list* 'around-real x (not (null (next-method-p))) (call-next-method)))
+ (test-um10 17))
+ fails with a type error, and
+
+ b.(progn
+ (defgeneric test-um12 (x))
+ (defmethod test-um12 ((x integer))
+ (list* 'integer x (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um12 ((x rational))
+ (list* 'rational x (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um12 ((x real))
+ (list 'real x (not (null (next-method-p)))))
+ (defmethod test-um12 :after ((x real)))
+ (defmethod test-um12 :around ((x integer))
+ (list* 'around-integer x
+ (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um12 :around ((x rational))
+ (list* 'around-rational x
+ (not (null (next-method-p))) (call-next-method)))
+ (def-user-method test-um12 :around ((x real))
+ (list* 'around-real x (not (null (next-method-p))) (call-next-method)))
+ (test-um12 17))
+ fails with NO-APPLICABLE-METHOD.
+
+338: "MOP specializers as type specifiers"
+ (reported by Bruno Haible sbcl-devel 2004-06-11)
+
+ ANSI 7.6.2 says:
+ Because every valid parameter specializer is also a valid type
+ specifier, the function typep can be used during method selection
+ to determine whether an argument satisfies a parameter
+ specializer.
+
+ however, SBCL's EQL specializers are not type specifiers:
+ (defmethod foo ((x (eql 4.0))) 3.0)
+ (typep 1 (first (sb-pcl:method-specializers *)))
+ gives an error.
(declare (ignore env))
(multiple-value-bind (parameters unspecialized-lambda-list specializers)
(parse-specialized-lambda-list lambda-list)
- (declare (ignore parameters))
(multiple-value-bind (real-body declarations documentation)
(parse-body body)
(values `(lambda ,unspecialized-lambda-list
;; it can avoid run-time type dispatch overhead,
;; which can be a huge win for Python.)
;;
- ;; FIXME: Perhaps these belong in
- ;; ADD-METHOD-DECLARATIONS instead of here?
+ ;; KLUDGE: when I tried moving these to
+ ;; ADD-METHOD-DECLARATIONS, things broke. No idea
+ ;; why. -- CSR, 2004-06-16
,@(mapcar #'parameter-specializer-declaration-in-defmethod
parameters
specializers)))
((eq p '&aux)
(return nil))))))
(multiple-value-bind
- (walked-lambda call-next-method-p closurep next-method-p-p)
+ (walked-lambda call-next-method-p closurep
+ next-method-p-p setq-p)
(walk-method-lambda method-lambda
required-parameters
env
:call-next-method-p
,call-next-method-p
:next-method-p-p ,next-method-p-p
+ :setq-p ,setq-p
;; we need to pass this along
;; so that NO-NEXT-METHOD can
;; be given a suitable METHOD
(or ,cnm-args ,',method-args))))
(next-method-p-body ()
`(not (null .next-method.)))
- (with-rebound-original-args ((call-next-method-p) &body body)
- (declare (ignore call-next-method-p))
+ (with-rebound-original-args ((call-next-method-p setq-p)
+ &body body)
+ (declare (ignore call-next-method-p setq-p))
`(let () ,@body)))
,@body))
`(,rest-arg)))))))
(next-method-p-body ()
`(not (null ,',next-method-call)))
- (with-rebound-original-args ((cnm-p) &body body)
- (if cnm-p
+ (with-rebound-original-args ((cnm-p setq-p) &body body)
+ (if (or cnm-p setq-p)
`(let ,',rebindings
(declare (ignorable ,@',all-params))
,@body)
,@body)))
(defmacro bind-lexical-method-functions
- ((&key call-next-method-p next-method-p-p
+ ((&key call-next-method-p next-method-p-p setq-p
closurep applyp method-name-declaration)
&body body)
(cond ((and (null call-next-method-p) (null next-method-p-p)
- (null closurep) (null applyp))
+ (null closurep) (null applyp) (null setq-p))
`(let () ,@body))
(t
`(call-next-method-bind
,@(and next-method-p-p
'((next-method-p ()
(next-method-p-body)))))
- (with-rebound-original-args (,call-next-method-p)
+ (with-rebound-original-args (,call-next-method-p ,setq-p)
,@body))))))
(defmacro bind-args ((lambda-list args) &body body)
; should be in the method definition
(closurep nil) ; flag indicating that #'CALL-NEXT-METHOD
; was seen in the body of a method
- (next-method-p-p nil)) ; flag indicating that NEXT-METHOD-P
+ (next-method-p-p nil) ; flag indicating that NEXT-METHOD-P
; should be in the method definition
+ (setq-p nil))
(flet ((walk-function (form context env)
(cond ((not (eq context :eval)) form)
;; FIXME: Jumping to a conclusion from the way it's used
((eq (car form) 'next-method-p)
(setq next-method-p-p t)
form)
+ ((eq (car form) 'setq)
+ (setq setq-p t)
+ form)
((and (eq (car form) 'function)
(cond ((eq (cadr form) 'call-next-method)
(setq call-next-method-p t)
(values walked-lambda
call-next-method-p
closurep
- next-method-p-p)))))
+ next-method-p-p
+ setq-p)))))
(defun generic-function-name-p (name)
(and (legal-fun-name-p name)
projects / sbcl.git / commitdiff