* The fasl file version number changed again, for dozens of reasons,
some of which are apparent above.
+changes in sbcl-0.7.0 relative to sbcl-0.6.13:
+* various bug fixes, notably:
+ ** DEFGENERIC is now choosier about the methods it redefines, so
+ reLOADing a previously-LOADed file containing DEFGENERICs does
+ the right thing now, so now the Lispy edit/reLOAD-a-little/test
+ cycle works as it should. (thanks to APD)
+
planned incompatible changes in 0.7.x:
* When the profiling interface settles down, maybe in 0.7.x, maybe
later, it might impact TRACE. They both encapsulate functions, and
"%TANH" "%UNARY-ROUND" "%UNARY-TRUNCATE"
"%WITH-ARRAY-DATA" "%WITH-ARRAY-DATA-MACRO"
"*ALREADY-MAYBE-GCING*"
- "*CURRENT-LEVEL*" "*EMPTY-TYPE*"
+ "*CURRENT-LEVEL-IN-PRINT*" "*EMPTY-TYPE*"
"*GC-INHIBIT*"
"*NEED-TO-COLLECT-GARBAGE*"
"*PRETTY-PRINTER*" "*UNIVERSAL-TYPE*"
(error "Unaligned instruction? offset=#x~X." offset))
(sb!sys:without-gcing
(let ((sap (truly-the system-area-pointer
- (%primitive sb!kernel::code-instructions code))))
+ (%primitive code-instructions code))))
(ecase kind
(:jmp-hint
(assert (zerop (ldb (byte 2 0) value)))
;; that CL:CLASS-NAME is a generic function.)
(%name nil :type symbol)
;; the current layout for this class, or NIL if none assigned yet
- (layout nil :type (or sb!kernel::layout null))
+ (layout nil :type (or layout null))
;; How sure are we that this class won't be redefined?
;; :READ-ONLY = We are committed to not changing the effective
;; slots or superclasses.
#!+sb-show
(defun hexstr (thing)
(/noshow0 "entering HEXSTR")
- (let ((addr (sb!kernel:get-lisp-obj-address thing))
+ (let ((addr (get-lisp-obj-address thing))
(str (make-string 10)))
(/noshow0 "ADDR and STR calculated")
(setf (char str 0) #\0
;; the program. WITH-STANDARD-IO-SYNTAX does some of that,
;; but
;; 1. It doesn't affect our internal special variables
- ;; like *CURRENT-LEVEL*.
+ ;; like *CURRENT-LEVEL-IN-PRINT*.
;; 2. It isn't customizable.
;; 3. It doesn't set *PRINT-READABLY* or *PRINT-PRETTY*
;; to the same value as the toplevel default.
;; helpful behavior for a debugger.
;; We try to remedy all these problems with explicit
;; rebindings here.
- (sb!kernel:*current-level* 0)
+ (sb!kernel:*current-level-in-print* 0)
(*print-length* *debug-print-length*)
(*print-level* *debug-print-level*)
(*readtable* *debug-readtable*)
(format *error-output*
"~&(caught ~S trying to print ~S when entering debugger)~%"
(type-of condition)
- '*debug-condition*)))
+ '*debug-condition*)
+ (when (typep condition 'cell-error)
+ ;; what we really want to know when it's e.g. an UNBOUND-VARIABLE:
+ (format *error-output*
+ "~&(CELL-ERROR-NAME = ~S)~%)"
+ (cell-error-name *debug-condition*)))))
;; After the initial error/condition/whatever announcement to
;; *ERROR-OUTPUT*, we become interactive, and should talk on
#-sb-xc-host (:pure t)
(:constructor make-defstruct-description (name)))
;; name of the structure
- (name (missing-arg) :type symbol)
+ (name (missing-arg) :type symbol :read-only t)
;; documentation on the structure
(doc nil :type (or string null))
;; prefix for slot names. If NIL, none.
fun-name)))
(cond ((not (eql pf 0))
`((def!method print-object ((,x ,name) ,s)
- (funcall #',(farg pf) ,x ,s *current-level*))))
+ (funcall #',(farg pf)
+ ,x
+ ,s
+ *current-level-in-print*))))
((not (eql po 0))
`((def!method print-object ((,x ,name) ,s)
(funcall #',(farg po) ,x ,s))))
\f
;;;; level and length abbreviations
-(defvar *current-level* 0
- #!+sb-doc
- "The current level we are printing at, to be compared against *PRINT-LEVEL*.
- See the macro DESCEND-INTO for a handy interface to depth abbreviation.")
+;;; The current level we are printing at, to be compared against
+;;; *PRINT-LEVEL*. See the macro DESCEND-INTO for a handy interface to
+;;; depth abbreviation.
+(defvar *current-level-in-print* 0)
+;;; Automatically handle *PRINT-LEVEL* abbreviation. If we are too
+;;; deep, then a #\# is printed to STREAM and BODY is ignored.
(defmacro descend-into ((stream) &body body)
- #!+sb-doc
- "Automatically handle *PRINT-LEVEL* abbreviation. If we are too deep, then
- a # is printed to STREAM and BODY is ignored."
(let ((flet-name (gensym)))
`(flet ((,flet-name ()
,@body))
(cond ((and (null *print-readably*)
*print-level*
- (>= *current-level* *print-level*))
+ (>= *current-level-in-print* *print-level*))
(write-char #\# ,stream))
(t
- (let ((*current-level* (1+ *current-level*)))
+ (let ((*current-level-in-print* (1+ *current-level-in-print*)))
(,flet-name)))))))
+;;; Punt if INDEX is equal or larger then *PRINT-LENGTH* (and
+;;; *PRINT-READABLY* is NIL) by outputting \"...\" and returning from
+;;; the block named NIL.
(defmacro punt-print-if-too-long (index stream)
- #!+sb-doc
- "Punt if INDEX is equal or larger then *PRINT-LENGTH* (and *PRINT-READABLY*
- is NIL) by outputting \"...\" and returning from the block named NIL."
`(when (and (not *print-readably*)
*print-length*
(>= ,index *print-length*))
(or (not wherein)
(trace-wherein-p frame wherein)))))
(when conditionp
- (let ((sb-kernel:*current-level* 0)
+ (let ((sb-kernel:*current-level-in-print* 0)
(*standard-output* *trace-output*)
(*in-trace* t))
(fresh-line)
(or (cdr entry)
(let ((cond (trace-info-condition-after info)))
(and cond (funcall (cdr cond) frame)))))
- (let ((sb-kernel:*current-level* 0)
+ (let ((sb-kernel:*current-level-in-print* 0)
(*standard-output* *trace-output*)
(*in-trace* t))
(fresh-line)
*print-object-is-disabled-p*))
(print-object object stream))
((typep object 'structure-object)
- (default-structure-print object stream *current-level*))
+ (default-structure-print object stream *current-level-in-print*))
(t
(write-string "#<INSTANCE but not STRUCTURE-OBJECT>" stream))))
(function
;;; use until CLOS is set up (at which time it will be replaced with
;;; the real generic function implementation)
(defun print-object (instance stream)
- (default-structure-print instance stream *current-level*))
+ (default-structure-print instance stream *current-level-in-print*))
\f
;;;; integer, ratio, and complex printing (i.e. everything but floats)
(t
(%default-structure-ugly-print structure stream))))
(def!method print-object ((x structure-object) stream)
- (default-structure-print x stream *current-level*))
+ (default-structure-print x stream *current-level-in-print*))
(defun make-load-form-saving-slots (object &key slot-names environment)
(declare (ignore object environment))
(if slot-names
- (error "stub: MAKE-LOAD-FORM-SAVING-SLOTS :SLOT-NAMES not implemented") ; KLUDGE
- :just-dump-it-normally))
+ (error "stub: MAKE-LOAD-FORM-SAVING-SLOTS :SLOT-NAMES not implemented") ; KLUDGE
+ :just-dump-it-normally))
\f
;;;; testing structure types
;;; which have a handle on the type's LAYOUT.
;;;
;;; FIXME: This is fairly big, so it should probably become
-;;; MAYBE-INLINE instead of INLINE. Or else we could fix things up so
-;;; that the things which call it are all closures, so that it's
-;;; expanded only in a small number of places.
+;;; MAYBE-INLINE instead of INLINE, or its inlineness should become
+;;; conditional (probably through DEFTRANSFORM) on (> SPEED SPACE). Or
+;;; else we could fix things up so that the things which call it are
+;;; all closures, so that it's expanded only in a small number of
+;;; places.
#!-sb-fluid (declaim (inline typep-to-layout))
(defun typep-to-layout (obj layout)
(declare (type layout layout) (optimize (speed 3) (safety 0)))
sb!vm:fun-pointer-lowtag))
(next (read-wordindexed code-object sb!vm:code-entry-points-slot)))
(unless (zerop (logand offset sb!vm:lowtag-mask))
- ;; FIXME: This should probably become a fatal error.
- (warn "unaligned function entry: ~S at #X~X" name offset))
+ (error "unaligned function entry: ~S at #X~X" name offset))
(write-wordindexed code-object sb!vm:code-entry-points-slot fn)
(write-memory fn
(make-other-immediate-descriptor
;; code instead of a pointer back to the object
;; itself.) Ask on the mailing list whether
;; this is documented somewhere, and if not,
- ;; try to reverse engineer some documentation
- ;; before release.
+ ;; try to reverse engineer some documentation.
#!-x86
;; a pointer back to the function object, as
;; described in CMU CL
;; writing codes/strings for internal errors
(format t "#define ERRORS { \\~%")
- ;; FIXME: Is this just DOVECTOR?
(let ((internal-errors sb!c:*backend-internal-errors*))
(dotimes (i (length internal-errors))
(format t " ~S, /*~D*/ \\~%" (cdr (aref internal-errors i)) i)))
;; writing static symbol offsets
(dolist (symbol (cons nil sb!vm:*static-symbols*))
- ;; FIXME: It would be nice to use longer names NIL and (particularly) T
- ;; in #define statements.
+ ;; FIXME: It would be nice to use longer names than NIL and
+ ;; (particularly) T in #define statements.
(format t "#define ~A LISPOBJ(0x~X)~%"
(nsubstitute #\_ #\-
(remove-if (lambda (char)
(defparameter initial-fun-entry-type-code 3863)
(defparameter end-entry-type-code 3840)
-(declaim (ftype (function (sb!vm:word) sb!vm:word) write-long))
-(defun write-long (num) ; FIXME: WRITE-WORD would be a better name.
+(declaim (ftype (function (sb!vm:word) sb!vm:word) write-word))
+(defun write-word (num)
(ecase sb!c:*backend-byte-order*
(:little-endian
(dotimes (i 4)
;; DATA PAGE
;; ADDRESS
;; PAGE COUNT
- (write-long (gspace-identifier gspace))
- (write-long (gspace-free-word-index gspace))
- (write-long *data-page*)
+ (write-word (gspace-identifier gspace))
+ (write-word (gspace-free-word-index gspace))
+ (write-word *data-page*)
(multiple-value-bind (floor rem)
(floor (gspace-byte-address gspace) sb!c:*backend-page-size*)
(aver (zerop rem))
- (write-long floor))
- (write-long pages)
+ (write-word floor))
+ (write-word pages)
(incf *data-page* pages)))
:if-exists :rename-and-delete)
;; Write the magic number.
- (write-long core-magic)
+ (write-word core-magic)
;; Write the Version entry.
- (write-long version-entry-type-code)
- (write-long 3)
- (write-long sbcl-core-version-integer)
+ (write-word version-entry-type-code)
+ (write-word 3)
+ (write-word sbcl-core-version-integer)
;; Write the New Directory entry header.
- (write-long new-directory-entry-type-code)
- (write-long 17) ; length = (5 words/space) * 3 spaces + 2 for header.
+ (write-word new-directory-entry-type-code)
+ (write-word 17) ; length = (5 words/space) * 3 spaces + 2 for header.
(output-gspace *read-only*)
(output-gspace *static*)
(output-gspace *dynamic*)
;; Write the initial function.
- (write-long initial-fun-entry-type-code)
- (write-long 3)
+ (write-word initial-fun-entry-type-code)
+ (write-word 3)
(let* ((cold-name (cold-intern '!cold-init))
(cold-fdefn (cold-fdefinition-object cold-name))
(initial-fun (read-wordindexed cold-fdefn
(format t
"~&/(DESCRIPTOR-BITS INITIAL-FUN)=#X~X~%"
(descriptor-bits initial-fun))
- (write-long (descriptor-bits initial-fun)))
+ (write-word (descriptor-bits initial-fun)))
;; Write the End entry.
- (write-long end-entry-type-code)
- (write-long 2)))
+ (write-word end-entry-type-code)
+ (write-word 2)))
(format t "done]~%")
(force-output)
(arglist (elt qab arglist-pos))
(qualifiers (subseq qab 0 arglist-pos))
(body (nthcdr (1+ arglist-pos) qab)))
- `(defmethod ,fun-name ,@qualifiers ,arglist ,@body))))
+ `(push (defmethod ,fun-name ,@qualifiers ,arglist ,@body)
+ (generic-function-initial-methods #',fun-name)))))
(macrolet ((initarg (key) `(getf initargs ,key)))
(dolist (option options)
(let ((car-option (car option)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(compile-or-load-defgeneric ',fun-name))
(load-defgeneric ',fun-name ',lambda-list ,@initargs)
- ,@(mapcar #'expand-method-definition methods)
- `,(function ,fun-name)))))
+ ,@(mapcar #'expand-method-definition methods)
+ #',fun-name))))
(defun compile-or-load-defgeneric (fun-name)
(sb-kernel:proclaim-as-fun-name fun-name)
(defun load-defgeneric (fun-name lambda-list &rest initargs)
(when (fboundp fun-name)
- (sb-kernel::style-warn "redefining ~S in DEFGENERIC" fun-name))
+ (sb-kernel::style-warn "redefining ~S in DEFGENERIC" fun-name)
+ (let ((fun (fdefinition fun-name)))
+ (when (generic-function-p fun)
+ (loop for method in (generic-function-initial-methods fun)
+ do (remove-method fun method))
+ (setf (generic-function-initial-methods fun) '()))))
(apply #'ensure-generic-function
- fun-name
- :lambda-list lambda-list
- :definition-source `((defgeneric ,fun-name) ,*load-truename*)
- initargs))
+ fun-name
+ :lambda-list lambda-list
+ :definition-source `((defgeneric ,fun-name) ,*load-truename*)
+ initargs))
\f
(defmacro defmethod (&rest args &environment env)
(multiple-value-bind (name qualifiers lambda-list body)
(defclass method (standard-object) ())
(defclass standard-method (definition-source-mixin plist-mixin method)
- ((generic-function
- :initform nil
- :accessor method-generic-function)
-; (qualifiers
-; :initform ()
-; :initarg :qualifiers
-; :reader method-qualifiers)
- (specializers
- :initform ()
- :initarg :specializers
- :reader method-specializers)
- (lambda-list
- :initform ()
- :initarg :lambda-list
- :reader method-lambda-list)
- (function
- :initform nil
- :initarg :function) ;no writer
- (fast-function
- :initform nil
- :initarg :fast-function ;no writer
- :reader method-fast-function)
-; (documentation
-; :initform nil
-; :initarg :documentation
-; :reader method-documentation)
- ))
+ ((generic-function
+ :initform nil
+ :accessor method-generic-function)
+;;; (qualifiers
+;;; :initform ()
+;;; :initarg :qualifiers
+;;; :reader method-qualifiers)
+ (specializers
+ :initform ()
+ :initarg :specializers
+ :reader method-specializers)
+ (lambda-list
+ :initform ()
+ :initarg :lambda-list
+ :reader method-lambda-list)
+ (function
+ :initform nil
+ :initarg :function) ;no writer
+ (fast-function
+ :initform nil
+ :initarg :fast-function ;no writer
+ :reader method-fast-function)
+;;; (documentation
+;;; :initform nil
+;;; :initarg :documentation
+;;; :reader method-documentation)
+ ))
(defclass standard-accessor-method (standard-method)
- ((slot-name :initform nil
- :initarg :slot-name
- :reader accessor-method-slot-name)
- (slot-definition :initform nil
- :initarg :slot-definition
- :reader accessor-method-slot-definition)))
+ ((slot-name :initform nil
+ :initarg :slot-name
+ :reader accessor-method-slot-name)
+ (slot-definition :initform nil
+ :initarg :slot-definition
+ :reader accessor-method-slot-definition)))
(defclass standard-reader-method (standard-accessor-method) ())
definition-source-mixin
documentation-mixin
funcallable-standard-object)
- ()
+ (;; We need to make a distinction between the methods initially set
+ ;; up by :METHOD options to DEFGENERIC and the ones set up later by
+ ;; DEFMETHOD, because ANSI's specifies that executing DEFGENERIC on
+ ;; an already-DEFGENERICed function clears the methods set by the
+ ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making
+ ;; this distinction seems a little kludgy, but it has the positive
+ ;; effect of making it so that loading a file a.lisp containing
+ ;; DEFGENERIC, then loading a second file b.lisp containing
+ ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp
+ ;; tends to leave the generic function in a state consistent with
+ ;; the most-recently-loaded state of a.lisp and b.lisp.)
+ (initial-methods
+ :initform ()
+ :accessor generic-function-initial-methods))
(:metaclass funcallable-standard-class))
(defclass standard-generic-function (generic-function)
- ((name
- :initform nil
- :initarg :name
- :accessor generic-function-name)
- (methods
- :initform ()
- :accessor generic-function-methods
- :type list)
- (method-class
- :initarg :method-class
- :accessor generic-function-method-class)
- (method-combination
- :initarg :method-combination
- :accessor generic-function-method-combination)
- (arg-info
- :initform (make-arg-info)
- :reader gf-arg-info)
- (dfun-state
- :initform ()
- :accessor gf-dfun-state))
+ ((name
+ :initform nil
+ :initarg :name
+ :accessor generic-function-name)
+ (methods
+ :initform ()
+ :accessor generic-function-methods
+ :type list)
+ (method-class
+ :initarg :method-class
+ :accessor generic-function-method-class)
+ (method-combination
+ :initarg :method-combination
+ :accessor generic-function-method-combination)
+ (arg-info
+ :initform (make-arg-info)
+ :reader gf-arg-info)
+ (dfun-state
+ :initform ()
+ :accessor gf-dfun-state))
(:metaclass funcallable-standard-class)
(:default-initargs :method-class *the-class-standard-method*
:method-combination *standard-method-combination*))
(defgeneric gf-dfun-state (standard-generic-function))
+(defgeneric generic-function-initial-methods (standard-generic-function))
+
(defgeneric long-method-combination-function (long-method-combination))
(defgeneric method-combination-documentation (standard-method-combination))
(defgeneric (setf gf-dfun-state) (new-value standard-generic-function))
+(defgeneric (setf generic-function-initial-methods)
+ (new-value standard-generic-function))
+
(defgeneric (setf method-generic-function) (new-value standard-method))
(defgeneric (setf object-plist) (new-value plist-mixin))
(:use "CL"))
(in-package "FOO")
\f
-;;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to
-;;;; structure types defined earlier in the file.
+;;; 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))
'structure-class))
(assert (typep (make-instance 'structure-class-foo1) 'structure-class-foo1))
(assert (typep (make-instance 'standard-class-foo1) 'standard-class-foo1))
+
+;;; DEFGENERIC's blow-away-old-methods behavior is specified to have
+;;; special hacks to distinguish between defined-with-DEFGENERIC-:METHOD
+;;; methods and defined-with-DEFMETHOD methods, so that reLOADing
+;;; DEFGENERIC-containing files does the right thing instead of
+;;; randomly slicing your generic functions. (APD made this work
+;;; in sbcl-0.7.0.2.)
+(defgeneric born-to-be-redefined (x)
+ (:method ((x integer))
+ 'integer))
+(defmethod born-to-be-redefined ((x real))
+ 'real)
+(assert (eq (born-to-be-redefined 1) 'integer))
+(defgeneric born-to-be-redefined (x))
+(assert (eq (born-to-be-redefined 1) 'real)) ; failed until sbcl-0.7.0.2
+(defgeneric born-to-be-redefined (x)
+ (:method ((x integer))
+ 'integer))
+(defmethod born-to-be-redefined ((x integer))
+ 'int)
+(assert (eq (born-to-be-redefined 1) 'int))
+(defgeneric born-to-be-redefined (x))
+(assert (eq (born-to-be-redefined 1) 'int))
\f
;;;; success
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.0"
+"0.7.0.2"
projects / sbcl.git / commitdiff