From: Christophe R. <cr...@us...> - 2003-02-15 11:16:37
|
Update of /cvsroot/sbcl/sbcl/src/compiler In directory sc8-pr-cvs1:/tmp/cvs-serv13913/src/compiler Modified Files: ir1-translators.lisp ir2tran.lisp Log Message: 0.7.12.38: PCL accessors/SLOT-MISSING fixes: Remove some package fragility of generated accessor functions ... define a new generalized function name class: SB-PCL::SLOT-ACCESSOR ... s/SLOT-READER-SYMBOL/SLOT-READER-NAME/, and use the new generalized function names ... now SB-SLOT-ACCESSOR-NAME and *SLOT-ACCESSOR-NAME-PACKAGE* can go away Ensure that SLOT-MISSING is called in all required situations. The easy way would just have been to adjust ASV-FUNCALL slightly, but that would have been no fun, so include an optimization due to Gerd Moellmann: ... new LOAD-TIME-VALUE logic that ensures that the relevant accessor name is always FBOUNDP, so the FBOUNDP check can be elided at runtime By this stage, it's all working, but ... while we're at it, also include the ASV-FUNCALL-as-was/ENSURE-ACCESSOR optimization for SLOT-BOUNDP, which was not included in historical PCL. ... also, ensure that fast discriminating functions are constructed, conditional on *OPTIMIZE-CACHE-FUNCTIONS-P*: eventually, this can probably be made either unconditional or conditional on the compilation policy when a generic function is compiled. Include a simple test for SLOT-MISSING behaviour. ... this version has also been tested against Gerd Moellmann's test suite, with no regressions found. Index: ir1-translators.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1-translators.lisp,v retrieving revision 1.40 retrieving revision 1.41 diff -u -d -r1.40 -r1.41 --- ir1-translators.lisp 31 Jan 2003 09:28:35 -0000 1.40 +++ ir1-translators.lisp 15 Feb 2003 11:16:34 -0000 1.41 @@ -444,7 +444,7 @@ thing :debug-name (debug-namify "#'~S" thing) :allow-debug-catch-tag t))) - ((setf sb!pcl::class-predicate) + ((setf sb!pcl::class-predicate sb!pcl::slot-accessor) (let ((var (find-lexically-apparent-fun thing "as the argument to FUNCTION"))) (reference-leaf start cont var))) Index: ir2tran.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir2tran.lisp,v retrieving revision 1.39 retrieving revision 1.40 diff -u -d -r1.39 -r1.40 --- ir2tran.lisp 11 Nov 2002 08:37:04 -0000 1.39 +++ ir2tran.lisp 15 Feb 2003 11:16:34 -0000 1.40 @@ -1039,9 +1039,11 @@ (bug "full call to ~S" fname))) (when (consp fname) - (destructuring-bind (setf stem) fname - (aver (eq setf 'setf)) - (setf (gethash stem *setf-assumed-fboundp*) t))))) + (destructuring-bind (setfoid &rest stem) fname + (aver (member setfoid + '(setf sb!pcl::class-predicate sb!pcl::slot-accessor))) + (when (eq setfoid 'setf) + (setf (gethash (car stem) *setf-assumed-fboundp*) t)))))) ;;; If the call is in a tail recursive position and the return ;;; convention is standard, then do a tail full call. If one or fewer |