* Martin Atzmueller ported Tim Moore's marvellous CMU CL DISASSEMBLE
patch, so that DISASSEMBLE output is much nicer.
* better error handling in CLOS method combination, thanks to
- Martin Atzmueller and Pierre Mai
-* Logical pathnames work better, thanks to various fixes and
- tests from Dan Barlow.
+ Martin Atzmueller porting Pierre Mai's CMU CL patches
+* Pathnames are much more ANSI-compliant, thanks to various fixes
+ and tests from Dan Barlow.
* Hash tables can be printed readably, as inspired by CMU CL code
of Eric Marsden and SBCL code of Martin Atzmueller.
-* a new slam.sh hack to shorten the edit/compile/debug cycle for
- low-level changes to SBCL itself, and a new :SB-AFTER-XC-CORE
- target feature to control the generation of the after-xc.core
- file needed by slam.sh.
* Compiler trace output (the :TRACE-FILE option to COMPILE-FILE)
is now a supported extension again, since the consensus is that
it can be useful for ordinary development work, not just for
debugging SBCL itself.
?? more overflow fixes for >16Mbyte i/o buffers
+* There's a new slam.sh hack to shorten the edit/compile/debug
+ cycle for low-level changes to SBCL itself, and a new
+ :SB-AFTER-XC-CORE target feature to control the generation of
+ the after-xc.core file needed by slam.sh.
* minor incompatible change: The ENTRY-POINTS &KEY argument to
COMPILE-FILE is no longer supported, so that now every function
gets an entry point, so that block compilation looks a little
(setf (getf ,all-keys :method-combination)
(find-method-combination (class-prototype ,gf-class)
(car combin)
- (cdr combin)))))))
+ (cdr combin)))))
+ (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))))))
(defun real-ensure-gf-using-class--generic-function
(existing
(expand-defclass name direct-superclasses direct-slots options))
(defun expand-defclass (name supers slots options)
- ;; FIXME: We should probably just ensure that the relevant
- ;; DEFVAR/DEFPARAMETERs occur before this definition, rather
- ;; than locally declaring them SPECIAL.
- (declare (special *boot-state* *the-class-structure-class*))
(setq supers (copy-tree supers)
slots (copy-tree slots)
options (copy-tree options))
,defclass-form))
(progn
(when (eq *boot-state* 'complete)
+ ;; FIXME: MNA (on sbcl-devel 2001-05-30) reported
+ ;; (if I understand correctly -- WHN) that this call
+ ;; is directly responsible for defining
+ ;; class-predicates which always return
+ ;; CONSTANTLY-NIL in the compile-time environment,
+ ;; and is indirectly responsible for bogus warnings
+ ;; about redefinitions when making definitions in
+ ;; the interpreter. I didn't like his fix (deleting
+ ;; the call) since I think the type system *should*
+ ;; be informed about class definitions here. And I'm
+ ;; not eager to look too deeply into this sort of
+ ;; done-too-many-times-in-the-interpreter problem
+ ;; right now, since it should be easier to make a
+ ;; clean fix when EVAL-WHEN is made more ANSI (as
+ ;; per the IR1 section in the BUGS file). But
+ ;; at some point this should be cleaned up.
(inform-type-system-about-std-class name))
defclass-form)))))))
#'(lambda (x)
(funcall (the function (find-class-cell-predicate cell)) x))))
-(defun make-class-eq-predicate (class)
- (when (symbolp class) (setq class (find-class class)))
- #'(lambda (object) (eq class (class-of object))))
-
-(defun make-eql-predicate (eql-object)
- #'(lambda (object) (eql eql-object object)))
+(defun make-type-predicate-name (name &optional kind)
+ (if (symbol-package name)
+ (intern (format nil
+ "~@[~A ~]TYPE-PREDICATE ~A ~A"
+ kind
+ (package-name (symbol-package name))
+ (symbol-name name))
+ *pcl-package*)
+ (make-symbol (format nil
+ "~@[~A ~]TYPE-PREDICATE ~A"
+ kind
+ (symbol-name name)))))
;;; internal to this file..
;;;
(t
(subtypep (convert-to-system-type type1)
(convert-to-system-type type2))))))))
-
-(defun make-type-predicate-name (name &optional kind)
- (if (symbol-package name)
- (intern (format nil
- "~@[~A ~]TYPE-PREDICATE ~A ~A"
- kind
- (package-name (symbol-package name))
- (symbol-name name))
- *pcl-package*)
- (make-symbol (format nil
- "~@[~A ~]TYPE-PREDICATE ~A"
- kind
- (symbol-name name)))))
\f
(defvar *built-in-class-symbols* ())
(defvar *built-in-wrapper-symbols* ())
;;; an :instance slot, this is the index number of that slot
;;; in the object argument.
(defun cache-miss-values (gf args state)
- (if (null (if (early-gf-p gf)
- (early-gf-methods gf)
- (generic-function-methods gf)))
- (apply #'no-applicable-method gf args)
- (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
- (get-generic-function-info gf)
- (declare (ignore nreq applyp nkeys))
- (with-dfun-wrappers (args metatypes)
- (dfun-wrappers invalid-wrapper-p wrappers classes types)
- (error-need-at-least-n-args gf (length metatypes))
- (multiple-value-bind (emf methods accessor-type index)
- (cache-miss-values-internal
- gf arg-info wrappers classes types state)
- (values emf methods
- dfun-wrappers
- invalid-wrapper-p
- accessor-type index))))))
+ (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
+ (get-generic-function-info gf)
+ (declare (ignore nreq applyp nkeys))
+ (with-dfun-wrappers (args metatypes)
+ (dfun-wrappers invalid-wrapper-p wrappers classes types)
+ (error-need-at-least-n-args gf (length metatypes))
+ (multiple-value-bind (emf methods accessor-type index)
+ (cache-miss-values-internal
+ gf arg-info wrappers classes types state)
+ (values emf methods
+ dfun-wrappers
+ invalid-wrapper-p
+ accessor-type index)))))
(defun cache-miss-values-internal (gf arg-info wrappers classes types state)
(let* ((for-accessor-p (eq state 'accessor))
(in-package "SB-PCL")
\f
-(defmethod shared-initialize :after ((slotd standard-slot-definition)
- slot-names &key)
- (declare (ignore slot-names))
- (with-slots (allocation class)
- slotd
- (setq allocation (if (eq allocation :class) class allocation))))
-
-(defmethod shared-initialize :after ((slotd structure-slot-definition)
- slot-names
- &key (allocation :instance))
- (declare (ignore slot-names))
- (unless (eq allocation :instance)
- (error "Structure slots must have :INSTANCE allocation.")))
-
-(defmethod inform-type-system-about-class ((class structure-class) (name t))
- nil)
;;; methods
;;;
`(let ,bindings ,form)
form)))
-;;; FIXME: Why is this defined in two different places? And what does
-;;; it mean anyway? And can we just eliminate it completely (replacing
-;;; it with NIL, then hand-eliminating any resulting dead code)?
-(defconstant +optimize-slot-boundp+ nil)
-
(defmacro accessor-slot-boundp (object slot-name)
(unless (constantp slot-name)
(error "~S requires its slot-name argument to be a constant"
'accessor-slot-boundp))
(let* ((slot-name (eval slot-name))
(sym (slot-boundp-symbol slot-name)))
- (if (not +optimize-slot-boundp+)
- `(slot-boundp-normal ,object ',slot-name)
- `(asv-funcall ,sym ,slot-name boundp ,object))))
+ `(slot-boundp-normal ,object ',slot-name)))
(defun structure-slot-boundp (object)
(declare (ignore object))
(gf (ensure-generic-function name)))
(unless (generic-function-methods gf)
(add-writer-method *the-class-slot-object* gf slot-name))))
- (when (and +optimize-slot-boundp+
- (or (null type) (eq type 'boundp)))
- (let* ((name (slot-boundp-symbol slot-name))
- (gf (ensure-generic-function name)))
- (unless (generic-function-methods gf)
- (add-boundp-method *the-class-slot-object* gf slot-name))))
nil)
(defun initialize-internal-slot-gfs* (readers writers boundps)
`(accessor-set-slot-value ,object-form ,slot-name-form ,new-value-form)
`(set-slot-value-normal ,object-form ,slot-name-form ,new-value-form)))
-(defconstant +optimize-slot-boundp+ nil)
-
(defun slot-boundp (object slot-name)
(let* ((class (class-of object))
(slot-definition (find-slot-definition class slot-name)))
(defmethod ensure-class-using-class (name (class null) &rest args &key)
(multiple-value-bind (meta initargs)
(ensure-class-values class args)
- (inform-type-system-about-class (class-prototype meta) name);***
(setf class (apply #'make-instance meta :name name initargs)
(find-class name) class)
- (inform-type-system-about-class class name) ;***
+ (inform-type-system-about-class class name)
class))
(defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)
(unless (eq (class-of class) meta) (change-class class meta))
(apply #'reinitialize-instance class initargs)
(setf (find-class name) class)
- (inform-type-system-about-class class name) ;***
+ (inform-type-system-about-class class name)
class))
(defmethod class-predicate-name ((class t))
(and (neq supplied-slots unsupplied) supplied-slots)
initargs)))))
\f
-#|| ; since it doesn't do anything
-(defmethod shared-initialize :before ((class std-class)
- slot-names
- &key direct-superclasses)
- (declare (ignore slot-names))
- ;; *** error checking
- )
-||#
(defmethod shared-initialize :after
((class std-class)
#'(lambda (dependent)
(apply #'update-dependent class dependent initargs))))
+(defmethod shared-initialize :after ((slotd standard-slot-definition)
+ slot-names &key)
+ (declare (ignore slot-names))
+ (with-slots (allocation class)
+ slotd
+ (setq allocation (if (eq allocation :class) class allocation))))
+
+(defmethod shared-initialize :after ((slotd structure-slot-definition)
+ slot-names
+ &key (allocation :instance))
+ (declare (ignore slot-names))
+ (unless (eq allocation :instance)
+ (error "Structure slots must have :INSTANCE allocation.")))
+
(defmethod shared-initialize :after
((class structure-class)
slot-names
;;; *** There is a subtle bug here which is going to have to be fixed.
;;; *** Namely, the simplistic use of the template has to be fixed. We
;;; *** have to give the optimize-slot-value method the user might have
-;;; *** defined for this metclass a chance to run.
+;;; *** defined for this metaclass a chance to run.
(defmethod make-reader-method-function ((class slot-class) slot-name)
(make-std-reader-method-function (class-name class) slot-name))
(make-std-boundp-method-function (class-name class) slot-name))
\f
;;;; inform-type-system-about-class
-;;;; make-type-predicate
;;;
;;; These are NOT part of the standard protocol. They are internal
;;; mechanism which PCL uses to *try* and tell the type system about
;;; the type system about new classes would be different.
(defmethod inform-type-system-about-class ((class std-class) name)
(inform-type-system-about-std-class name))
+
+(defmethod inform-type-system-about-class ((class structure-class) (name t))
+ nil)
\f
(defmethod compatible-meta-class-change-p (class proto-new-class)
(eq (class-of class) (class-of proto-new-class)))
--- /dev/null
+;;;; miscellaneous side-effectful tests of CLOS
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(defpackage "FOO"
+ (:use "CL"))
+(in-package "FOO")
+\f
+;;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to
+;;;; structure types defined earlier in the file.
+(defstruct struct-a x y)
+(defstruct struct-b x y z)
+(defmethod wiggle ((a struct-a))
+ (+ (struct-a-x a)
+ (struct-a-y a)))
+(defgeneric jiggle ((arg t)))
+(defmethod jiggle ((a struct-a))
+ (- (struct-a-x a)
+ (struct-a-y a)))
+(defmethod jiggle ((b struct-b))
+ (- (struct-b-x b)
+ (struct-b-y b)
+ (struct-b-z b)))
+(assert (= (wiggle (make-struct-a :x 6 :y 5))
+ (jiggle (make-struct-b :x 19 :y 6 :z 2))))
+
+;;; Compiling DEFGENERIC should prevent "undefined function" style warnings
+;;; from code within the same file.
+(defgeneric gf-defined-in-this-file ((x number) (y number)))
+(defun function-using-gf-defined-in-this-file (x y n)
+ (unless (minusp n)
+ (gf-defined-in-this-file x y)))
+
+;;; Until Martin Atzmueller ported Pierre Mai's CMU CL fixes in
+;;; sbcl-0.6.12.25, the implementation of NO-APPLICABLE-METHOD was
+;;; broken in such a way that the code here would signal an error.
+(defgeneric zut-n-a-m (a b c))
+(defmethod no-applicable-method ((zut-n-a-m (eql #'zut-n-a-m)) &rest args)
+ (format t "~&No applicable method for ZUT-N-A-M ~S, yet.~%" args))
+(zut-n-a-m 1 2 3)
+\f
+;;;; success
+
+(sb-ext:quit :unix-status 104)
+++ /dev/null
-;;;; miscellaneous side-effectful tests of CLOS
-
-;;;; This software is part of the SBCL system. See the README file for
-;;;; more information.
-;;;;
-;;;; While most of SBCL is derived from the CMU CL system, the test
-;;;; files (like this one) were written from scratch after the fork
-;;;; from CMU CL.
-;;;;
-;;;; This software is in the public domain and is provided with
-;;;; absolutely no warranty. See the COPYING and CREDITS files for
-;;;; more information.
-
-(defpackage "FOO"
- (:use "CL"))
-(in-package "FOO")
-\f
-;;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to
-;;;; structure types defined earlier in the file.
-
-(defstruct struct-a x y)
-(defstruct struct-b x y z)
-
-(defmethod wiggle ((a struct-a))
- (+ (struct-a-x a)
- (struct-a-y a)))
-(defgeneric jiggle ((arg t)))
-(defmethod jiggle ((a struct-a))
- (- (struct-a-x a)
- (struct-a-y a)))
-(defmethod jiggle ((b struct-b))
- (- (struct-b-x b)
- (struct-b-y b)
- (struct-b-z b)))
-
-(assert (= (wiggle (make-struct-a :x 6 :y 5))
- (jiggle (make-struct-b :x 19 :y 6 :z 2))))
-\f
-;;; Compiling DEFGENERIC should prevent "undefined function" style warnings
-;;; from code within the same file.
-
-(defgeneric gf-defined-in-this-file ((x number) (y number)))
-(defun function-using-gf-defined-in-this-file (x y n)
- (unless (minusp n)
- (gf-defined-in-this-file x y)))
-\f
-;;;; success
-
-(sb-ext:quit :unix-status 104)
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.12.24"
+"0.6.12.25"
projects / sbcl.git / commitdiff