X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=32848970d1fa5ccde6ad71d8f7403dcb62ebdb17;hb=ba38798a5ca26b90647a1993f348806cb32f2d1b;hp=f385fb5050782dc21d133ffd911d01338d068b92;hpb=ed7ba4dad8a79726fdfeba5aa12e276ea852c540;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index f385fb5..3284897 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)) @@ -935,31 +964,38 @@ bootstrapping. (defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call) &body body) `(macrolet ((call-next-method-bind (&body body) - `(let () ,@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 + ,',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"))) (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 +1109,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 +1229,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 +1239,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 +1276,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 +1325,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 +1356,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 +1525,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 +1758,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)))) @@ -1794,7 +1830,7 @@ bootstrapping. (when lambda-list-p (proclaim (defgeneric-declaration fun-name lambda-list))))) -(defun get-generic-function-info (gf) +(defun get-generic-fun-info (gf) ;; values nreq applyp metatypes nkeys arg-info (multiple-value-bind (applyp metatypes arg-info) (let* ((arg-info (if (early-gf-p gf) @@ -1830,8 +1866,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