Update of /cvsroot/sbcl/sbcl/src/pcl
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv10713/src/pcl
Modified Files:
boot.lisp
Log Message:
1.0.30.9: improved generic-function FTYPE handling
* Use :DEFINED-METHOD as :WHERE-FROM even if there is no explicit
DEFGENERIC -- initial type becomes FUNCTION.
* Also signal a style-warning when the FTYPE is clobbered by a
generic function -- though in this case it is more "bad SBCL style"
than bad user style... but at least the user will know that
something unexpected is going on. (Clobbering itself is not new.)
Index: boot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/boot.lisp,v
retrieving revision 1.152
retrieving revision 1.153
diff -u -d -r1.152 -r1.153
--- boot.lisp 19 Dec 2008 15:20:44 -0000 1.152
+++ boot.lisp 29 Jul 2009 14:48:51 -0000 1.153
@@ -2208,6 +2208,21 @@
method-class)
(t (find-class method-class t ,env))))))))
+(defun note-gf-signature (fun-name lambda-list-p lambda-list)
+ ;; FIXME: Ideally we would like to not clobber it, but because generic
+ ;; functions assert their FTYPEs callers believing the FTYPE are
+ ;; left with unsafe assumptions. Hence the clobbering.
+ (when (eq :declared (info :function :where-from fun-name))
+ (style-warn "~@<Generic function ~S clobbers an earlier ~S proclamation ~
+ for the same name.~:@>"
+ fun-name 'ftype))
+ (setf (info :function :type fun-name)
+ (specifier-type
+ (if lambda-list-p
+ (ftype-declaration-from-lambda-list lambda-list fun-name)
+ 'function)))
+ (setf (info :function :where-from fun-name) :defined-method))
+
(defun real-ensure-gf-using-class--generic-function
(existing
fun-name
@@ -2222,11 +2237,7 @@
(change-class existing generic-function-class))
(prog1
(apply #'reinitialize-instance existing all-keys)
- (when lambda-list-p
- (setf (info :function :type fun-name)
- (specifier-type
- (ftype-declaration-from-lambda-list lambda-list fun-name))
- (info :function :where-from fun-name) :defined-method))))
+ (note-gf-signature fun-name lambda-list-p lambda-list)))
(defun real-ensure-gf-using-class--null
(existing
@@ -2241,11 +2252,7 @@
(setf (gdefinition fun-name)
(apply #'make-instance generic-function-class
:name fun-name all-keys))
- (when lambda-list-p
- (setf (info :function :type fun-name)
- (specifier-type
- (ftype-declaration-from-lambda-list lambda-list fun-name))
- (info :function :where-from fun-name) :defined-method))))
+ (note-gf-signature fun-name lambda-list-p lambda-list)))
(defun safe-gf-arg-info (generic-function)
(if (eq (class-of generic-function) *the-class-standard-generic-function*)
|