(let ((car-option (car option)))
(case car-option
(declare
- (when (and
- (consp (cadr option))
- (member (first (cadr option))
- ;; FIXME: this list is slightly weird.
- ;; ANSI (on the DEFGENERIC page) in one
- ;; place allows only OPTIMIZE; in
- ;; another place gives this list of
- ;; disallowed declaration specifiers.
- ;; This seems to be the only place where
- ;; the FUNCTION declaration is
- ;; mentioned; TYPE seems to be missing.
- ;; Very strange. -- CSR, 2002-10-21
- '(declaration ftype function
- inline notinline special)))
- (error 'simple-program-error
- :format-control "The declaration specifier ~S ~
+ (dolist (spec (cdr option))
+ (unless (consp spec)
+ (error 'simple-program-error
+ :format-control "~@<Invalid declaration specifier in ~
+ DEFGENERIC: ~S~:@>"
+ :format-arguments (list spec)))
+ (when (member (first spec)
+ ;; FIXME: this list is slightly weird.
+ ;; ANSI (on the DEFGENERIC page) in one
+ ;; place allows only OPTIMIZE; in
+ ;; another place gives this list of
+ ;; disallowed declaration specifiers.
+ ;; This seems to be the only place where
+ ;; the FUNCTION declaration is
+ ;; mentioned; TYPE seems to be missing.
+ ;; Very strange. -- CSR, 2002-10-21
+ '(declaration ftype function
+ inline notinline special))
+ (error 'simple-program-error
+ :format-control "The declaration specifier ~S ~
is not allowed inside DEFGENERIC."
- :format-arguments (list (cadr option))))
- (push (cadr option) (initarg :declarations)))
+ :format-arguments (list spec)))
+ (if (or (eq 'optimize (first spec))
+ (info :declaration :recognized (first spec)))
+ (push spec (initarg :declarations))
+ (warn "Ignoring unrecognized declaration in DEFGENERIC: ~S"
+ spec))))
(:method-combination
(when (initarg car-option)
(duplicate-option car-option))
(compile-or-load-defgeneric ',fun-name))
(load-defgeneric ',fun-name ',lambda-list
(sb-c:source-location) ,@initargs)
- ,@(mapcar #'expand-method-definition methods)
- (fdefinition ',fun-name)))))
+ ,@(mapcar #'expand-method-definition methods)
+ (fdefinition ',fun-name)))))
(defun compile-or-load-defgeneric (fun-name)
(proclaim-as-fun-name fun-name)
applyp))
&body body
&environment env)
- (let* ((all-params (append args (when rest-arg (list rest-arg))))
- (rebindings (when (or setq-p call-next-method-p)
- (mapcar (lambda (x) (list x x)) all-params))))
+ (let* ((rebindings (when (or setq-p call-next-method-p)
+ (mapcar (lambda (x) (list x x)) parameters-setqd))))
(if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
`(locally
,@body)
(declare (optimize (sb-c:insert-step-conditions 0)))
(not (null ,next-method-call))))))
(let ,rebindings
- ,@(when rebindings `((declare (ignorable ,@all-params))))
,@body)))))
;;; CMUCL comment (Gerd Moellmann):
:format-arguments (list fun-name)))
(defvar *sgf-wrapper*
- (boot-make-wrapper (early-class-size 'standard-generic-function)
- 'standard-generic-function))
+ (!boot-make-wrapper (early-class-size 'standard-generic-function)
+ 'standard-generic-function))
(defvar *sgf-slots-init*
(mapcar (lambda (canonical-slot)
(finalize-inheritance ,gf-class)))
(remf ,all-keys :generic-function-class)
(remf ,all-keys :environment)
- (let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
- (unless (eq combin '.shes-not-there.)
- (setf (getf ,all-keys :method-combination)
- (find-method-combination (class-prototype ,gf-class)
- (car combin)
- (cdr combin)))))
+ (let ((combin (getf ,all-keys :method-combination)))
+ (etypecase combin
+ (cons
+ (setf (getf ,all-keys :method-combination)
+ (find-method-combination (class-prototype ,gf-class)
+ (car combin)
+ (cdr combin))))
+ ((or null method-combination))))
(let ((method-class (getf ,all-keys :method-class '.shes-not-there.)))
(unless (eq method-class '.shes-not-there.)
(setf (getf ,all-keys :method-class)