X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=6f4177c6045ad1449db1fb609f276c779f645e7e;hb=550e5afc7ad95ff1e1bbfe932bf8dd81b0c4dce6;hp=4c4de8d70a2fa962bde5fb511377fd267bef4502;hpb=29a9ccc860532b32c566aec095f570e999a9c52c;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 4c4de8d..6f4177c 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)) @@ -157,6 +156,11 @@ bootstrapping. standard-compute-effective-method)))) (defmacro defgeneric (fun-name lambda-list &body options) + (declare (type list lambda-list)) + (unless (legal-fun-name-p fun-name) + (error 'simple-program-error + :format-control "illegal generic function name ~S" + :format-arguments (list fun-name))) (let ((initargs ()) (methods ())) (flet ((duplicate-option (name) @@ -168,7 +172,8 @@ bootstrapping. (arglist (elt qab arglist-pos)) (qualifiers (subseq qab 0 arglist-pos)) (body (nthcdr (1+ arglist-pos) qab))) - `(defmethod ,fun-name ,@qualifiers ,arglist ,@body)))) + `(push (defmethod ,fun-name ,@qualifiers ,arglist ,@body) + (generic-function-initial-methods #',fun-name))))) (macrolet ((initarg (key) `(getf initargs ,key))) (dolist (option options) (let ((car-option (car option))) @@ -202,8 +207,8 @@ bootstrapping. (eval-when (:compile-toplevel :load-toplevel :execute) (compile-or-load-defgeneric ',fun-name)) (load-defgeneric ',fun-name ',lambda-list ,@initargs) - ,@(mapcar #'expand-method-definition methods) - `,(function ,fun-name))))) + ,@(mapcar #'expand-method-definition methods) + #',fun-name)))) (defun compile-or-load-defgeneric (fun-name) (sb-kernel:proclaim-as-fun-name fun-name) @@ -215,12 +220,17 @@ bootstrapping. (defun load-defgeneric (fun-name lambda-list &rest initargs) (when (fboundp fun-name) - (sb-kernel::style-warn "redefining ~S in DEFGENERIC" fun-name)) + (sb-kernel::style-warn "redefining ~S in DEFGENERIC" fun-name) + (let ((fun (fdefinition fun-name))) + (when (generic-function-p fun) + (loop for method in (generic-function-initial-methods fun) + do (remove-method fun method)) + (setf (generic-function-initial-methods fun) '())))) (apply #'ensure-generic-function - fun-name - :lambda-list lambda-list - :definition-source `((defgeneric ,fun-name) ,*load-truename*) - initargs)) + fun-name + :lambda-list lambda-list + :definition-source `((defgeneric ,fun-name) ,*load-truename*) + initargs)) (defmacro defmethod (&rest args &environment env) (multiple-value-bind (name qualifiers lambda-list body) @@ -328,8 +338,8 @@ bootstrapping. (class-name (class-of proto-method)) 'standard-method) initargs-form - (getf (getf initargs ':plist) - ':pv-table-symbol)))))))) + (getf (getf initargs :plist) + :pv-table-symbol)))))))) (defun interned-symbol-p (x) (and (symbolp x) (symbol-package x))) @@ -364,7 +374,7 @@ bootstrapping. `(,(car specl) ,(eval (cadr specl))) specl)) specializers)) - (mname `(,(if (eq (cadr initargs-form) ':function) + (mname `(,(if (eq (cadr initargs-form) :function) 'method 'fast-method) ,name ,@qualifiers ,specls)) (mname-sym (intern (let ((*print-pretty* nil) @@ -393,7 +403,8 @@ bootstrapping. ,,(cadr specializer)) `',specializer)) specializers)) - unspecialized-lambda-list method-class-name + unspecialized-lambda-list + method-class-name initargs-form pv-table-symbol)))) @@ -435,7 +446,24 @@ bootstrapping. (extract-declarations body env) (values `(lambda ,unspecialized-lambda-list ,@(when documentation `(,documentation)) - (declare (%method-name ,(list name qualifiers specializers))) + ;; (Old PCL code used a somewhat different style of + ;; list for %METHOD-NAME values. Our names use + ;; ,@QUALIFIERS instead of ,QUALIFIERS so that the + ;; method names look more like what you see in a + ;; DEFMETHOD form.) + ;; + ;; FIXME: As of sbcl-0.7.0.6, code elsewhere, at + ;; least the code to set up named BLOCKs around the + ;; bodies of methods, depends on the function's base + ;; name being the first element of the %METHOD-NAME + ;; list. It would be good to remove this dependency, + ;; perhaps by building the BLOCK here, or by using + ;; another declaration (e.g. %BLOCK-NAME), so that + ;; our method debug names are free to have any format, + ;; e.g. (:METHOD PRINT-OBJECT :AROUND (CLOWN T)). + (declare (%method-name (,name + ,@qualifiers + ,specializers))) (declare (%method-lambda-list ,@lambda-list)) ,@declarations ,@real-body) @@ -444,7 +472,8 @@ bootstrapping. (defun real-make-method-initargs-form (proto-gf proto-method method-lambda initargs env) (declare (ignore proto-gf proto-method)) - (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) + (unless (and (consp method-lambda) + (eq (car method-lambda) 'lambda)) (error "The METHOD-LAMBDA argument to MAKE-METHOD-FUNCTION, ~S, ~ is not a lambda form." method-lambda)) @@ -673,10 +702,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) @@ -741,11 +770,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 @@ -795,26 +821,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 @@ -829,18 +854,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 @@ -934,32 +953,65 @@ bootstrapping. (defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call) &body body) - `(macrolet ((call-next-method-bind (&body body) - `(let () ,@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 - ,(if (and (null ',rest-arg) - (consp cnm-args) - (eq (car cnm-args) 'list)) - `(invoke-effective-method-function - ,',next-method-call nil - ,@(cdr cnm-args)) - (let ((call `(invoke-effective-method-function - ,',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))) - ,cnm-args) - ,call) - ,call))) - (error "no next method"))) + `(if ,',next-method-call + ,(locally + ;; This declaration suppresses a "deleting + ;; unreachable code" note for the following IF when + ;; REST-ARG is NIL. It is not nice for debugging + ;; SBCL itself, but at least it keeps us from + ;; annoying users. + (declare (optimize (inhibit-warnings 3))) + (if (and (null ',rest-arg) + (consp cnm-args) + (eq (car cnm-args) 'list)) + `(invoke-effective-method-function + (narrowed-emf ,',next-method-call) + nil + ,@(cdr cnm-args)) + (let ((call `(invoke-effective-method-function + (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))) + ,cnm-args) + ,call) + ,call)))) + (error "no next method"))) (next-method-p-body () - `(not (null ,',next-method-call)))) - ,@body)) + `(not (null ,',next-method-call)))) + ,@body)) (defmacro bind-lexical-method-functions ((&key call-next-method-p next-method-p-p closurep applyp) @@ -1073,7 +1125,7 @@ bootstrapping. (next-method-p-p nil)) ; flag indicating that NEXT-METHOD-P ; should be in the method definition (flet ((walk-function (form context env) - (cond ((not (eq context ':eval)) form) + (cond ((not (eq context :eval)) form) ;; FIXME: Jumping to a conclusion from the way it's used ;; above, perhaps CONTEXT should be called SITUATION ;; (after the term used in the ANSI specification of @@ -1193,9 +1245,9 @@ bootstrapping. (defun load-defmethod (class name quals specls ll initargs &optional pv-table-symbol) (setq initargs (copy-tree initargs)) - (let ((method-spec (or (getf initargs ':method-spec) + (let ((method-spec (or (getf initargs :method-spec) (make-method-spec name quals specls)))) - (setf (getf initargs ':method-spec) method-spec) + (setf (getf initargs :method-spec) method-spec) (load-defmethod-internal class name quals specls ll initargs pv-table-symbol))) @@ -1203,7 +1255,7 @@ bootstrapping. (method-class gf-spec qualifiers specializers lambda-list initargs pv-table-symbol) (when pv-table-symbol - (setf (getf (getf initargs ':plist) :pv-table-symbol) + (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)) (when (and (eq *boot-state* 'complete) (fboundp gf-spec)) @@ -1240,12 +1292,12 @@ bootstrapping. `(method ,gf-spec ,@qualifiers ,unparsed-specializers)) (defun initialize-method-function (initargs &optional return-function-p method) - (let* ((mf (getf initargs ':function)) - (method-spec (getf initargs ':method-spec)) - (plist (getf initargs ':plist)) - (pv-table-symbol (getf plist ':pv-table-symbol)) + (let* ((mf (getf initargs :function)) + (method-spec (getf initargs :method-spec)) + (plist (getf initargs :plist)) + (pv-table-symbol (getf plist :pv-table-symbol)) (pv-table nil) - (mff (getf initargs ':fast-function))) + (mff (getf initargs :fast-function))) (flet ((set-mf-property (p v) (when mf (setf (method-function-get mf p) v)) @@ -1289,7 +1341,7 @@ bootstrapping. (defun analyze-lambda-list (lambda-list) (flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG? - (parse-key-argument (arg) + (parse-key-arg (arg) (if (listp arg) (if (listp (car arg)) (caar arg) @@ -1320,7 +1372,7 @@ bootstrapping. (ecase state (required (incf nrequired)) (optional (incf noptional)) - (key (push (parse-key-argument x) keywords) + (key (push (parse-key-arg x) keywords) (push x keyword-parameters)) (rest (incf nrest))))) (when (and restp (zerop nrest)) @@ -1489,7 +1541,7 @@ bootstrapping. (setq lambda-list (gf-lambda-list gf))) (when (or lambda-list-p (and first-p - (eq (arg-info-lambda-list arg-info) ':no-lambda-list))) + (eq (arg-info-lambda-list arg-info) :no-lambda-list))) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) (analyze-lambda-list lambda-list) (when (and methods (not first-p)) @@ -1722,7 +1774,7 @@ bootstrapping. (let ((arg-info (if (eq *boot-state* 'complete) (gf-arg-info gf) (early-gf-arg-info gf)))) - (if (eq ':no-lambda-list (arg-info-lambda-list arg-info)) + (if (eq :no-lambda-list (arg-info-lambda-list arg-info)) (let ((methods (if (eq *boot-state* 'complete) (generic-function-methods gf) (early-gf-methods gf)))) @@ -1830,8 +1882,8 @@ bootstrapping. parsed ())) (list :early-method ;This is an early method dammit! - (getf initargs ':function) - (getf initargs ':fast-function) + (getf initargs :function) + (getf initargs :fast-function) parsed ;The parsed specializers. This is used ;by early-method-specializers to cache