(qualifiers (subseq qab 0 arglist-pos))
(body (nthcdr (1+ arglist-pos) qab)))
`(push (defmethod ,fun-name ,@qualifiers ,arglist ,@body)
- (generic-function-initial-methods #',fun-name)))))
+ (generic-function-initial-methods (fdefinition ',fun-name))))))
(macrolet ((initarg (key) `(getf initargs ,key)))
(dolist (option options)
(let ((car-option (car option)))
(compile-or-load-defgeneric ',fun-name))
(load-defgeneric ',fun-name ',lambda-list ,@initargs)
,@(mapcar #'expand-method-definition methods)
- #',fun-name))))
+ (fdefinition ',fun-name)))))
(defun compile-or-load-defgeneric (fun-name)
(proclaim-as-fun-name fun-name)
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))))
+ ,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
;; second argument.) Hopefully it only does this kind of
;; weirdness when bootstrapping.. -- WHN 20000610
'(ignorable))
+ ((var-globally-special-p parameter)
+ ;; KLUDGE: Don't declare types for global special variables
+ ;; -- our rebinding magic for SETQ cases don't work right
+ ;; there.
+ ;;
+ ;; FIXME: It would be better to detect the SETQ earlier and
+ ;; skip declarations for specials only when needed, not
+ ;; always.
+ ;;
+ ;; --NS 2004-10-14
+ '(ignorable))
(t
;; Otherwise, we can usually make Python very happy.
(let ((type (info :type :kind specializer)))
(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)))))
(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
+ collect (if (consp x) (list (car x)) x)
+ if (eq x '&key) do (loop-finish)))
+
(defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p)
argument-precedence-order)
(let* ((arg-info (if (eq *boot-state* 'complete)
(error "The lambda-list ~S is incompatible with ~
existing methods of ~S."
lambda-list gf))))
- (when lambda-list-p
- (esetf (arg-info-lambda-list arg-info) lambda-list))
+ (esetf (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)
(let* ((method (car (last methods)))
(ll (if (consp method)
(early-method-lambda-list method)
- (method-lambda-list method)))
- (k (member '&key ll)))
- (if k
- (ldiff ll (cdr k))
- ll))))
+ (method-lambda-list method))))
+ (create-gf-lambda-list ll))))
(arg-info-lambda-list arg-info))))
(defmacro real-ensure-gf-internal (gf-class all-keys env)
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)