;;; then things break.)
(declaim (declaration class))
-;;; FIXME: SB-KERNEL::PCL-CHECK-WRAPPER-VALIDITY-HOOK shouldn't be a
-;;; separate function. Instead, we should define a simple placeholder
-;;; version of SB-PCL:CHECK-WRAPPER-VALIDITY where
-;;; SB-KERNEL::PCL-CHECK-WRAPPER-VALIDITY is defined now, then just
-;;; let the later real PCL DEFUN of SB-PCL:CHECK-WRAPPER-VALIDITY
-;;; overwrite it.
-(setf (symbol-function 'sb-kernel::pcl-check-wrapper-validity-hook)
- #'check-wrapper-validity)
-
(declaim (notinline make-a-method
add-named-method
ensure-generic-function-using-class
(error 'simple-program-error
:format-control "illegal generic function name ~S"
:format-arguments (list fun-name)))
+ (check-gf-lambda-list lambda-list)
(let ((initargs ())
(methods ()))
(flet ((duplicate-option (name)
:lambda-list lambda-list
:definition-source `((defgeneric ,fun-name) ,*load-truename*)
initargs))
+
+;;; As per section 3.4.2 of the ANSI spec, generic function lambda
+;;; lists have some special limitations, which we check here.
+(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))))
+ (multiple-value-bind (required optional restp rest keyp keys allowp
+ auxp aux morep more-context more-count)
+ (parse-lambda-list lambda-list)
+ (declare (ignore required)) ; since they're no different in a gf ll
+ (declare (ignore restp rest)) ; since they're no different in a gf ll
+ (declare (ignore allowp)) ; since &ALLOW-OTHER-KEYS is fine either way
+ (declare (ignore aux)) ; since we require AUXP=NIL
+ (declare (ignore more-context more-count)) ; safely ignored unless MOREP
+ ;; no defaults allowed for &OPTIONAL arguments
+ (dolist (i optional)
+ (ensure i (or (symbolp i)
+ (and (consp i) (symbolp (car i)) (null (cdr i))))))
+ ;; no defaults allowed for &KEY arguments
+ (when keyp
+ (dolist (i keys)
+ (ensure i (or (symbolp i)
+ (and (consp i)
+ (or (symbolp (car i))
+ (and (consp (car i))
+ (symbolp (caar i))
+ (symbolp (cadar i))
+ (null (cddar i))))
+ (null (cdr i)))))))
+ ;; no &AUX allowed
+ (when auxp
+ (error "&AUX is not allowed in a generic function lambda list: ~S"
+ lambda-list))
+ ;; Oh, *puhlease*... not specifically as per section 3.4.2 of
+ ;; the ANSI spec, but the CMU CL &MORE extension does not
+ ;; belong here!
+ (aver (not morep)))))
\f
(defmacro defmethod (&rest args &environment env)
(multiple-value-bind (name qualifiers lambda-list body)
(multiple-value-bind (parameters unspecialized-lambda-list specializers)
(parse-specialized-lambda-list lambda-list)
(declare (ignore parameters))
- (multiple-value-bind (documentation declarations real-body)
- (extract-declarations body env)
+ (multiple-value-bind (real-body declarations documentation)
+ (parse-body body env)
(values `(lambda ,unspecialized-lambda-list
,@(when documentation `(,documentation))
;; (Old PCL code used a somewhat different style of
(error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~
is not a lambda form."
method-lambda))
- (multiple-value-bind (documentation declarations real-body)
- (extract-declarations (cddr method-lambda) env)
+ (multiple-value-bind (real-body declarations documentation)
+ (parse-body (cddr method-lambda) env)
(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)))
env
slots
calls)
- (multiple-value-bind
- (ignore walked-declarations walked-lambda-body)
- (extract-declarations (cddr walked-lambda))
- (declare (ignore ignore))
+ (multiple-value-bind (walked-lambda-body
+ walked-declarations
+ walked-documentation)
+ (parse-body (cddr walked-lambda) env)
+ (declare (ignore walked-documentation))
(when (or next-method-p-p call-next-method-p)
(setq plist (list* :needs-next-methods-p t plist)))
(when (some #'cdr slots)
+slot-unbound+)))))
(function
(apply emf args))))
-
-;; KLUDGE: A comment from the original PCL said "This can be improved alot."
-(defun gf-make-function-from-emf (gf emf)
- (etypecase emf
- (fast-method-call (let* ((arg-info (gf-arg-info gf))
- (nreq (arg-info-number-required arg-info))
- (restp (arg-info-applyp arg-info)))
- (lambda (&rest args)
- (trace-emf-call emf t args)
- (apply (fast-method-call-function emf)
- (fast-method-call-pv-cell emf)
- (fast-method-call-next-method-call emf)
- (if restp
- (let* ((rest-args (nthcdr nreq args))
- (req-args (ldiff args
- rest-args)))
- (nconc req-args rest-args))
- args)))))
- (method-call (lambda (&rest args)
- (trace-emf-call emf t args)
- (apply (method-call-function emf)
- args
- (method-call-call-method-args emf))))
- (function emf)))
\f
(defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call)
&body body)
,(cadr var)))))))
(rest `((,var ,args-tail)))
(key (cond ((not (consp var))
- `((,var (get-key-arg ,(keywordicate var)
- ,args-tail))))
+ `((,var (car
+ (get-key-arg-tail ,(keywordicate var)
+ ,args-tail)))))
((null (cddr var))
(multiple-value-bind (keyword variable)
(if (consp (car var))
(cadar var))
(values (keywordicate (car var))
(car var)))
- `((,key (get-key-arg1 ',keyword ,args-tail))
- (,variable (if (consp ,key)
+ `((,key (get-key-arg-tail ',keyword
+ ,args-tail))
+ (,variable (if ,key
(car ,key)
,(cadr var))))))
(t
(cadar var))
(values (keywordicate (car var))
(car var)))
- `((,key (get-key-arg1 ',keyword ,args-tail))
+ `((,key (get-key-arg-tail ',keyword
+ ,args-tail))
(,(caddr var) ,key)
- (,variable (if (consp ,key)
+ (,variable (if ,key
(car ,key)
,(cadr var))))))))
(aux `(,var))))))
(declare (ignorable ,args-tail))
,@body)))))
-(defun get-key-arg (keyword list)
- (loop (when (atom list) (return nil))
- (when (eq (car list) keyword) (return (cadr list)))
- (setq list (cddr list))))
-
-(defun get-key-arg1 (keyword list)
- (loop (when (atom list) (return nil))
- (when (eq (car list) keyword) (return (cdr list)))
- (setq list (cddr list))))
+(defun get-key-arg-tail (keyword list)
+ (loop for (key . tail) on list by #'cddr
+ when (null tail) do
+ ;; FIXME: Do we want to export this symbol? Or maybe use an
+ ;; (ERROR 'SIMPLE-PROGRAM-ERROR) form?
+ (sb-c::%odd-key-args-error)
+ when (eq key keyword)
+ return tail))
(defun walk-method-lambda (method-lambda required-parameters env slots calls)
(let ((call-next-method-p nil) ; flag indicating that CALL-NEXT-METHOD
(defun ensure-generic-function-using-class (existing spec &rest keys
&key (lambda-list nil
lambda-list-p)
+ argument-precedence-order
&allow-other-keys)
(declare (ignore keys))
(cond ((and existing (early-gf-p existing))
existing)
((assoc spec *!generic-function-fixups* :test #'equal)
(if existing
- (make-early-gf spec lambda-list lambda-list-p existing)
+ (make-early-gf spec lambda-list lambda-list-p existing
+ argument-precedence-order)
(error "The function ~S is not already defined." spec)))
(existing
(error "~S should be on the list ~S."
'*!generic-function-fixups*))
(t
(pushnew spec *!early-generic-functions* :test #'equal)
- (make-early-gf spec lambda-list lambda-list-p))))
+ (make-early-gf spec lambda-list lambda-list-p nil
+ argument-precedence-order))))
-(defun make-early-gf (spec &optional lambda-list lambda-list-p function)
+(defun make-early-gf (spec &optional lambda-list lambda-list-p
+ function argument-precedence-order)
(let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*)))
(set-funcallable-instance-fun
fin
(setf (early-gf-arg-info fin) arg-info)
(when lambda-list-p
(proclaim (defgeneric-declaration spec lambda-list))
- (set-arg-info fin :lambda-list lambda-list)))
+ (if argument-precedence-order
+ (set-arg-info fin
+ :lambda-list lambda-list
+ :argument-precedence-order argument-precedence-order)
+ (set-arg-info fin :lambda-list lambda-list))))
fin))
(defun set-dfun (gf &optional dfun cache info)
projects / sbcl.git / blobdiff