anymore.
* fixed bug: sometimes MAKE-INSTANCE did not work with classes with
many :DEFAULT-INITARGS. (reported by Istvan Marko)
+ * fixed bug: if last continuation of a deleted block has a
+ destination, this destination should be deleted too. (reported by
+ ohler on #lisp)
* fixed some bugs revealed by Paul Dietz' test suite:
** LAST and [N]BUTLAST should accept a bignum.
+ ** condition slot accessors are methods.
planned incompatible changes in 0.8.x:
* (not done yet, but planned:) When the profiling interface settles
(res (copy-structure sslot)))))))
(res)))
+;;; Early definitions of slot accessor creators.
+;;;
+;;; Slot accessors must be generic functions, but ANSI does not seem
+;;; to specify any of them, and we cannot support it before end of
+;;; warm init. So we use ordinary functions inside SBCL, and switch to
+;;; GFs only at the end of building.
+(declaim (notinline install-condition-slot-reader
+ install-condition-slot-writer))
+(defun install-condition-slot-reader (name condition slot-name)
+ (declare (ignore condition))
+ (setf (fdefinition name)
+ (lambda (condition)
+ (condition-reader-function condition slot-name))))
+(defun install-condition-slot-writer (name condition slot-name)
+ (declare (ignore condition))
+ (setf (fdefinition name)
+ (lambda (new-value condition)
+ (condition-writer-function condition new-value slot-name))))
+
(defun %define-condition (name slots documentation report default-initargs)
(let ((class (find-classoid name)))
(setf (condition-classoid-slots class) slots)
(dolist (slot slots)
;; Set up reader and writer functions.
- (let ((name (condition-slot-name slot)))
+ (let ((slot-name (condition-slot-name slot)))
(dolist (reader (condition-slot-readers slot))
- (setf (fdefinition reader)
- (lambda (condition)
- (condition-reader-function condition name))))
+ (install-condition-slot-reader reader name slot-name))
(dolist (writer (condition-slot-writers slot))
- (setf (fdefinition writer)
- (lambda (new-value condition)
- (condition-writer-function condition new-value name))))))
+ (install-condition-slot-writer writer name slot-name))))
;; Compute effective slots and set up the class and hairy slots
;; (subsets of the effective slots.)
--- /dev/null
+;;;; Condition support in target lisp
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-KERNEL")
+\f
+(fmakunbound 'install-condition-slot-reader)
+(fmakunbound 'install-condition-slot-writer)
+(defun install-condition-slot-reader (name condition slot-name)
+ (eval `(defmethod ,name ((.condition. ,condition))
+ (condition-reader-function .condition. ',slot-name))))
+(defun install-condition-slot-writer (name condition slot-name)
+ (eval `(defmethod ,name (new-value (.condition. ,condition))
+ (condition-writer-function .condition. new-value ',slot-name))))
;; miscellaneous functionality which depends on CLOS
"src/code/force-delayed-defbangmethods"
+ "src/code/late-condition"
;; CLOS-level support for the Gray OO streams
;; extension (which is also supported by various
(unless (gethash (continuation-block cont) *seen-blocks*)
(barf "~S receives ~S, which is in an unknown block." node cont))
(unless (eq (continuation-dest cont) node)
- (barf "DEST for ~S should be ~S." cont node)))))
+ (barf "DEST for ~S should be ~S." cont node))
+ (unless (find-uses cont)
+ (barf "Continuation ~S has a destinatin, but no uses."
+ cont)))))
(values))
;;; This function deals with checking for consistency of the
(check-dest (basic-combination-fun node) node)
(dolist (arg (basic-combination-args node))
(cond
- (arg (check-dest arg node))
- ((not (and (eq (basic-combination-kind node) :local)
- (combination-p node)))
- (barf "flushed arg not in local call: ~S" node))
- (t
- (locally
- ;; KLUDGE: In sbcl-0.6.11.37, the compiler doesn't like
- ;; (DECLARE (TYPE INDEX POS)) after the inline expansion of
- ;; POSITION. It compiles it correctly, but it issues a type
- ;; mismatch warning because it can't eliminate the
- ;; possibility that control will flow through the
- ;; NIL-returning branch. So we punt here. -- WHN 2001-04-15
- (declare (notinline position))
- (let ((fun (ref-leaf (continuation-use
- (basic-combination-fun node))))
- (pos (position arg (basic-combination-args node))))
- (declare (type index pos))
- (when (leaf-refs (elt (lambda-vars fun) pos))
- (barf "flushed arg for referenced var in ~S" node)))))))
+ (arg (check-dest arg node))
+ ((not (and (eq (basic-combination-kind node) :local)
+ (combination-p node)))
+ (barf "flushed arg not in local call: ~S" node))
+ (t
+ (locally
+ ;; KLUDGE: In sbcl-0.6.11.37, the compiler doesn't like
+ ;; (DECLARE (TYPE INDEX POS)) after the inline expansion of
+ ;; POSITION. It compiles it correctly, but it issues a type
+ ;; mismatch warning because it can't eliminate the
+ ;; possibility that control will flow through the
+ ;; NIL-returning branch. So we punt here. -- WHN 2001-04-15
+ (declare (notinline position))
+ (let ((fun (ref-leaf (continuation-use
+ (basic-combination-fun node))))
+ (pos (position arg (basic-combination-args node))))
+ (declare (type index pos))
+ (when (leaf-refs (elt (lambda-vars fun) pos))
+ (barf "flushed arg for referenced var in ~S" node)))))))
(let ((dest (continuation-dest (node-cont node))))
(when (and (return-p dest)
(eq (basic-combination-kind node) :local)
(pprint-logical-block (nil nil)
(format t "~:@_IR1 block ~D start c~D"
(block-number block) (cont-num (block-start block)))
+ (when (block-delete-p block)
+ (format t " <deleted>"))
(let ((last (block-last block)))
(pprint-newline :mandatory)
(when last
(let ((cont (node-cont last)))
(delete-continuation-use last)
- (if (eq (continuation-kind cont) :unused)
- (delete-continuation cont)
- (reoptimize-continuation cont)))))
+ (acond ((eq (continuation-kind cont) :unused)
+ (delete-continuation cont))
+ ((and (null (find-uses cont))
+ (continuation-dest cont))
+ (mark-for-deletion (node-block it)))
+ ((reoptimize-continuation cont))))))
(dolist (b (block-pred block))
(unlink-blocks b block)
(cast
(flush-dest (cast-value node))))
- (delete-continuation (node-prev node)))
+ (delete-continuation (node-prev node)))
(remove-from-dfo block)
(values))
(list (bar x) (bar x) (bar x))))
(assert (raises-error? (bug249 1.0) type-error))
+
+;;; bug reported by ohler on #lisp 2003-07-10
+(defun bug-ohler-2003-07-10 (a b)
+ (declare (optimize (speed 0) (safety 3) (space 0)
+ (debug 1) (compilation-speed 0)))
+ (adjoin a b))
\f
;;;; tests not in the problem domain, but of the consistency of the
;;;; compiler machinery itself
--- /dev/null
+;;;; 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.
+
+(cl:in-package :cl-user)
+
+;;; Bug from CLOCC.
+(defpackage :p1
+ (:use :cl)
+ (:export #:code #:code-msg #:%code-msg))
+(in-package :p1)
+(define-condition code ()
+ ((msg :reader code-msg :reader %code-msg :initarg :msg)))
+
+(defpackage :p2
+ (:use :cl :p1))
+(in-package :p2)
+(define-condition code1 (code)
+ ((msg :accessor code-msg :initarg :msg)))
+
+(let ((code (make-condition 'code :msg 1)))
+ (assert (typep code 'code))
+ (assert (eql (code-msg code) 1))
+ (assert (eql (%code-msg code) 1)))
+(let ((code (make-condition 'code1 :msg 1)))
+ (assert (typep code 'code))
+ (assert (eql (code-msg code) 1))
+ (assert (eql (%code-msg code) 1))
+ (setf (code-msg code) 2)
+ (assert (eql (code-msg code) 2))
+ (assert (eql (%code-msg code) 1)))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.1.28"
+"0.8.1.29"
projects / sbcl.git / commitdiff