X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=b277f876504308868721f987cfc0bdc1a84a6183;hb=0e35b321b97477bcfedaa1a5aed1fa87d635d262;hp=ab5388d1d3f42fdaf5280481fe2a4bd0f3581736;hpb=22aec7852f4861e5dab28cc0d619c24b62590dad;p=sbcl.git

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index ab5388d..b277f87 100644
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -165,7 +165,7 @@ bootstrapping.
 		    (qualifiers (subseq qab 0 arglist-pos))
 		    (body (nthcdr (1+ arglist-pos) qab)))
 	       `(push (defmethod ,fun-name ,@qualifiers ,arglist ,@body)
-                      (generic-function-initial-methods #',fun-name)))))
+                      (generic-function-initial-methods (fdefinition ',fun-name))))))
       (macrolet ((initarg (key) `(getf initargs ,key)))
 	(dolist (option options)
 	  (let ((car-option (car option)))
@@ -239,7 +239,7 @@ bootstrapping.
 	   (compile-or-load-defgeneric ',fun-name))
          (load-defgeneric ',fun-name ',lambda-list ,@initargs)
         ,@(mapcar #'expand-method-definition methods)
-	 #',fun-name))))
+        (fdefinition ',fun-name)))))
 
 (defun compile-or-load-defgeneric (fun-name)
   (proclaim-as-fun-name fun-name)
@@ -263,18 +263,18 @@ bootstrapping.
          :definition-source `((defgeneric ,fun-name) ,*load-pathname*)
          initargs))
 
-;;; As per section 3.4.2 of the ANSI spec, generic function lambda
-;;; lists have some special limitations, which we check here.
+(define-condition generic-function-lambda-list-error
+    (reference-condition simple-program-error)
+  ()
+  (:default-initargs :references (list '(:ansi-cl :section (3 4 2)))))
+
 (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.)
-	      "~@<non-ANSI-conforming argument ~S ~_in the generic function lambda list ~S~:>"
-	      arg lambda-list))))
+	     (error 'generic-function-lambda-list-error
+		    :format-control
+		    "~@<invalid ~S ~_in the generic function lambda list ~S~:>"
+		    :format-arguments (list 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)
@@ -435,24 +435,16 @@ bootstrapping.
 				   specl))
 			       specializers))
 	       (mname `(,(if (eq (cadr initargs-form) :function)
-			     'method 'fast-method)
-			,name ,@qualifiers ,specls))
-	       (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* *keyword-package*))
-				    (format nil "~S" mname)))))
+			     'slow-method 'fast-method)
+			,name ,@qualifiers ,specls)))
 	  `(progn
-	     (defun ,mname-sym ,(cadr fn-lambda)
+	     (defun ,mname ,(cadr fn-lambda)
 	       ,@(cddr fn-lambda))
 	     ,(make-defmethod-form-internal
 	       name qualifiers `',specls
 	       unspecialized-lambda-list method-class-name
 	       `(list* ,(cadr initargs-form)
-		       #',mname-sym
+		       #',mname
 		       ,@(cdddr initargs-form))
 	       pv-table-symbol)))
 	(make-defmethod-form-internal
@@ -460,7 +452,7 @@ bootstrapping.
 	 `(list ,@(mapcar (lambda (specializer)
 			    (if (consp specializer)
 				``(,',(car specializer)
-				   ,,(cadr specializer))
+				      ,,(cadr specializer))
 				`',specializer))
 			  specializers))
 	 unspecialized-lambda-list
@@ -499,11 +491,11 @@ bootstrapping.
 				 env))))
 
 (defun add-method-declarations (name qualifiers lambda-list body env)
+  (declare (ignore env))
   (multiple-value-bind (parameters unspecialized-lambda-list specializers)
       (parse-specialized-lambda-list lambda-list)
-    (declare (ignore parameters))
     (multiple-value-bind (real-body declarations documentation)
-	(parse-body body env)
+	(parse-body body)
       (values `(lambda ,unspecialized-lambda-list
 		 ,@(when documentation `(,documentation))
 		 ;; (Old PCL code used a somewhat different style of
@@ -607,27 +599,52 @@ bootstrapping.
 	 ;; second argument.) Hopefully it only does this kind of
 	 ;; weirdness when bootstrapping.. -- WHN 20000610
 	 '(ignorable))
+	((var-globally-special-p parameter)
+	 ;; KLUDGE: Don't declare types for global special variables
+	 ;; -- our rebinding magic for SETQ cases don't work right
+	 ;; there.
+	 ;;
+	 ;; FIXME: It would be better to detect the SETQ earlier and
+	 ;; skip declarations for specials only when needed, not
+	 ;; always.
+	 ;;
+	 ;; --NS 2004-10-14
+	 '(ignorable))
 	(t
 	 ;; Otherwise, we can usually make Python very happy.
-	 (let ((type (info :type :kind specializer)))
-	   (ecase type
-	     ((:primitive :defined :instance :forthcoming-defclass-type)
-	      `(type ,specializer ,parameter))
-	     ((nil)
+	 (let ((kind (info :type :kind specializer)))
+	   (ecase kind
+	     ((:primitive) `(type ,specializer ,parameter))
+	     ((:defined) 
+	      (let ((class (find-class specializer nil)))
+                ;; CLASS can be null here if the user has erroneously
+                ;; tried to use a defined type as a specializer; it
+                ;; can be a non-BUILT-IN-CLASS if the user defines a
+                ;; type and calls (SETF FIND-CLASS) in a consistent
+                ;; way.
+                (when (and class (typep class 'built-in-class))
+                  `(type ,specializer ,parameter))))
+	     ((:instance nil)
 	      (let ((class (find-class specializer nil)))
-		(if class
-		    `(type ,(class-name class) ,parameter)
-		    (progn
-		      ;; we can get here, and still not have a failure
-		      ;; case, by doing MOP programming like (PROGN
-		      ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO))
-		      ;; ...)).  Best to let the user know we haven't
-		      ;; been able to extract enough information:
-		      (style-warn
-		       "~@<can't find type for presumed class ~S in ~S.~@:>"
-		       specializer
-		       'parameter-specializer-declaration-in-defmethod)
-		      '(ignorable))))))))))
+		(cond
+		  (class
+		   (if (typep class '(or built-in-class structure-class))
+		       `(type ,specializer ,parameter)
+		       ;; don't declare CLOS classes as parameters;
+		       ;; it's too expensive.
+		       '(ignorable)))
+		  (t
+		   ;; we can get here, and still not have a failure
+		   ;; case, by doing MOP programming like (PROGN
+		   ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO))
+		   ;; ...)).  Best to let the user know we haven't
+		   ;; been able to extract enough information:
+		   (style-warn
+		    "~@<can't find type for presumed class ~S in ~S.~@:>"
+		    specializer
+		    'parameter-specializer-declaration-in-defmethod)
+		   '(ignorable)))))
+	     ((:forthcoming-defclass-type) '(ignorable)))))))
 
 (defun make-method-lambda-internal (method-lambda &optional env)
   (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
@@ -635,7 +652,7 @@ bootstrapping.
 	    is not a lambda form."
 	   method-lambda))
   (multiple-value-bind (real-body declarations documentation)
-      (parse-body (cddr method-lambda) env)
+      (parse-body (cddr method-lambda))
     (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)))
@@ -669,8 +686,9 @@ bootstrapping.
 		  ;; it can avoid run-time type dispatch overhead,
 		  ;; which can be a huge win for Python.)
 		  ;;
-		  ;; FIXME: Perhaps these belong in
-		  ;; ADD-METHOD-DECLARATIONS instead of here?
+		  ;; KLUDGE: when I tried moving these to
+		  ;; ADD-METHOD-DECLARATIONS, things broke.  No idea
+		  ;; why.  -- CSR, 2004-06-16
 		  ,@(mapcar #'parameter-specializer-declaration-in-defmethod
 			    parameters
 			    specializers)))
@@ -716,7 +734,8 @@ bootstrapping.
 			       ((eq p '&aux)
 				(return nil))))))
 	  (multiple-value-bind
-	      (walked-lambda call-next-method-p closurep next-method-p-p)
+		(walked-lambda call-next-method-p closurep
+			       next-method-p-p setq-p)
 	      (walk-method-lambda method-lambda
 				  required-parameters
 				  env
@@ -725,7 +744,7 @@ bootstrapping.
 	    (multiple-value-bind (walked-lambda-body
 				  walked-declarations
 				  walked-documentation)
-		(parse-body (cddr walked-lambda) env)
+		(parse-body (cddr walked-lambda))
 	      (declare (ignore walked-documentation))
 	      (when (or next-method-p-p call-next-method-p)
 		(setq plist (list* :needs-next-methods-p t plist)))
@@ -757,6 +776,7 @@ bootstrapping.
 					:call-next-method-p
 					,call-next-method-p
 					:next-method-p-p ,next-method-p-p
+			                :setq-p ,setq-p
 			                ;; we need to pass this along
 			                ;; so that NO-NEXT-METHOD can
 			                ;; be given a suitable METHOD
@@ -819,8 +839,9 @@ bootstrapping.
 		            (or ,cnm-args ,',method-args))))
 	      (next-method-p-body ()
 	       `(not (null .next-method.)))
-	      (with-rebound-original-args ((call-next-method-p) &body body)
-		(declare (ignore call-next-method-p))
+	      (with-rebound-original-args ((call-next-method-p setq-p)
+					   &body body)
+		(declare (ignore call-next-method-p setq-p))
 		`(let () ,@body)))
     ,@body))
 
@@ -1113,8 +1134,8 @@ bootstrapping.
 					`(,rest-arg)))))))
 		(next-method-p-body ()
 		 `(not (null ,',next-method-call)))
-		(with-rebound-original-args ((cnm-p) &body body)
-		  (if cnm-p
+		(with-rebound-original-args ((cnm-p setq-p) &body body)
+		  (if (or cnm-p setq-p)
 		      `(let ,',rebindings
 			(declare (ignorable ,@',all-params))
 			,@body)
@@ -1122,11 +1143,11 @@ bootstrapping.
       ,@body)))
 
 (defmacro bind-lexical-method-functions
-    ((&key call-next-method-p next-method-p-p
+    ((&key call-next-method-p next-method-p-p setq-p
 	   closurep applyp method-name-declaration)
      &body body)
   (cond ((and (null call-next-method-p) (null next-method-p-p)
-	      (null closurep) (null applyp))
+	      (null closurep) (null applyp) (null setq-p))
 	 `(let () ,@body))
 	(t
 	 `(call-next-method-bind
@@ -1138,7 +1159,7 @@ bootstrapping.
 		   ,@(and next-method-p-p
 			  '((next-method-p ()
 			     (next-method-p-body)))))
-	      (with-rebound-original-args (,call-next-method-p)
+	      (with-rebound-original-args (,call-next-method-p ,setq-p)
 		,@body))))))
 
 (defmacro bind-args ((lambda-list args) &body body)
@@ -1230,8 +1251,9 @@ bootstrapping.
 				   ; should be in the method definition
 	(closurep nil)		   ; flag indicating that #'CALL-NEXT-METHOD
 				   ; was seen in the body of a method
-	(next-method-p-p nil))     ; flag indicating that NEXT-METHOD-P
+	(next-method-p-p nil)      ; flag indicating that NEXT-METHOD-P
 				   ; should be in the method definition
+	(setq-p nil))
     (flet ((walk-function (form context env)
 	     (cond ((not (eq context :eval)) form)
 		   ;; FIXME: Jumping to a conclusion from the way it's used
@@ -1246,6 +1268,17 @@ bootstrapping.
 		   ((eq (car form) 'next-method-p)
 		    (setq next-method-p-p t)
 		    form)
+		   ((memq (car form) '(setq multiple-value-setq))
+		    ;; FIXME: this is possibly a little strong as
+		    ;; conditions go.  Ideally we would want to detect
+		    ;; which, if any, of the method parameters are
+		    ;; being set, and communicate that information to
+		    ;; e.g. SPLIT-DECLARATIONS.  However, the brute
+		    ;; force method doesn't really cost much; a little
+		    ;; loss of discrimination over IGNORED variables
+		    ;; should be all.  -- CSR, 2004-07-01
+		    (setq setq-p t)
+		    form)
 		   ((and (eq (car form) 'function)
 			 (cond ((eq (cadr form) 'call-next-method)
 				(setq call-next-method-p t)
@@ -1282,7 +1315,8 @@ bootstrapping.
 	(values walked-lambda
 		call-next-method-p
 		closurep
-		next-method-p-p)))))
+		next-method-p-p
+		setq-p)))))
 
 (defun generic-function-name-p (name)
   (and (legal-fun-name-p name)
@@ -1362,6 +1396,7 @@ bootstrapping.
 	     (fboundp gf-spec))
     (let* ((gf (fdefinition gf-spec))
 	   (method (and (generic-function-p gf)
+                        (generic-function-methods gf)
 			(find-method gf
 				     qualifiers
                                      (parse-specializers specializers)
@@ -1390,7 +1425,7 @@ bootstrapping.
     method))
 
 (defun make-method-spec (gf-spec qualifiers unparsed-specializers)
-  `(method ,gf-spec ,@qualifiers ,unparsed-specializers))
+  `(slow-method ,gf-spec ,@qualifiers ,unparsed-specializers))
 
 (defun initialize-method-function (initargs &optional return-function-p method)
   (let* ((mf (getf initargs :function))
@@ -1408,20 +1443,7 @@ bootstrapping.
 	(when mf
 	  (setq mf (set-fun-name mf method-spec)))
 	(when mff
-	  (let ((name `(,(or (get (car method-spec) 'fast-sym)
-			     (setf (get (car method-spec) 'fast-sym)
-				   ;; KLUDGE: If we're going to be
-				   ;; interning private symbols in our
-				   ;; a this way, it would be cleanest
-				   ;; to use a separate package
-				   ;; %PCL-PRIVATE or something, and
-				   ;; failing that, to use a special
-				   ;; symbol prefix denoting privateness.
-				   ;; -- WHN 19991201
-				   (intern (format nil "FAST-~A"
-						   (car method-spec))
-					   *pcl-package*)))
-			 ,@(cdr method-spec))))
+	  (let ((name `(fast-method ,@(cdr method-spec))))
 	    (set-fun-name mff name)
 	    (unless mf
 	      (set-mf-property :name name)))))
@@ -1522,8 +1544,6 @@ bootstrapping.
 		 *))))
 
 (defun defgeneric-declaration (spec lambda-list)
-  (when (consp spec)
-    (setq spec (get-setf-fun-name (cadr spec))))
   `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec))
 
 ;;;; early generic function support
@@ -1628,6 +1648,12 @@ bootstrapping.
        (unless (equal ,pos ,valsym)
 	 (setf ,pos ,valsym)))))
 
+(defun create-gf-lambda-list (lambda-list)
+  ;;; Create a gf lambda list from a method lambda list
+  (loop for x in lambda-list
+        collect (if (consp x) (list (car x)) x)
+        if (eq x '&key) do (loop-finish)))
+
 (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p)
 			argument-precedence-order)
   (let* ((arg-info (if (eq *boot-state* 'complete)
@@ -1655,8 +1681,10 @@ bootstrapping.
 	      (error "The lambda-list ~S is incompatible with ~
 		     existing methods of ~S."
 		     lambda-list gf))))
-	(when lambda-list-p
-	  (esetf (arg-info-lambda-list arg-info) lambda-list))
+        (esetf (arg-info-lambda-list arg-info)
+               (if lambda-list-p
+                   lambda-list
+                   (create-gf-lambda-list lambda-list)))
 	(when (or lambda-list-p argument-precedence-order
 		  (null (arg-info-precedence arg-info)))
 	  (esetf (arg-info-precedence arg-info)
@@ -1806,6 +1834,8 @@ bootstrapping.
 					    &allow-other-keys)
   (declare (ignore keys))
   (cond ((and existing (early-gf-p existing))
+	 (when lambda-list-p
+	   (set-arg-info existing :lambda-list lambda-list))
 	 existing)
 	((assoc spec *!generic-function-fixups* :test #'equal)
 	 (if existing
@@ -1902,11 +1932,8 @@ bootstrapping.
 	      (let* ((method (car (last methods)))
 		     (ll (if (consp method)
 			     (early-method-lambda-list method)
-			     (method-lambda-list method)))
-		     (k (member '&key ll)))
-		(if k
-		    (append (ldiff ll (cdr k)) '(&allow-other-keys))
-		    ll))))
+			     (method-lambda-list method))))
+                (create-gf-lambda-list ll))))
 	(arg-info-lambda-list arg-info))))
 
 (defmacro real-ensure-gf-internal (gf-class all-keys env)
@@ -1929,7 +1956,7 @@ bootstrapping.
     (let ((method-class (getf ,all-keys :method-class '.shes-not-there.)))
       (unless (eq method-class '.shes-not-there.)
         (setf (getf ,all-keys :method-class)
-                (find-class method-class t ,env))))))
+	      (find-class method-class t ,env))))))
 
 (defun real-ensure-gf-using-class--generic-function
        (existing
@@ -2277,11 +2304,10 @@ bootstrapping.
 	      gf (method-generic-function method)
 	      temp (and gf (generic-function-name gf))
 	      name (if temp
-		       (intern-fun-name
-			 (make-method-spec temp
-					   (method-qualifiers method)
-					   (unparse-specializers
-					     (method-specializers method))))
+                       (make-method-spec temp
+                                         (method-qualifiers method)
+                                         (unparse-specializers
+                                          (method-specializers method)))
 		       (make-symbol (format nil "~S" method))))
 	(multiple-value-bind (gf-spec quals specls)
 	    (parse-defmethod spec)
@@ -2295,9 +2321,8 @@ bootstrapping.
 		 (and
 		   (setq method (get-method gf quals specls errorp))
 		   (setq name
-			 (intern-fun-name (make-method-spec gf-spec
-							    quals
-							    specls))))))))
+                         (make-method-spec
+                          gf-spec quals (unparse-specializers specls))))))))
     (values gf method name)))
 
 (defun extract-parameters (specialized-lambda-list)
@@ -2324,6 +2349,11 @@ bootstrapping.
     (declare (ignore ignore1 ignore2 ignore3))
     required-parameters))
 
