(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)
:definition-source `((defgeneric ,fun-name) ,*load-pathname*)
initargs))
-;;; As per section 3.4.2 of the ANSI spec, generic function lambda
-;;; lists have some special limitations, which we check here.
+(define-condition generic-function-lambda-list-error
+ (reference-condition simple-program-error)
+ ()
+ (:default-initargs :references (list '(:ansi-cl :section (3 4 2)))))
+
(defun check-gf-lambda-list (lambda-list)
(flet ((ensure (arg ok)
(unless ok
- (error
- ;; (s/invalid/non-ANSI-conforming/ because the old PCL
- ;; implementation allowed this, so people got used to
- ;; it, and maybe this phrasing will help them to guess
- ;; why their program which worked under PCL no longer works.)
- "~@<non-ANSI-conforming argument ~S ~_in the generic function lambda list ~S~:>"
- arg lambda-list))))
+ (error 'generic-function-lambda-list-error
+ :format-control
+ "~@<invalid ~S ~_in the generic function lambda list ~S~:>"
+ :format-arguments (list arg lambda-list)))))
(multiple-value-bind (required optional restp rest keyp keys allowp
auxp aux morep more-context more-count)
(parse-lambda-list lambda-list)
(mname `(,(if (eq (cadr initargs-form) :function)
'method 'fast-method)
,name ,@qualifiers ,specls))
- (mname-sym (intern (let ((*print-pretty* nil)
- ;; (We bind *PACKAGE* to
- ;; KEYWORD here as a way to
- ;; force symbols to be printed
- ;; with explicit package
- ;; prefixes.)
- (*package* *keyword-package*))
- (format nil "~S" mname)))))
+ (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))))
`(progn
(defun ,mname-sym ,(cadr fn-lambda)
,@(cddr fn-lambda))
`(list ,@(mapcar (lambda (specializer)
(if (consp specializer)
``(,',(car specializer)
- ,,(cadr specializer))
+ ,,(cadr specializer))
`',specializer))
specializers))
unspecialized-lambda-list
env))))
(defun add-method-declarations (name qualifiers lambda-list body env)
+ (declare (ignore env))
(multiple-value-bind (parameters unspecialized-lambda-list specializers)
(parse-specialized-lambda-list lambda-list)
- (declare (ignore parameters))
(multiple-value-bind (real-body declarations documentation)
- (parse-body body env)
+ (parse-body body)
(values `(lambda ,unspecialized-lambda-list
,@(when documentation `(,documentation))
;; (Old PCL code used a somewhat different style of
;; 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)))
is not a lambda form."
method-lambda))
(multiple-value-bind (real-body declarations documentation)
- (parse-body (cddr method-lambda) env)
+ (parse-body (cddr method-lambda))
(let* ((name-decl (get-declaration '%method-name declarations))
(sll-decl (get-declaration '%method-lambda-list declarations))
(method-name (when (consp name-decl) (car name-decl)))
;; it can avoid run-time type dispatch overhead,
;; which can be a huge win for Python.)
;;
- ;; FIXME: Perhaps these belong in
- ;; ADD-METHOD-DECLARATIONS instead of here?
+ ;; KLUDGE: when I tried moving these to
+ ;; ADD-METHOD-DECLARATIONS, things broke. No idea
+ ;; why. -- CSR, 2004-06-16
,@(mapcar #'parameter-specializer-declaration-in-defmethod
parameters
specializers)))
((eq p '&aux)
(return nil))))))
(multiple-value-bind
- (walked-lambda call-next-method-p closurep next-method-p-p)
+ (walked-lambda call-next-method-p closurep
+ next-method-p-p setq-p)
(walk-method-lambda method-lambda
required-parameters
env
(multiple-value-bind (walked-lambda-body
walked-declarations
walked-documentation)
- (parse-body (cddr walked-lambda) env)
+ (parse-body (cddr walked-lambda))
(declare (ignore walked-documentation))
(when (or next-method-p-p call-next-method-p)
(setq plist (list* :needs-next-methods-p t plist)))
:call-next-method-p
,call-next-method-p
:next-method-p-p ,next-method-p-p
+ :setq-p ,setq-p
;; we need to pass this along
;; so that NO-NEXT-METHOD can
;; be given a suitable METHOD
(or ,cnm-args ,',method-args))))
(next-method-p-body ()
`(not (null .next-method.)))
- (with-rebound-original-args ((call-next-method-p) &body body)
- (declare (ignore call-next-method-p))
+ (with-rebound-original-args ((call-next-method-p setq-p)
+ &body body)
+ (declare (ignore call-next-method-p setq-p))
`(let () ,@body)))
,@body))
`(,rest-arg)))))))
(next-method-p-body ()
`(not (null ,',next-method-call)))
- (with-rebound-original-args ((cnm-p) &body body)
- (if cnm-p
+ (with-rebound-original-args ((cnm-p setq-p) &body body)
+ (if (or cnm-p setq-p)
`(let ,',rebindings
(declare (ignorable ,@',all-params))
,@body)
,@body)))
(defmacro bind-lexical-method-functions
- ((&key call-next-method-p next-method-p-p
+ ((&key call-next-method-p next-method-p-p setq-p
closurep applyp method-name-declaration)
&body body)
(cond ((and (null call-next-method-p) (null next-method-p-p)
- (null closurep) (null applyp))
+ (null closurep) (null applyp) (null setq-p))
`(let () ,@body))
(t
`(call-next-method-bind
,@(and next-method-p-p
'((next-method-p ()
(next-method-p-body)))))
- (with-rebound-original-args (,call-next-method-p)
+ (with-rebound-original-args (,call-next-method-p ,setq-p)
,@body))))))
(defmacro bind-args ((lambda-list args) &body body)
; should be in the method definition
(closurep nil) ; flag indicating that #'CALL-NEXT-METHOD
; was seen in the body of a method
- (next-method-p-p nil)) ; flag indicating that NEXT-METHOD-P
+ (next-method-p-p nil) ; flag indicating that NEXT-METHOD-P
; should be in the method definition
+ (setq-p nil))
(flet ((walk-function (form context env)
(cond ((not (eq context :eval)) form)
;; FIXME: Jumping to a conclusion from the way it's used
((eq (car form) 'next-method-p)
(setq next-method-p-p t)
form)
+ ((eq (car form) '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
+ ;; being set, and communicate that information to
+ ;; e.g. SPLIT-DECLARATIONS. However, the brute
+ ;; force method doesn't really cost much; a little
+ ;; loss of discrimination over IGNORED variables
+ ;; should be all. -- CSR, 2004-07-01
+ (setq setq-p t)
+ form)
((and (eq (car form) 'function)
(cond ((eq (cadr form) 'call-next-method)
(setq call-next-method-p t)
(values walked-lambda
call-next-method-p
closurep
- next-method-p-p)))))
+ next-method-p-p
+ setq-p)))))
(defun generic-function-name-p (name)
(and (legal-fun-name-p name)
;; failing that, to use a special
;; symbol prefix denoting privateness.
;; -- WHN 19991201
- (intern (format nil "FAST-~A"
- (car method-spec))
- *pcl-package*)))
- ,@(cdr method-spec))))
+ (format-symbol *pcl-package*
+ "FAST-~A"
+ (car method-spec))))
+ ,@(cdr method-spec))))
(set-fun-name mff name)
(unless mf
(set-mf-property :name name)))))
*))))
(defun defgeneric-declaration (spec lambda-list)
- (when (consp spec)
- (setq spec (get-setf-fun-name (cadr spec))))
`(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec))
\f
;;;; early generic function support
(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)
&allow-other-keys)
(declare (ignore keys))
(cond ((and existing (early-gf-p existing))
+ (when lambda-list-p
+ (set-arg-info existing :lambda-list lambda-list))
existing)
((assoc spec *!generic-function-fixups* :test #'equal)
(if existing
(let* ((method (car (last methods)))
(ll (if (consp method)
(early-method-lambda-list method)
- (method-lambda-list method)))
- (k (member '&key ll)))
- (if k
- (append (ldiff ll (cdr k)) '(&allow-other-keys))
- 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)
(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))))))
+ (find-class method-class t ,env))))))
(defun real-ensure-gf-using-class--generic-function
(existing
(declare (ignore ignore1 ignore2 ignore3))
required-parameters))
+(define-condition specialized-lambda-list-error
+ (reference-condition simple-program-error)
+ ()
+ (:default-initargs :references (list '(:ansi-cl :section (3 4 3)))))
+
(defun parse-specialized-lambda-list
(arglist
&optional supplied-keywords (allowed-keywords '(&optional &rest &key &aux))
((eq arg '&aux)
(values nil arglist nil nil))
((memq arg lambda-list-keywords)
- ;; Now, since we try to conform to ANSI, non-standard
- ;; lambda-list-keywords should be treated as errors.
+ ;; non-standard lambda-list-keywords are errors.
(unless (memq arg specialized-lambda-list-keywords)
- (error 'simple-program-error
+ (error 'specialized-lambda-list-error
:format-control "unknown specialized-lambda-list ~
keyword ~S~%"
:format-arguments (list arg)))
;; no multiple &rest x &rest bla specifying
(when (memq arg supplied-keywords)
- (error 'simple-program-error
+ (error 'specialized-lambda-list-error
:format-control "multiple occurrence of ~
specialized-lambda-list keyword ~S~%"
:format-arguments (list arg)))
;; And no placing &key in front of &optional, either.
(unless (memq arg allowed-keywords)
- (error 'simple-program-error
+ (error 'specialized-lambda-list-error
:format-control "misplaced specialized-lambda-list ~
keyword ~S~%"
:format-arguments (list arg)))
(not (or (null (cadr lambda-list))
(memq (cadr lambda-list)
specialized-lambda-list-keywords)))))
- (error 'simple-program-error
+ (error 'specialized-lambda-list-error
:format-control
"in a specialized-lambda-list, excactly one ~
variable must follow &REST.~%"
projects / sbcl.git / blobdiff