specl))
specializers))
(mname `(,(if (eq (cadr initargs-form) :function)
- 'method 'fast-method)
- ,name ,@qualifiers ,specls))
- (mname-sym (let ((*print-pretty* nil)
- ;; (We bind *PACKAGE* to KEYWORD here
- ;; as a way to force symbols to be
- ;; printed with explicit package
- ;; prefixes.)
- (target *package*)
- (*package* *keyword-package*))
- (format-symbol target "~S" mname))))
+ 'slow-method 'fast-method)
+ ,name ,@qualifiers ,specls)))
`(progn
- (defun ,mname-sym ,(cadr fn-lambda)
+ (defun ,mname ,(cadr fn-lambda)
,@(cddr fn-lambda))
,(make-defmethod-form-internal
name qualifiers `',specls
unspecialized-lambda-list method-class-name
`(list* ,(cadr initargs-form)
- #',mname-sym
+ #',mname
,@(cdddr initargs-form))
pv-table-symbol)))
(make-defmethod-form-internal
'(ignorable))
(t
;; Otherwise, we can usually make Python very happy.
- (let ((type (info :type :kind specializer)))
- (ecase type
- ((:primitive :defined :instance :forthcoming-defclass-type)
- `(type ,specializer ,parameter))
- ((nil)
+ (let ((kind (info :type :kind specializer)))
+ (ecase kind
+ ((:primitive) `(type ,specializer ,parameter))
+ ((:defined)
(let ((class (find-class specializer nil)))
- (if class
- `(type ,(class-name class) ,parameter)
- (progn
- ;; we can get here, and still not have a failure
- ;; case, by doing MOP programming like (PROGN
- ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO))
- ;; ...)). Best to let the user know we haven't
- ;; been able to extract enough information:
- (style-warn
- "~@<can't find type for presumed class ~S in ~S.~@:>"
- specializer
- 'parameter-specializer-declaration-in-defmethod)
- '(ignorable))))))))))
+ ;; CLASS can be null here if the user has erroneously
+ ;; tried to use a defined type as a specializer; it
+ ;; can be a non-BUILT-IN-CLASS if the user defines a
+ ;; type and calls (SETF FIND-CLASS) in a consistent
+ ;; way.
+ (when (and class (typep class 'built-in-class))
+ `(type ,specializer ,parameter))))
+ ((:instance nil)
+ (let ((class (find-class specializer nil)))
+ (cond
+ (class
+ (if (typep class '(or built-in-class structure-class))
+ `(type ,specializer ,parameter)
+ ;; don't declare CLOS classes as parameters;
+ ;; it's too expensive.
+ '(ignorable)))
+ (t
+ ;; we can get here, and still not have a failure
+ ;; case, by doing MOP programming like (PROGN
+ ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO))
+ ;; ...)). Best to let the user know we haven't
+ ;; been able to extract enough information:
+ (style-warn
+ "~@<can't find type for presumed class ~S in ~S.~@:>"
+ specializer
+ 'parameter-specializer-declaration-in-defmethod)
+ '(ignorable)))))
+ ((:forthcoming-defclass-type) '(ignorable)))))))
(defun make-method-lambda-internal (method-lambda &optional env)
(unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
((eq (car form) 'next-method-p)
(setq next-method-p-p t)
form)
- ((eq (car form) 'setq)
+ ((memq (car form) '(setq multiple-value-setq))
;; FIXME: this is possibly a little strong as
;; conditions go. Ideally we would want to detect
;; which, if any, of the method parameters are
method))
(defun make-method-spec (gf-spec qualifiers unparsed-specializers)
- `(method ,gf-spec ,@qualifiers ,unparsed-specializers))
+ `(slow-method ,gf-spec ,@qualifiers ,unparsed-specializers))
(defun initialize-method-function (initargs &optional return-function-p method)
(let* ((mf (getf initargs :function))
(when mf
(setq mf (set-fun-name mf method-spec)))
(when mff
- (let ((name `(,(or (get (car method-spec) 'fast-sym)
- (setf (get (car method-spec) 'fast-sym)
- ;; KLUDGE: If we're going to be
- ;; interning private symbols in our
- ;; a this way, it would be cleanest
- ;; to use a separate package
- ;; %PCL-PRIVATE or something, and
- ;; failing that, to use a special
- ;; symbol prefix denoting privateness.
- ;; -- WHN 19991201
- (format-symbol *pcl-package*
- "FAST-~A"
- (car method-spec))))
- ,@(cdr method-spec))))
+ (let ((name `(fast-method ,@(cdr method-spec))))
(set-fun-name mff name)
(unless mf
(set-mf-property :name name)))))
(defun arg-info-nkeys (arg-info)
(count-if (lambda (x) (neq x t)) (arg-info-metatypes arg-info)))
-;;; Keep pages clean by not setting if the value is already the same.
-(defmacro esetf (pos val)
- (with-unique-names (valsym)
- `(let ((,valsym ,val))
- (unless (equal ,pos ,valsym)
- (setf ,pos ,valsym)))))
-
(defun create-gf-lambda-list (lambda-list)
;;; Create a gf lambda list from a method lambda list
(loop for x in lambda-list
(error "The lambda-list ~S is incompatible with ~
existing methods of ~S."
lambda-list gf))))
- (esetf (arg-info-lambda-list arg-info)
- (if lambda-list-p
- lambda-list
+ (setf (arg-info-lambda-list arg-info)
+ (if lambda-list-p
+ lambda-list
(create-gf-lambda-list lambda-list)))
(when (or lambda-list-p argument-precedence-order
(null (arg-info-precedence arg-info)))
- (esetf (arg-info-precedence arg-info)
- (compute-precedence lambda-list nreq
- argument-precedence-order)))
- (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-keys arg-info)
- (if lambda-list-p
- (if allow-other-keys-p t keywords)
- (arg-info-key/rest-p arg-info)))))
+ (setf (arg-info-precedence arg-info)
+ (compute-precedence lambda-list nreq argument-precedence-order)))
+ (setf (arg-info-metatypes arg-info) (make-list nreq))
+ (setf (arg-info-number-optional arg-info) nopt)
+ (setf (arg-info-key/rest-p arg-info) (not (null (or keysp restp))))
+ (setf (arg-info-keys arg-info)
+ (if lambda-list-p
+ (if allow-other-keys-p t keywords)
+ (arg-info-key/rest-p arg-info)))))
(when new-method
(check-method-arg-info gf arg-info new-method))
(set-arg-info1 gf arg-info new-method methods was-valid-p first-p)
(setq type (cond ((null type) new-type)
((eq type new-type) type)
(t nil)))))
- (esetf (arg-info-metatypes arg-info) metatypes)
- (esetf (gf-info-simple-accessor-type arg-info) type)))
+ (setf (arg-info-metatypes arg-info) metatypes)
+ (setf (gf-info-simple-accessor-type arg-info) type)))
(when (or (not was-valid-p) first-p)
(multiple-value-bind (c-a-m-emf std-p)
(if (early-gf-p gf)
(values t t)
(compute-applicable-methods-emf gf))
- (esetf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf)
- (esetf (gf-info-c-a-m-emf-std-p arg-info) std-p)
+ (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf)
+ (setf (gf-info-c-a-m-emf-std-p arg-info) std-p)
(unless (gf-info-c-a-m-emf-std-p arg-info)
- (esetf (gf-info-simple-accessor-type arg-info) t))))
+ (setf (gf-info-simple-accessor-type arg-info) t))))
(unless was-valid-p
(let ((name (if (eq *boot-state* 'complete)
(generic-function-name gf)
(!early-gf-name gf))))
- (esetf (gf-precompute-dfun-and-emf-p arg-info)
- (cond
- ((and (consp name)
- (member (car name)
- *internal-pcl-generalized-fun-name-symbols*))
+ (setf (gf-precompute-dfun-and-emf-p arg-info)
+ (cond
+ ((and (consp name)
+ (member (car name)
+ *internal-pcl-generalized-fun-name-symbols*))
nil)
- (t (let* ((symbol (fun-name-block-name name))
- (package (symbol-package symbol)))
- (and (or (eq package *pcl-package*)
- (memq package (package-use-list *pcl-package*)))
- ;; FIXME: this test will eventually be
- ;; superseded by the *internal-pcl...* test,
- ;; above. While we are in a process of
- ;; transition, however, it should probably
- ;; remain.
- (not (find #\Space (symbol-name symbol))))))))))
- (esetf (gf-info-fast-mf-p arg-info)
- (or (not (eq *boot-state* 'complete))
- (let* ((method-class (generic-function-method-class gf))
- (methods (compute-applicable-methods
- #'make-method-lambda
- (list gf (class-prototype method-class)
- '(lambda) nil))))
- (and methods (null (cdr methods))
- (let ((specls (method-specializers (car methods))))
- (and (classp (car specls))
- (eq 'standard-generic-function
- (class-name (car specls)))
- (classp (cadr specls))
- (eq 'standard-method
- (class-name (cadr specls)))))))))
+ (t (let* ((symbol (fun-name-block-name name))
+ (package (symbol-package symbol)))
+ (and (or (eq package *pcl-package*)
+ (memq package (package-use-list *pcl-package*)))
+ ;; FIXME: this test will eventually be
+ ;; superseded by the *internal-pcl...* test,
+ ;; above. While we are in a process of
+ ;; transition, however, it should probably
+ ;; remain.
+ (not (find #\Space (symbol-name symbol))))))))))
+ (setf (gf-info-fast-mf-p arg-info)
+ (or (not (eq *boot-state* 'complete))
+ (let* ((method-class (generic-function-method-class gf))
+ (methods (compute-applicable-methods
+ #'make-method-lambda
+ (list gf (class-prototype method-class)
+ '(lambda) nil))))
+ (and methods (null (cdr methods))
+ (let ((specls (method-specializers (car methods))))
+ (and (classp (car specls))
+ (eq 'standard-generic-function
+ (class-name (car specls)))
+ (classp (cadr specls))
+ (eq 'standard-method
+ (class-name (cadr specls)))))))))
arg-info)
;;; This is the early definition of ENSURE-GENERIC-FUNCTION-USING-CLASS.
gf (method-generic-function method)
temp (and gf (generic-function-name gf))
name (if temp
- (intern-fun-name
- (make-method-spec temp
- (method-qualifiers method)
- (unparse-specializers
- (method-specializers method))))
+ (make-method-spec temp
+ (method-qualifiers method)
+ (unparse-specializers
+ (method-specializers method)))
(make-symbol (format nil "~S" method))))
(multiple-value-bind (gf-spec quals specls)
(parse-defmethod spec)
(and
(setq method (get-method gf quals specls errorp))
(setq name
- (intern-fun-name (make-method-spec gf-spec
- quals
- specls))))))))
+ (make-method-spec
+ gf-spec quals (unparse-specializers specls))))))))
(values gf method name)))
\f
(defun extract-parameters (specialized-lambda-list)