(dolist (method methods)
(let ((mspecializers (method-specializers method)))
(aver (= lspec (length mspecializers)))
- (when (and (equal qualifiers (method-qualifiers method))
+ (when (and (equal qualifiers (safe-method-qualifiers method))
(every #'same-specializer-p specializers
(method-specializers method)))
(return method))))))
\f
(defmethod generic-function-argument-precedence-order
((gf standard-generic-function))
- (aver (eq *boot-state* 'complete))
+ (aver (eq **boot-state** 'complete))
(loop with arg-info = (gf-arg-info gf)
with lambda-list = (arg-info-lambda-list arg-info)
for argument-position in (arg-info-precedence arg-info)
(slot-value method 'qualifiers)
(slot-value method 'specializers)
(slot-value method 'lambda-list)
- (slot-value method '%generic-function))))
+ (slot-value method '%generic-function)
+ (slot-value gf 'name))))
+
+(define-condition print-object-stream-specializer (reference-condition simple-warning)
+ ()
+ (:default-initargs
+ :references (list '(:ansi-cl :function print-object))
+ :format-control "~@<Specializing on the second argument to ~S has ~
+ unportable effects, and also interferes with ~
+ precomputation of print functions for exceptional ~
+ situations.~@:>"
+ :format-arguments (list 'print-object)))
(defun real-add-method (generic-function method &optional skip-dfun-update-p)
(flet ((similar-lambda-lists-p (old-method new-lambda-list)
(eq (or a-keyp a-restp)
(or b-keyp b-restp)))))))
(multiple-value-bind (lock qualifiers specializers new-lambda-list
- method-gf)
+ method-gf name)
(values-for-add-method generic-function method)
(when method-gf
(error "~@<The method ~S is already part of the generic ~
function ~S; it can't be added to another generic ~
function until it is removed from the first one.~@:>"
method method-gf))
+ (when (and (eq name 'print-object) (not (eq (second specializers) *the-class-t*)))
+ (warn 'print-object-stream-specializer))
(handler-case
;; System lock because interrupts need to be disabled as
;; well: it would be bad to unwind and leave the gf in an
;; inconsistent state.
- (sb-thread::with-recursive-system-spinlock (lock)
+ (sb-thread::with-recursive-system-lock (lock)
(let ((existing (get-method generic-function
qualifiers
specializers
(warn "~@<Invalid qualifiers for ~S method combination ~
in method ~S:~2I~_~S.~@:>"
mc-name method qualifiers))))))
-
(unless skip-dfun-update-p
(update-ctors 'add-method
:generic-function generic-function
:method method)
(update-dfun generic-function))
+ (setf (gf-info-needs-update generic-function) t)
(map-dependents generic-function
(lambda (dep)
(update-dependent generic-function
;; System lock because interrupts need to be disabled as well:
;; it would be bad to unwind and leave the gf in an inconsistent
;; state.
- (sb-thread::with-recursive-system-spinlock (lock)
+ (sb-thread::with-recursive-system-lock (lock)
(let* ((specializers (method-specializers method))
(methods (generic-function-methods generic-function))
(new-methods (remove method methods)))
:generic-function generic-function
:method method)
(update-dfun generic-function)
+ (setf (gf-info-needs-update generic-function) t)
(map-dependents generic-function
(lambda (dep)
(update-dependent generic-function
dep 'remove-method method)))))))
generic-function)
+
+
+;; Tell INFO about the generic function's methods' keys so that the
+;; compiler doesn't complain that the keys defined for some method are
+;; unrecognized.
+(sb-ext:without-package-locks
+ (defun sb-c::maybe-update-info-for-gf (name)
+ (let ((gf (if (fboundp name) (fdefinition name))))
+ (when (and gf (generic-function-p gf) (not (early-gf-p gf))
+ (not (eq :declared (info :function :where-from name)))
+ (gf-info-needs-update gf))
+ (let* ((methods (generic-function-methods gf))
+ (gf-lambda-list (generic-function-lambda-list gf))
+ (tfun (constantly t))
+ keysp)
+ (multiple-value-bind (gf.required gf.optional gf.restp gf.rest
+ gf.keyp gf.keys gf.allowp)
+ (parse-lambda-list gf-lambda-list)
+ (declare (ignore gf.rest))
+ ;; 7.6.4 point 5 probably entails that if any method says
+ ;; &allow-other-keys then the gf should be construed to
+ ;; accept any key.
+ (let* ((allowp (or gf.allowp
+ (find '&allow-other-keys methods
+ :test #'find
+ :key #'method-lambda-list)))
+ (ftype
+ (specifier-type
+ `(function
+ (,@(mapcar tfun gf.required)
+ ,@(if gf.optional
+ `(&optional ,@(mapcar tfun gf.optional)))
+ ,@(if gf.restp
+ `(&rest t))
+ ,@(when gf.keyp
+ (let ((all-keys
+ (mapcar
+ (lambda (x)
+ (list x t))
+ (remove-duplicates
+ (nconc
+ (mapcan #'function-keywords methods)
+ (mapcar #'keyword-spec-name gf.keys))))))
+ (when all-keys
+ (setq keysp t)
+ `(&key ,@all-keys))))
+ ,@(when (and (not keysp) allowp)
+ `(&key))
+ ,@(when allowp
+ `(&allow-other-keys)))
+ *))))
+ (setf (info :function :type name) ftype
+ (info :function :where-from name) :defined-method
+ (gf-info-needs-update gf) nil)
+ ftype)))))))
\f
(defun compute-applicable-methods-function (generic-function arguments)
(values (compute-applicable-methods-using-types
(let ((emf (get-effective-method-function generic-function
methods)))
(invoke-emf emf args))
- (apply #'no-applicable-method generic-function args)))))
+ (call-no-applicable-method generic-function args)))))
(defun list-eq (x y)
(loop (when (atom x) (return (eq x y)))
(defvar *std-cam-methods* nil)
(defun compute-applicable-methods-emf (generic-function)
- (if (eq *boot-state* 'complete)
+ (if (eq **boot-state** 'complete)
(let* ((cam (gdefinition 'compute-applicable-methods))
(cam-methods (compute-applicable-methods-using-types
cam (list `(eql ,generic-function) t))))
(class-eq (cadr type))
(class (cadr type)))))
-(defun precompute-effective-methods (gf caching-p &optional classes-list-p)
- (let* ((arg-info (gf-arg-info gf))
- (methods (generic-function-methods gf))
- (precedence (arg-info-precedence arg-info))
- (*in-precompute-effective-methods-p* t)
- (classes-list nil))
- (generate-discrimination-net-internal
- gf methods nil
- (lambda (methods known-types)
- (when methods
- (when classes-list-p
- (push (mapcar #'class-from-type known-types) classes-list))
- (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p
- methods))))
- (map-all-orders
- methods precedence
- (lambda (methods)
- (get-secondary-dispatch-function1
- gf methods known-types
- nil caching-p no-eql-specls-p))))))
- (lambda (position type true-value false-value)
- (declare (ignore position type true-value false-value))
- nil)
- (lambda (type)
- (if (and (consp type) (eq (car type) 'eql))
- `(class-eq ,(class-of (cadr type)))
- type)))
- classes-list))
-
;;; We know that known-type implies neither new-type nor `(not ,new-type).
(defun augment-type (new-type known-type)
(if (or (eq known-type t)
(make-dfun-lambda-list nargs applyp)
(make-fast-method-call-lambda-list nargs applyp))))
(multiple-value-bind (cfunction constants)
- (get-fun1 `(lambda
+ (get-fun1 `(named-lambda (gf-dispatch ,name)
,arglist
,@(unless function-p
`((declare (ignore .pv. .next-method-call.))))
(defun slot-value-using-class-dfun (class object slotd)
(declare (ignore class))
- (function-funcall (slot-definition-reader-function slotd) object))
+ (funcall (slot-info-reader (slot-definition-info slotd)) object))
(defun setf-slot-value-using-class-dfun (new-value class object slotd)
(declare (ignore class))
- (function-funcall (slot-definition-writer-function slotd) new-value object))
+ (funcall (slot-info-writer (slot-definition-info slotd)) new-value object))
(defun slot-boundp-using-class-dfun (class object slotd)
(declare (ignore class))
- (function-funcall (slot-definition-boundp-function slotd) object))
+ (funcall (slot-info-boundp (slot-definition-info slotd)) object))
(defun special-case-for-compute-discriminating-function-p (gf)
(or (eq gf #'slot-value-using-class)
(eq gf #'(setf slot-value-using-class))
(eq gf #'slot-boundp-using-class)))
+;;; this is the normal function for computing the discriminating
+;;; function of a standard-generic-function
+(let (initial-print-object-cache)
+ (defun standard-compute-discriminating-function (gf)
+ (let ((dfun-state (slot-value gf 'dfun-state)))
+ (when (special-case-for-compute-discriminating-function-p gf)
+ ;; if we have a special case for
+ ;; COMPUTE-DISCRIMINATING-FUNCTION, then (at least for the
+ ;; special cases implemented as of 2006-05-09) any information
+ ;; in the cache is misplaced.
+ (aver (null dfun-state)))
+ (typecase dfun-state
+ (null
+ (when (eq gf #'compute-applicable-methods)
+ (update-all-c-a-m-gf-info gf))
+ (cond
+ ((eq gf #'slot-value-using-class)
+ (update-slot-value-gf-info gf 'reader)
+ #'slot-value-using-class-dfun)
+ ((eq gf #'(setf slot-value-using-class))
+ (update-slot-value-gf-info gf 'writer)
+ #'setf-slot-value-using-class-dfun)
+ ((eq gf #'slot-boundp-using-class)
+ (update-slot-value-gf-info gf 'boundp)
+ #'slot-boundp-using-class-dfun)
+ ;; KLUDGE: PRINT-OBJECT is not a special-case in the sense
+ ;; of having a desperately special discriminating function.
+ ;; However, it is important that the machinery for printing
+ ;; conditions for stack and heap exhaustion, and the
+ ;; restarts offered by the debugger, work without consuming
+ ;; many extra resources. This way (testing by name of GF
+ ;; rather than by identity) was the only way I found to get
+ ;; this to bootstrap, given that the PRINT-OBJECT generic
+ ;; function is only set up later, in
+ ;; SRC;PCL;PRINT-OBJECT.LISP. -- CSR, 2008-06-09
+ ((eq (slot-value gf 'name) 'print-object)
+ (let ((nkeys (nth-value 3 (get-generic-fun-info gf))))
+ (cond ((/= nkeys 1)
+ ;; KLUDGE: someone has defined a method
+ ;; specialized on the second argument: punt.
+ (setf initial-print-object-cache nil)
+ (make-initial-dfun gf))
+ (initial-print-object-cache
+ (multiple-value-bind (dfun cache info)
+ (make-caching-dfun gf (copy-cache initial-print-object-cache))
+ (set-dfun gf dfun cache info)))
+ ;; the relevant PRINT-OBJECT methods get defined
+ ;; late, by delayed DEF!METHOD. We mustn't cache
+ ;; the effective method for our classes earlier
+ ;; than the relevant PRINT-OBJECT methods are
+ ;; defined...
+ ((boundp 'sb-impl::*delayed-def!method-args*)
+ (make-initial-dfun gf))
+ (t (multiple-value-bind (dfun cache info)
+ (make-final-dfun-internal
+ gf
+ (mapcar (lambda (x) (list (find-class x)))
+ '(sb-kernel::control-stack-exhausted
+ sb-kernel::binding-stack-exhausted
+ sb-kernel::alien-stack-exhausted
+ sb-kernel::heap-exhausted-error
+ restart)))
+ (setq initial-print-object-cache cache)
+ (set-dfun gf dfun (copy-cache cache) info))))))
+ ((gf-precompute-dfun-and-emf-p (slot-value gf 'arg-info))
+ (make-final-dfun gf))
+ (t
+ (make-initial-dfun gf))))
+ (function dfun-state)
+ (cons (car dfun-state))))))
+
+;;; in general we need to support SBCL's encapsulation for generic
+;;; functions: the default implementation of encapsulation changes the
+;;; identity of the function bound to a name, which breaks anything
+;;; class-based, so we implement the encapsulation ourselves in the
+;;; discriminating function.
+(defun sb-impl::encapsulate-generic-function (gf type body)
+ (push (cons type body) (generic-function-encapsulations gf))
+ (reinitialize-instance gf))
+(defun sb-impl::unencapsulate-generic-function (gf type)
+ (setf (generic-function-encapsulations gf)
+ (remove type (generic-function-encapsulations gf)
+ :key #'car :count 1))
+ (reinitialize-instance gf))
+(defun sb-impl::encapsulated-generic-function-p (gf type)
+ (position type (generic-function-encapsulations gf) :key #'car))
+(defun standard-compute-discriminating-function-with-encapsulations (gf encs)
+ (if (null encs)
+ (standard-compute-discriminating-function gf)
+ (let ((inner (standard-compute-discriminating-function-with-encapsulations
+ gf (cdr encs)))
+ (body (cdar encs)))
+ (lambda (&rest args)
+ (let ((sb-int:arg-list args)
+ (sb-int:basic-definition inner))
+ (declare (special sb-int:arg-list sb-int:basic-definition))
+ (eval body))))))
(defmethod compute-discriminating-function ((gf standard-generic-function))
- (let ((dfun-state (slot-value gf 'dfun-state)))
- (when (special-case-for-compute-discriminating-function-p gf)
- ;; if we have a special case for
- ;; COMPUTE-DISCRIMINATING-FUNCTION, then (at least for the
- ;; special cases implemented as of 2006-05-09) any information
- ;; in the cache is misplaced.
- (aver (null dfun-state)))
- (typecase dfun-state
- (null
- (when (eq gf #'compute-applicable-methods)
- (update-all-c-a-m-gf-info gf))
- (cond
- ((eq gf #'slot-value-using-class)
- (update-slot-value-gf-info gf 'reader)
- #'slot-value-using-class-dfun)
- ((eq gf #'(setf slot-value-using-class))
- (update-slot-value-gf-info gf 'writer)
- #'setf-slot-value-using-class-dfun)
- ((eq gf #'slot-boundp-using-class)
- (update-slot-value-gf-info gf 'boundp)
- #'slot-boundp-using-class-dfun)
- ((gf-precompute-dfun-and-emf-p (slot-value gf 'arg-info))
- (make-final-dfun gf))
- (t
- (make-initial-dfun gf))))
- (function dfun-state)
- (cons (car dfun-state)))))
-
-(defmethod update-gf-dfun ((class std-class) gf)
- (let ((*new-class* class)
- (arg-info (gf-arg-info gf)))
- (cond
- ((special-case-for-compute-discriminating-function-p gf))
- ((gf-precompute-dfun-and-emf-p arg-info)
- (multiple-value-bind (dfun cache info)
- (make-final-dfun-internal gf)
- (update-dfun gf dfun cache info))))))
+ (standard-compute-discriminating-function-with-encapsulations
+ gf (generic-function-encapsulations gf)))
\f
(defmethod (setf class-name) (new-value class)
(let ((classoid (wrapper-classoid (class-wrapper class))))
(reinitialize-instance generic-function :name new-value)
new-value)
\f
+(defmethod function-keywords ((method standard-method))
+ (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p
+ keywords)
+ (analyze-lambda-list (if (consp method)
+ (early-method-lambda-list method)
+ (method-lambda-list method)))
+ (declare (ignore nreq nopt keysp restp))
+ (values keywords allow-other-keys-p)))
+
(defmethod function-keyword-parameters ((method standard-method))
(multiple-value-bind (nreq nopt keysp restp allow-other-keys-p
keywords keyword-parameters)
;; PARSE-LAMBDA-LIST to something handier.
(multiple-value-bind (required optional restp rest keyp keys allowp
auxp aux morep more-context more-count)
- (parse-lambda-list lambda-list)
+ (parse-lambda-list lambda-list :silent t)
(declare (ignore restp keyp auxp aux morep))
(declare (ignore more-context more-count))
(values required optional rest keys allowp)))
projects / sbcl.git / blobdiff