\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)
;; 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))))
- (setf (info :function :type name)
+ (let* ((allowp (or gf.allowp
+ (find '&allow-other-keys methods
+ :test #'find
+ :key #'method-lambda-list)))
+ (ftype
(specifier-type
`(function
(,@(mapcar tfun gf.required)
`(&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))))))
- (values)))
+ (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)
(eq gf #'(setf slot-value-using-class))
(eq gf #'slot-boundp-using-class)))
-(let (po-cache)
+(let (initial-print-object-cache)
(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)
(cond ((/= nkeys 1)
;; KLUDGE: someone has defined a method
;; specialized on the second argument: punt.
- (setf po-cache nil)
+ (setf initial-print-object-cache nil)
(make-initial-dfun gf))
- (po-cache
+ (initial-print-object-cache
(multiple-value-bind (dfun cache info)
- (make-caching-dfun gf po-cache)
+ (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
(t (multiple-value-bind (dfun cache info)
(make-final-dfun-internal
gf
- (list (list (find-class 'sb-kernel::control-stack-exhausted))
- (list (find-class 'sb-kernel::heap-exhausted-error))
- (list (find-class 'restart))))
- (setq po-cache cache)
- (set-dfun gf dfun cache info))))))
+ (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))))))
-
-(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))))))
\f
(defmethod (setf class-name) (new-value class)
(let ((classoid (wrapper-classoid (class-wrapper class))))
projects / sbcl.git / blobdiff