Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv30982/src/pcl
22.214.171.124: better handling of derived function types
Fixes bug 657499, and improves the earlier fix of 655126.
* Sort out TYPE vs. DEFINED-TYPE in FIND-GLOBAL-FUN:
** TYPE is the declarared type, OR the derived type iff
*derive-function-types* is true, no ftype has been declared,
we're not explicitly late-binding, and the function is not
** DEFINED-TYPE is the derived type, or FUNCTION if the function has
been declared NOTINLINE or we're late-binding.
Previously TYPE (which is what the rest of the system trusts
implcitly) was the derived type for functions in the same file
not declared NOTINLINE.
* ASSERT-CALL-TYPE can now be used in "untrusted" cases as well:
argument types are asserted as before, but instead of using
DERIVE-NODE-TYPE to annotate the function LVAR with its type, we
instead assert the return-type when appropriate.
* VALIDATE-CALL-TYPE is now called with DEFINED-TYPE from
IR1-CONVERT-COMBINATION-CHECKING-TYPE: the DEFINED-TYPE may be used
there in an untrusted call to ASSERT-CALL-TYPE.
Also keep track of the leaves whose DEFINED-TYPE we have asserted,
so that we won't do duplicate work. New slot in COMBINATION:
TYPE-VALIDATED-FOR-LEAF is utilized for this.
* LEAF-WHERE-FROM can now also be :DEFINED-HERE, meaning the
definition originates in the file being compiled -- this
information is used by VALIDATE-CALL-TYPE, and filled in by
FIND-FREE-FUN and FIND-GLOBAL-FUN.
* Adjust the tests for 655126 to account for full warnings
in case *derive-function-types* and self-calls.
RCS file: /cvsroot/sbcl/sbcl/src/pcl/methods.lisp,v
retrieving revision 1.93
retrieving revision 1.94
diff -u -d -r1.93 -r1.94
--- methods.lisp 30 Jul 2010 21:01:13 -0000 1.93
+++ methods.lisp 14 Oct 2010 16:32:52 -0000 1.94
@@ -616,11 +616,11 @@
;; 7.6.4 point 5 probably entails that if any method says
;; &allow-other-keys then the gf should be construed to
;; accept any key.
- (let ((allowp (or gf.allowp
- (find '&allow-other-keys methods
- :test #'find
- :key #'method-lambda-list))))
- (setf (info :function :type name)
+ (let* ((allowp (or gf.allowp
+ (find '&allow-other-keys methods
+ :test #'find
+ :key #'method-lambda-list)))
(,@(mapcar tfun gf.required)
@@ -644,10 +644,11 @@
+ (setf (info :function :type name) ftype
(info :function :where-from name) :defined-method
- (gf-info-needs-update gf) nil))))))
+ (gf-info-needs-update gf) nil)
(defun compute-applicable-methods-function (generic-function arguments)