+(define-condition specialized-lambda-list-error
+    (reference-condition simple-program-error)
+  ()
+  (:default-initargs :references (list '(:ansi-cl :section (3 4 3)))))
+
 (defun parse-specialized-lambda-list
     (arglist
      &optional supplied-keywords (allowed-keywords '(&optional &rest &key &aux))
@@ -2334,22 +2364,21 @@ bootstrapping.
 	  ((eq arg '&aux)
 	   (values nil arglist nil nil))
 	  ((memq arg lambda-list-keywords)
-	   ;; Now, since we try to conform to ANSI, non-standard
-	   ;; lambda-list-keywords should be treated as errors.
+	   ;; non-standard lambda-list-keywords are errors.
 	   (unless (memq arg specialized-lambda-list-keywords)
-	     (error 'simple-program-error
+	     (error 'specialized-lambda-list-error
 		    :format-control "unknown specialized-lambda-list ~
                                      keyword ~S~%"
 		    :format-arguments (list arg)))
 	   ;; no multiple &rest x &rest bla specifying
 	   (when (memq arg supplied-keywords)
-	     (error 'simple-program-error
+	     (error 'specialized-lambda-list-error
 		    :format-control "multiple occurrence of ~
                                      specialized-lambda-list keyword ~S~%"
 		    :format-arguments (list arg)))
 	   ;; And no placing &key in front of &optional, either.
 	   (unless (memq arg allowed-keywords)
-	     (error 'simple-program-error
+	     (error 'specialized-lambda-list-error
 		    :format-control "misplaced specialized-lambda-list ~
                                      keyword ~S~%"
 		    :format-arguments (list arg)))
@@ -2372,7 +2401,7 @@ bootstrapping.
 			    (not (or (null (cadr lambda-list))
 				     (memq (cadr lambda-list)
 					   specialized-lambda-list-keywords)))))
-	       (error 'simple-program-error
+	       (error 'specialized-lambda-list-error
 		      :format-control
 		      "in a specialized-lambda-list, excactly one ~
                        variable must follow &REST.~%"