X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=1c9b4fee10c31ab2d3f32da9c9baedaca249c70e;hb=ef11b09c41b1e344212f6a363892a849af7ff94e;hp=65433a115ea6306d80cb524fad2e51ce832a0dc0;hpb=625946563072d5b9fb7e9bde905f8cbed219a329;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 65433a1..1c9b4fe 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -161,6 +161,7 @@ bootstrapping. (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) @@ -231,6 +232,50 @@ bootstrapping. :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.) + "~@" + 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))))) (defmacro defmethod (&rest args &environment env) (multiple-value-bind (name qualifiers lambda-list body) @@ -442,8 +487,8 @@ bootstrapping. (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 @@ -549,8 +594,8 @@ bootstrapping. (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))) @@ -637,10 +682,11 @@ bootstrapping. 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) @@ -702,10 +748,10 @@ bootstrapping. rest-arg &rest lmf-options) &body body) - `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call) - (bind-lexical-method-functions (,@lmf-options) - (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg) - ,@body)))) + `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call) + (bind-lexical-method-functions (,@lmf-options) + (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg) + ,@body)))) (defmacro bind-simple-lexical-method-macros ((method-args next-methods) &body body) @@ -817,11 +863,6 @@ bootstrapping. (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) (invoke-fast-method-call ,emf ,@required-args+rest-arg))) -;;; KLUDGE: an opaque-to-the-compiler IDENTITY function to hide code -;;; from the too-easily-bewildered compiler type checker -(defun trust-me-i-know-what-i-am-doing (x) - x) - (defmacro invoke-effective-method-function (emf restp &rest required-args+rest-arg) (unless (constantp restp) @@ -859,27 +900,8 @@ bootstrapping. (let ((.new-value. ,(car required-args+rest-arg)) (.slots. (get-slots-or-nil ,(car required-args+rest-arg)))) - ;; KLUDGE: As of sbcl-0.7.4.20 or so, there's not - ;; enough information available either at - ;; macroexpansion time or at compile time to - ;; exclude the possibility that a two-argument - ;; CALL-NEXT-METHOD might be a FIXNUM-encoded slot - ;; writer, and when the compiler sees into this - ;; macroexpansion, it can tell that the type - ;; of this clause -- just in case of being - ;; a slot writer -- doesn't match the type - ;; needed for CALL-NEXT-METHOD, and complain. - ;; (E.g. in - ;; (defmethod get-price ((obj1 a) (obj2 c)) - ;; (* 3 (call-next-method))) - ;; in the original bug report from Stig Erik - ;; Sandoe. As a quick hack to make the bogus - ;; warning go away we use this - ;; opaque-to-the-compiler IDENTITY operation to - ;; hide any possible type mismatch.) - (trust-me-i-know-what-i-am-doing - (when .slots. - (setf (clos-slots-ref .slots. ,emf) .new-value.))))))) + (when .slots. + (setf (clos-slots-ref .slots. ,emf) .new-value.)))))) ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN ;; ...) clause here to handle SLOT-BOUNDish stuff. Since ;; there was no explanation and presumably the code is 10+ @@ -950,34 +972,35 @@ bootstrapping. +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))) (defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call) &body body) - `(macrolet ((call-next-method-bind (&body body) + `(macrolet ((narrowed-emf (emf) + ;; INVOKE-EFFECTIVE-METHOD-FUNCTION has code in it to + ;; dispatch on the possibility that EMF might be of + ;; type FIXNUM (as an optimized representation of a + ;; slot accessor). But as far as I (WHN 2002-06-11) + ;; can tell, it's impossible for such a representation + ;; to end up as .NEXT-METHOD-CALL. By reassuring + ;; INVOKE-E-M-F that when called from this context + ;; it needn't worry about the FIXNUM case, we can + ;; keep those cases from being compiled, which is + ;; good both because it saves bytes and because it + ;; avoids annoying type mismatch compiler warnings. + ;; + ;; KLUDGE: In sbcl-0.7.4.29, the compiler's type + ;; system isn't smart enough about NOT and intersection + ;; types to benefit from a (NOT FIXNUM) declaration + ;; here. -- WHN 2002-06-12 + ;; + ;; FIXME: Might the FUNCTION type be omittable here, + ;; leaving only METHOD-CALLs? Failing that, could this + ;; be documented somehow? (It'd be nice if the types + ;; involved could be understood without solving the + ;; halting problem.) + `(the (or function method-call fast-method-call) + ,emf)) + (call-next-method-bind (&body body) `(let () ,@body)) (call-next-method-body (cnm-args) `(if ,',next-method-call @@ -992,10 +1015,11 @@ bootstrapping. (consp cnm-args) (eq (car cnm-args) 'list)) `(invoke-effective-method-function - ,',next-method-call nil + (narrowed-emf ,',next-method-call) + nil ,@(cdr cnm-args)) (let ((call `(invoke-effective-method-function - ,',next-method-call + (narrowed-emf ,',next-method-call) ,',(not (null rest-arg)) ,@',args ,@',(when rest-arg `(,rest-arg)))))