X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=dfa7dcc0ff169686ded9f9c26a58c1802ba439f7;hb=82e0a78df47685519b12683f495d7ae19e07d3cf;hp=5ad7908d902113a2720d5754e6cf004c8b472012;hpb=71173fc4590389c52ac0e1abd75f79e417dad361;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 5ad7908..dfa7dcc 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -270,15 +270,15 @@ bootstrapping. (class-prototype (or (generic-function-method-class gf?) (find-class 'standard-method)))))))) -;;; takes a name which is either a generic function name or a list specifying -;;; a setf generic function (like: (SETF )). Returns +;;; Take a name which is either a generic function name or a list specifying +;;; a SETF generic function (like: (SETF )). Return ;;; the prototype instance of the method-class for that generic function. ;;; -;;; If there is no generic function by that name, this returns the default -;;; value, the prototype instance of the class STANDARD-METHOD. This default -;;; value is also returned if the spec names an ordinary function or even a -;;; macro. In effect, this leaves the signalling of the appropriate error -;;; until load time. +;;; If there is no generic function by that name, this returns the +;;; default value, the prototype instance of the class +;;; STANDARD-METHOD. This default value is also returned if the spec +;;; names an ordinary function or even a macro. In effect, this leaves +;;; the signalling of the appropriate error until load time. ;;; ;;; Note: During bootstrapping, this function is allowed to return NIL. (defun method-prototype-for-gf (name) @@ -321,7 +321,7 @@ bootstrapping. initargs env))) `(progn - ;; Note: We could DECLAIM the type of the generic + ;; Note: We could DECLAIM the ftype of the generic ;; function here, since ANSI specifies that we create it ;; if it does not exist. However, I chose not to, because ;; I think it's more useful to support a style of @@ -391,7 +391,13 @@ bootstrapping. (mname `(,(if (eq (cadr initargs-form) ':function) 'method 'fast-method) ,name ,@qualifiers ,specls)) - (mname-sym (intern (let ((*print-pretty* nil)) + (mname-sym (intern (let ((*print-pretty* nil) + ;; (We bind *PACKAGE* to + ;; KEYWORD here as a way to + ;; force symbols to be printed + ;; with explicit package + ;; prefixes.) + (*package* sb-int:*keyword-package*)) (format nil "~S" mname))))) `(eval-when ,*defmethod-times* (defun ,mname-sym ,(cadr fn-lambda) @@ -428,8 +434,10 @@ bootstrapping. ,specializers-form ',unspecialized-lambda-list ,initargs-form - ;; Paper over a bug in KCL by passing the cache-symbol here in addition to - ;; in the list. FIXME: We should no longer need to do this. + ;; Paper over a bug in KCL by passing the cache-symbol here in + ;; addition to in the list. FIXME: We should no longer need to do + ;; this, since the CLOS code is now SBCL-specific, and doesn't + ;; need to be ported to every buggy compiler in existence. ',pv-table-symbol)) (defmacro make-method-function (method-lambda &environment env) @@ -464,7 +472,7 @@ bootstrapping. method-lambda initargs env) (declare (ignore proto-gf proto-method)) (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) - (error "The METHOD-LAMBDA argument to MAKE-METHOD-FUNCTION, ~S,~ + (error "The METHOD-LAMBDA argument to MAKE-METHOD-FUNCTION, ~S, ~ is not a lambda form." method-lambda)) (make-method-initargs-form-internal method-lambda initargs env)) @@ -479,7 +487,7 @@ bootstrapping. (defun make-method-lambda-internal (method-lambda &optional env) (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) - (error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S,~ + (error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~ is not a lambda form." method-lambda)) (multiple-value-bind (documentation declarations real-body) @@ -492,21 +500,16 @@ bootstrapping. (multiple-value-bind (parameters lambda-list specializers) (parse-specialized-lambda-list specialized-lambda-list) (let* ((required-parameters - (mapcar #'(lambda (r s) (declare (ignore s)) r) + (mapcar (lambda (r s) (declare (ignore s)) r) parameters specializers)) (slots (mapcar #'list required-parameters)) (calls (list nil)) - (parameters-to-reference - (make-parameter-references specialized-lambda-list - required-parameters - declarations - method-name - specializers)) (class-declarations `(declare ;; FIXME: Are these (DECLARE (SB-PCL::CLASS FOO BAR)) ;; declarations used for anything any more? + ;; WHN 2000-12-21: I think not, commented 'em out to see.. ,@(remove nil (mapcar (lambda (a s) (and (symbolp s) (neq s 't) @@ -572,18 +575,27 @@ bootstrapping. ;; appropriate class declarations. The documentation ;; string is removed to make it easy for us to insert ;; new declarations later, they will just go after the - ;; cadr of the method lambda. The class declarations + ;; CADR of the method lambda. The class declarations ;; are inserted to communicate the class of the method's ;; arguments to the code walk. `(lambda ,lambda-list + ;; The default ignorability of method parameters + ;; doesn't seem to be specified by ANSI. PCL had + ;; them basically ignorable but was a little + ;; inconsistent. E.g. even though the two + ;; method definitions + ;; (DEFMETHOD FOO ((X T) (Y T)) "Z") + ;; (DEFMETHOD FOO ((X T) Y) "Z") + ;; are otherwise equivalent, PCL treated Y as + ;; ignorable in the first definition but not in the + ;; second definition. We make all required + ;; parameters ignorable as a way of systematizing + ;; the old PCL behavior. -- WHN 2000-11-24 + (declare (ignorable ,@required-parameters)) ,class-declarations ,@declarations - (declare (ignorable ,@parameters-to-reference)) - - ;; FIXME: should become FUNCTION-NAME-BLOCK-NAME - (block ,(if (listp generic-function-name) - (cadr generic-function-name) - generic-function-name) + (block ,(sb-int:function-name-block-name + generic-function-name) ,@real-body))) (constant-value-p (and (null (cdr real-body)) (constantp (car real-body)))) @@ -982,10 +994,10 @@ bootstrapping. (if (memq var lambda-list-keywords) (progn (case var - (&optional (setq state 'optional)) + (&optional (setq state 'optional)) (&key (setq state 'key)) (&allow-other-keys) - (&rest (setq state 'rest)) + (&rest (setq state 'rest)) (&aux (setq state 'aux)) (otherwise (error @@ -1129,30 +1141,6 @@ bootstrapping. (if (eq *boot-state* 'complete) (standard-generic-function-p (gdefinition name)) (funcallable-instance-p (gdefinition name))))) - -(defun make-parameter-references (specialized-lambda-list - required-parameters - declarations - method-name - specializers) - (flet ((ignoredp (symbol) - (dolist (decl (cdar declarations)) - (when (and (eq (car decl) 'ignore) - (memq symbol (cdr decl))) - (return t))))) - (gathering ((references (collecting))) - (iterate ((s (list-elements specialized-lambda-list)) - (p (list-elements required-parameters))) - (progn p) - (cond ((not (listp s))) - ((ignoredp (car s)) - (warn "In DEFMETHOD ~S, there is a~%~ - redundant IGNORE declaration for the parameter ~S." - method-name - specializers - (car s))) - (t - (gather (car s) references))))))) (defvar *method-function-plist* (make-hash-table :test 'eq)) (defvar *mf1* nil)