standard-compute-effective-method))))
\f
(defmacro defgeneric (function-name lambda-list &body options)
- (expand-defgeneric function-name lambda-list options))
-
-(defun expand-defgeneric (function-name lambda-list options)
(let ((initargs ())
(methods ()))
(flet ((duplicate-option (name)
- (error 'sb-kernel:simple-program-error
+ (error 'simple-program-error
:format-control "The option ~S appears more than once."
:format-arguments (list name)))
(expand-method-definition (qab) ; QAB = qualifiers, arglist, body
(arglist (elt qab arglist-pos))
(qualifiers (subseq qab 0 arglist-pos))
(body (nthcdr (1+ arglist-pos) qab)))
- (when (not (equal (cadr (getf initargs :method-combination))
- qualifiers))
- (error "bad method specification in DEFGENERIC ~A~%~
- -- qualifier mismatch for lambda list ~A"
- function-name arglist))
`(defmethod ,function-name ,@qualifiers ,arglist ,@body))))
(macrolet ((initarg (key) `(getf initargs ,key)))
(dolist (option options)
(t
;; ANSI requires that unsupported things must get a
;; PROGRAM-ERROR.
- (error 'sb-kernel:simple-program-error
+ (error 'simple-program-error
:format-control "unsupported option ~S"
:format-arguments (list option))))))
`(not (null .next-method.))))
,@body))
-(defstruct method-call
+(defstruct (method-call (:copier nil))
(function #'identity :type function)
call-method-args)
`(list ,@required-args+rest-arg))
(method-call-call-method-args ,method-call)))
-(defstruct fast-method-call
+(defstruct (fast-method-call (:copier nil))
(function #'identity :type function)
pv-cell
next-method-call
(fast-method-call-next-method-call ,method-call)
,@required-args+rest-arg))
-(defstruct fast-instance-boundp
+(defstruct (fast-instance-boundp (:copier nil))
(index 0 :type fixnum))
#-sb-fluid (declaim (sb-ext:freeze-type fast-instance-boundp))
(unless (constantp restp)
(error "The RESTP argument is not constant."))
(setq restp (eval restp))
- `(progn
+ `(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))
+
(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))
(null closurep)
(null applyp))
`(let () ,@body))
- ((and (null closurep)
- (null applyp))
+ ((and (null closurep)
+ (null applyp))
;; OK to use MACROLET, and all args are mandatory
;; (else APPLYP would be true).
`(call-next-method-bind
(let ((method-spec (or (getf initargs ':method-spec)
(make-method-spec name quals specls))))
(setf (getf initargs ':method-spec) method-spec)
- (record-definition 'method method-spec)
(load-defmethod-internal class name quals specls
ll initargs pv-table-symbol)))
\f
(defun analyze-lambda-list (lambda-list)
(flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG?
- (parse-keyword-argument (arg)
+ (parse-key-argument (arg)
(if (listp arg)
(if (listp (car arg))
(caar arg)
(ecase state
(required (incf nrequired))
(optional (incf noptional))
- (key (push (parse-keyword-argument x) keywords)
+ (key (push (parse-key-argument x) keywords)
(push x keyword-parameters))
(rest ()))))
(values nrequired noptional keysp restp allow-other-keys-p
(analyze-lambda-list lambda-list)
(declare (ignore keyword-parameters))
(let* ((old (info :function :type name)) ;FIXME:FDOCUMENTATION instead?
- (old-ftype (if (sb-kernel:function-type-p old) old nil))
- (old-restp (and old-ftype (sb-kernel:function-type-rest old-ftype)))
+ (old-ftype (if (sb-kernel:fun-type-p old) old nil))
+ (old-restp (and old-ftype (sb-kernel:fun-type-rest old-ftype)))
(old-keys (and old-ftype
(mapcar #'sb-kernel:key-info-name
- (sb-kernel:function-type-keywords
+ (sb-kernel:fun-type-keywords
old-ftype))))
- (old-keysp (and old-ftype (sb-kernel:function-type-keyp old-ftype)))
+ (old-keysp (and old-ftype (sb-kernel:fun-type-keyp old-ftype)))
(old-allowp (and old-ftype
- (sb-kernel:function-type-allowp old-ftype)))
+ (sb-kernel:fun-type-allowp old-ftype)))
(keywords (union old-keys (mapcar #'keyword-spec-name keywords))))
`(function ,(append (make-list nrequired :initial-element t)
(when (plusp noptional)
existing function-name all-keys))))
(defun generic-clobbers-function (function-name)
- (error 'sb-kernel:simple-program-error
- :format-control
- "~S already names an ordinary function or a macro."
+ (error 'simple-program-error
+ :format-control "~S already names an ordinary function or a macro."
:format-arguments (list function-name)))
(defvar *sgf-wrapper*
(!bootstrap-slot-index 'standard-generic-function 'dfun-state))
(defstruct (arg-info
- (:conc-name nil)
- (:constructor make-arg-info ()))
+ (:conc-name nil)
+ (:constructor make-arg-info ())
+ (:copier nil))
(arg-info-lambda-list :no-lambda-list)
arg-info-precedence
arg-info-metatypes
arg-info-number-optional
arg-info-key/rest-p
- arg-info-keywords ;nil no keyword or rest allowed
- ;(k1 k2 ..) each method must accept these keyword arguments
- ;T must have &key or &rest
+ arg-info-keys ;nil no &KEY or &REST allowed
+ ;(k1 k2 ..) Each method must accept these &KEY arguments.
+ ;T must have &KEY or &REST
gf-info-simple-accessor-type ; nil, reader, writer, boundp
(gf-precompute-dfun-and-emf-p nil) ; set by set-arg-info
(esetf (arg-info-metatypes arg-info) (make-list nreq))
(esetf (arg-info-number-optional arg-info) nopt)
(esetf (arg-info-key/rest-p arg-info) (not (null (or keysp restp))))
- (esetf (arg-info-keywords arg-info)
+ (esetf (arg-info-keys arg-info)
(if lambda-list-p
(if allow-other-keys-p t keywords)
(arg-info-key/rest-p arg-info)))))
method
gf
(apply #'format nil string args)))
- (compare (x y)
+ (comparison-description (x y)
(if (> x y) "more" "fewer")))
(let ((gf-nreq (arg-info-number-required arg-info))
(gf-nopt (arg-info-number-optional arg-info))
(gf-key/rest-p (arg-info-key/rest-p arg-info))
- (gf-keywords (arg-info-keywords arg-info)))
+ (gf-keywords (arg-info-keys arg-info)))
(unless (= nreq gf-nreq)
(lose
"the method has ~A required arguments than the generic function."
- (compare nreq gf-nreq)))
+ (comparison-description nreq gf-nreq)))
(unless (= nopt gf-nopt)
(lose
- "the method has ~S optional arguments than the generic function."
- (compare nopt gf-nopt)))
+ "the method has ~A optional arguments than the generic function."
+ (comparison-description nopt gf-nopt)))
(unless (eq (or keysp restp) gf-key/rest-p)
(error
"The method and generic function differ in whether they accept~%~
(unless (or (and restp (not keysp))
allow-other-keys-p
(every #'(lambda (k) (memq k keywords)) gf-keywords))
- (lose "the method does not accept each of the keyword arguments~%~
+ (lose "the method does not accept each of the &KEY arguments~%~
~S."
gf-keywords)))))))
(setf (getf ,all-keys :method-combination)
(find-method-combination (class-prototype ,gf-class)
(car combin)
- (cdr combin)))))))
+ (cdr combin)))))
+ (let ((method-class (getf ,all-keys :method-class '.shes-not-there.)))
+ (unless (eq method-class '.shes-not-there.)
+ (setf (getf ,all-keys :method-class)
+ (find-class method-class t ,env))))))
(defun real-ensure-gf-using-class--generic-function
(existing
projects / sbcl.git / blobdiff