X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=b9633df0548cca49ae2e3095401809fc5be41912;hb=c9d46bcb70ff719911bb1121493501ade1f54ca9;hp=f8df4fd31dd93a4064f35c147da709cf210db665;hpb=a8f0175b16a00f5fc83eb8d8a718ae7fc5497514;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index f8df4fd..b9633df 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -90,7 +90,6 @@ bootstrapping. (declaim (notinline make-a-method add-named-method ensure-generic-function-using-class - add-method remove-method)) @@ -162,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) @@ -232,6 +232,29 @@ 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 a number of limitations, which we check here. +(defun check-gf-lambda-list (lambda-list) + (macrolet ((ensure (condition) + `(unless ,condition + (error "Invalid argument ~S in the generic function lambda list ~S." + it lambda-list)))) + (process-lambda-list lambda-list + (&required (ensure (symbolp it))) + (&optional (ensure (or (symbolp it) + (and (consp it) (symbolp (car it)) (null (cdr it)))))) + (&rest (ensure (symbolp it))) + (&key (ensure (or (symbolp it) + (and (consp it) + (or (symbolp (car it)) + (and (consp (car it)) + (symbolp (caar it)) + (symbolp (cadar it)) + (null (cddar it)))) + (null (cdr it)))))) + ((&aux (error "&AUX is not allowed in the generic function lambda list ~S." + lambda-list)))))) (defmacro defmethod (&rest args &environment env) (multiple-value-bind (name qualifiers lambda-list body) @@ -703,10 +726,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) @@ -771,11 +794,8 @@ bootstrapping. #-sb-fluid (declaim (sb-ext:freeze-type fast-instance-boundp)) (eval-when (:compile-toplevel :load-toplevel :execute) - -(defvar *allow-emf-call-tracing-p* nil) -(defvar *enable-emf-call-tracing-p* #-testing nil #+testing t) - -) ; EVAL-WHEN + (defvar *allow-emf-call-tracing-p* nil) + (defvar *enable-emf-call-tracing-p* #-sb-show nil #+sb-show t)) ;;;; effective method functions @@ -825,26 +845,25 @@ bootstrapping. &rest required-args+rest-arg) (unless (constantp restp) (error "The RESTP argument is not constant.")) + ;; FIXME: The RESTP handling here is confusing and maybe slightly + ;; broken if RESTP evaluates to a non-self-evaluating form. E.g. if + ;; (INVOKE-EFFECTIVE-METHOD-FUNCTION EMF '(ERROR "gotcha") ...) + ;; then TRACE-EMF-CALL-CALL-INTERNAL might die on a gotcha error. (setq restp (eval restp)) - `(locally - - ;; In sbcl-0.6.11.43, the compiler would issue bogus warnings - ;; about type mismatches in unreachable code when we - ;; macroexpanded the GET-SLOTS-OR-NIL expressions here and - ;; byte-compiled the code. GET-SLOTS-OR-NIL is now an inline - ;; function instead of a macro, which seems sufficient to solve - ;; the problem all by itself (probably because of some quirk in - ;; the relative order of expansion and type inference) but we - ;; also use overkill by NOTINLINEing GET-SLOTS-OR-NIL, because it - ;; looks as though (1) inlining isn't that much of a win anyway, - ;; and (2a) once you miss the FAST-METHOD-CALL clause you're - ;; going to be slow anyway, but (2b) code bloat still hurts even - ;; when it's off the critical path. - (declare (notinline get-slots-or-nil)) - + `(progn (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) (cond ((typep ,emf 'fast-method-call) - (invoke-fast-method-call ,emf ,@required-args+rest-arg)) + (invoke-fast-method-call ,emf ,@required-args+rest-arg)) + ;; "What," you may wonder, "do these next two clauses do?" + ;; In that case, you are not a PCL implementor, for they + ;; considered this to be self-documenting.:-| Or CSR, for + ;; that matter, since he can also figure it out by looking + ;; at it without breaking stride. For the rest of us, + ;; though: From what the code is doing with .SLOTS. and + ;; whatnot, evidently it's implementing SLOT-VALUEish and + ;; GET-SLOT-VALUEish things. Then we can reason backwards + ;; and conclude that setting EMF to a FIXNUM is an + ;; optimized way to represent these slot access operations. ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) `(((typep ,emf 'fixnum) (let* ((.slots. (get-slots-or-nil @@ -859,18 +878,12 @@ bootstrapping. (let ((.new-value. ,(car required-args+rest-arg)) (.slots. (get-slots-or-nil ,(car required-args+rest-arg)))) - (when .slots. - (setf (clos-slots-ref .slots. ,emf) .new-value.)))))) - #|| - ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) - `(((typep ,emf 'fast-instance-boundp) - (let ((.slots. (get-slots-or-nil - ,(car required-args+rest-arg)))) - (and .slots. - (not (eq (clos-slots-ref - .slots. (fast-instance-boundp-index ,emf)) - +slot-unbound+))))))) - ||# + (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+ + ;; years stale, I simply deleted it. -- WHN) (t (etypecase ,emf (method-call @@ -964,7 +977,32 @@ bootstrapping. (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 @@ -979,17 +1017,18 @@ 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))))) `(if ,cnm-args (bind-args ((,@',args ,@',(when rest-arg - `(&rest ,rest-arg))) + `(&rest ,rest-arg))) ,cnm-args) ,call) ,call))))