  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.

;;; Bug from CLOCC.
;;; /
(defpackage :p1
  (:use :cl)
  (:export #:code #:code-msg #:%code-msg))
(define-condition p1:code ()
  ((p1::msg :reader p1:code-msg :reader p1:%code-msg :initarg :msg)))

(defpackage :p2
  (:use :cl :p1))
(define-condition p2::code1 (p1:code)
  ((p2::msg :accessor p1:code-msg :initarg :msg)))

;;; This test asserts that:
   - distinct symbols create distinct slots , unlike with DEFSTRUCT
      where slots are compared by string=
   - two slots can be initialized by one initarg
;;;  - an accessor can shadow an identically-named inherited accessor
;;;     and read/write a different slot
(with-test (:name :condition-slot-package-confusion)
  (let ((code (make-condition 'p1:code :msg 1)))
    (assert (typep code 'p1:code))
    (assert (eql (p1:code-msg code) 1))
    (assert (eql (p1:%code-msg code) 1)))
  (let ((code (make-condition 'p2::code1 :msg 1)))
    (assert (typep code 'p1:code))
    (assert (eql (p1:code-msg code) 1))
    (assert (eql (p1:%code-msg code) 1))
    (setf (p1:code-msg code) 2)
    (assert (eql (p1:code-msg code) 2))
    (assert (eql (p1:%code-msg code) 1))))

  Check that initializing the condition class metaobject does n't create
  any instances . Reported by   on sbcl - devel Mon , 05 Jul 2004 .
(defvar *condition-count* 0)
(define-condition counted-condition () ((slot :initform (incf *condition-count*))))
  What purpose was this DEFMETHOD serving ? None as far as I can tell .
  ( defmethod frob - counted - condition ( ( x counted - condition ) ) x )
(assert (= 0 *condition-count*))
(assert (typep (sb-mop:class-prototype (find-class 'counted-condition))
               '(and condition counted-condition)))
(opaque-identity (make-condition 'counted-condition))
(assert (= 1 *condition-count*))

(define-condition picky-condition () ())

(with-test (:name (:picky-condition compute-restarts))
  (restart-case
      (handler-case
          (error 'picky-condition)
        (picky-condition (c)
          ;; The PICKY-RESTART should be applicable for the
  PICKY - CONDITION and all other cases .
          (assert (eq (restart-name (first (compute-restarts))) 'picky-restart))
          (assert (eq (restart-name (first (compute-restarts c))) 'picky-restart))
          (assert (eq (car (compute-restarts)) (car (compute-restarts c))))
  ANOTHER - PICKY - RESTART should not be applicable for the
  PICKY - CONDITION , but all other cases .
          (assert (not (find 'another-picky-restart (compute-restarts c)
                             :key #'restart-name)))
          (assert (find 'another-picky-restart (compute-restarts)
                        :key #'restart-name))
          :ok))
    (picky-restart ()
      :report "Do nothing."
      :test (lambda (c) (typep c '(or null picky-condition))))
    (another-picky-restart ()
      :report "Do nothing as well"
      :test (lambda (c) (typep c '(not picky-condition))))))

  adapted from   on cmucl - imp
(with-test (:name (:picky-condition invoke-restart))
  (assert (eq 'it
              (restart-case
                  (handler-case
                      (error 'picky-condition)
                    (picky-condition (c)
                      (invoke-restart (find-restart 'give-it c))))
                (give-it ()
                  :test (lambda (c) (typep c 'picky-condition))
                  'it)))))

  In sbcl-1.0.9 , a condition derived from CL : STREAM - ERROR ( or
  CL : READER - ERROR or or CL : PARSE - ERROR ) did n't inherit a usable
;;; PRINT-OBJECT method --- the PRINT-OBJECT code implicitly assumed
  that CL : STREAM - ERROR was like a SIMPLE - CONDITION , with args and
;;; format control, which seems to be a preANSIism.
;;;
;;; (The spec for DEFINE-CONDITION says that if :REPORT is not
;;; supplied, "information about how to report this type of condition
  is inherited from the PARENT - TYPE . " The spec does n't explicitly
;;; forbid the inherited printer from trying to read slots which
;;; aren't portably specified for the condition, but it doesn't seem
;;; reasonable for the inherited printer to do so. It does seem
;;; reasonable for app code to derive a new condition from
  CL : READER - ERROR ( perhaps for an error in a readmacro ) or
  CL : PARSE - ERROR ( perhaps for an error in an operator
  READ - MY - FAVORITE - DATA - STRUCTURE ) or CL : STREAM - ERROR ( dunno why
  offhand , but perhaps for some Gray - stream - ish reason ) , not define
;;; a :REPORT method for its new condition, and expect to inherit from
;;; the application's printer all the cruft required for describing
;;; the location of the error in the input.)
(define-condition my-stream-error-1-0-9 (stream-error) ())
(define-condition parse-foo-error-1-0-9 (parse-error) ())
(define-condition read-bar-error-1-0-9 (reader-error) ())
(with-test (:name :printable-conditions)
  (let (;; instances created initializing all the slots specified in
  ANSI CL
        (parse-foo-error-1-0-9 (make-condition 'parse-foo-error-1-0-9
                                               :stream *standard-input*))
        (read-foo-error-1-0-9 (make-condition 'read-bar-error-1-0-9
                                              :stream *standard-input*))
        (my-stream-error-1-0-9 (make-condition 'my-stream-error-1-0-9
                                               :stream *standard-input*)))
    ;; should be printable
    (dolist (c (list
                my-stream-error-1-0-9
                parse-foo-error-1-0-9
                read-foo-error-1-0-9))
      ;; whether escaped or not
      (dolist (*print-escape* '(nil t))
        (write c :stream (make-string-output-stream))))))

  Reported by   : restart computation in : TEST - FUNCTION used to
;;; cause infinite recursion.
(defun restart-test-finds-restarts ()
  (restart-bind
      ((bar (lambda ()
              (return-from restart-test-finds-restarts 42))
         :test-function
         (lambda (condition)
           (declare (ignore condition))
           (find-restart 'qux))))
    (when (find-restart 'bar)
      (invoke-restart 'bar))))
(assert (not (restart-test-finds-restarts)))

(with-test (:name :bug-896379)
  (let ((*evaluator-mode* :compile))
    (handler-bind ((style-warning #'error))
      (let ((reader (gensym "READER"))
            (name (gensym "FOO-ERROR")))
        (eval `(define-condition ,name (error)
                 ((slot :initarg :slot :reader ,reader))
                 (:report (lambda (c stream)
                            (format stream "Oops: ~S" (,reader c))))))))))

(with-test (:name :define-condition-result)
  (let ((name (gensym "CONDITION")))
    (assert
     (eq (eval `(define-condition ,name () ()))
         name))))

  bug-1164970

(define-condition condition-with-default-initargs (condition)
  ()
  (:default-initargs :foo 1))

(with-test (:name (sb-mop:class-direct-default-initargs :for-condition-class
                   :bug-1164970))
  ;; CLASS-DIRECT-DEFAULT-INITARGS used to return nil for all
  ;; condition classes.
  (let ((initargs (sb-mop:class-direct-default-initargs
                   (find-class 'condition-with-default-initargs))))
    (assert (equal (subseq (first initargs) 0 2) '(:foo 1)))))

  bug-539517

(defconstant +error-when-called+ (lambda () (error "oops")))

(define-condition condition-with-constant-function-initarg ()
  ((foo :initarg :foo
        :reader condition-with-constant-function-initarg-foo))
  (:default-initargs :foo +error-when-called+))

(with-test (:name (:condition-with-constant-function-initarg :bug-539517))
  ;; The default initarg handling for condition classes used to
  ;; confuse constant functions (thus +ERROR-WHEN-CALLED+) and
  ;; initfunctions. This lead to +ERROR-WHEN-CALLED+ being called as
  ;; if it was an initfunction.
  (assert (functionp
           (condition-with-constant-function-initarg-foo
            (make-condition 'condition-with-constant-function-initarg))))
  (assert (functionp
           (condition-with-constant-function-initarg-foo
            (make-instance 'condition-with-constant-function-initarg)))))

;; Same problem

(define-condition condition-with-constant-function-initform ()
  ((foo :initarg :foo
        :reader condition-with-constant-function-initform-foo
        :initform +error-when-called+)))

(with-test (:name (:condition-with-constant-function-slot-initform))
  (assert (functionp
           (condition-with-constant-function-initform-foo
            (make-condition 'condition-with-constant-function-initform))))
  (assert (functionp
           (condition-with-constant-function-initform-foo
            (make-instance 'condition-with-constant-function-initform)))))

;;; bug-1164969

(defvar bar-counter 0)

(defvar baz-counter 0)

(define-condition condition-with-non-constant-default-initarg ()
  ((bar :initarg :bar
        :reader condition-with-non-constant-default-initarg-bar)
   (baz :initarg :baz
        :reader condition-with-non-constant-default-initarg-baz
        :initform (incf baz-counter)))
  (:default-initargs :bar (incf bar-counter)))
(define-condition condition-with-non-constant-default-initarg ()
  ((bar :initarg :bar
        :reader condition-with-non-constant-default-initarg-bar)
   (baz :initarg :baz
        :reader condition-with-non-constant-default-initarg-baz
        :initform (incf baz-counter)))
  (:default-initargs :bar (incf bar-counter)))

(with-test (:name (:redefining-condition-with-non-constant-default-initarg
                   :bug-1164969))
  ;; Redefining conditions could lead to multiple evaluations of
  ;; initfunctions for slots and default initargs. We need all the
  ;; combinations of make-condition/instance and eval/compile because
  ;; they failed differently.
  (macrolet ((test (case &body body)
               `(progn
                  (setf bar-counter 0
                        baz-counter 0)
                  (let ((instance (progn ,@body)))
                    (assert
                     (= 1 (condition-with-non-constant-default-initarg-bar
                           instance))
                     nil
                     ,(format nil "Assertion failed for default initarg initfunction for ~A"
                              case))
                    (assert
                     (= 1 (condition-with-non-constant-default-initarg-baz
                           instance))
                     nil
                     ,(format nil "Assertion failed for slot initfunction for ~A"
                              case)))
                  (assert (= 1 bar-counter))
                  (assert (= 1 baz-counter)))))

  Go through EVAL to avoid optimizations .
    (test :eval+make-condition
      (eval '(make-condition
              'condition-with-non-constant-default-initarg)))
    (test :eval+make-instance
      (eval '(make-instance
              'condition-with-non-constant-default-initarg)))

    ;; Allow optimizations.
    (test :compile+make-condition
      (make-condition
       'condition-with-non-constant-default-initarg))
    (test :compile+make-instance
      (make-instance
       'condition-with-non-constant-default-initarg))))

  bug-1049404

(define-condition condition-with-class-allocation ()
  ((count :accessor condition-with-class-allocation-count
          :initform 0
          :allocation :class)))

(with-test (:name (:condition-with-class-allocation :bug-1049404))
  (loop repeat 5 do
           (incf (condition-with-class-allocation-count
                  (make-condition 'condition-with-class-allocation))))
  (assert (= 5 (condition-with-class-allocation-count
                (make-condition 'condition-with-class-allocation)))))

;;; bug-789497

(with-test (:name (assert :print-intermediate-results :bug-789497))
  (macrolet ((test (bindings expression expected-message)
               `(let ,bindings
                  (handler-case (assert ,expression)
                    (simple-error (condition)
                      (assert (string= (princ-to-string condition)
                                       ,expected-message)))))))
    ;; Constant and variables => no special report.
    (test () nil "The assertion NIL failed.")
    (test ((a nil)) a "The assertion A failed.")
    ;; Special operators => no special report.
    (test ((a nil) (b nil)) (or a b) "The assertion (OR A B) failed.")
    (test ((a nil) (b t)) (and a b) "The assertion (AND A B) failed.")
    ;; Functions with constant and non-constant arguments => include
    ;; non-constant arguments in report.
    (test ((a t)) (not a) "The assertion (NOT A) failed with A = T.")
    (test () (not t) "The assertion (NOT T) failed.")
    (test ((a -1)) (plusp (signum a))
          "The assertion (PLUSP (SIGNUM A)) failed with (SIGNUM A) = -1.")
    ;; Same for local functions.
    (flet ((my-not (x) (not x))
           (my-plusp (x) (plusp x)))
      (test ((a t)) (my-not a) "The assertion (MY-NOT A) failed with A = T.")
      (test () (my-not t) "The assertion (MY-NOT T) failed.")
      (test ((a -1)) (my-plusp (signum a))
            "The assertion (MY-PLUSP (SIGNUM A)) failed with (SIGNUM A) = -1."))))

  If  thinks it 's checking a function call form , it binds the arguments
;; to local vars so that it can show them on failure. But it would accidentally
;; treat a local macro as a function if its name coincided with a global.
(defun compute (a b) (declare (ignore a b)))
(defun compute-something-else (a b) (list a b))
(defun assert-arg-eval-order (a b)
  (let ((evals))
    (flet ((eval-arg (arg) (setq evals (nconc evals (list arg))) arg))
      (macrolet ((compute (x y z)
                   (declare (ignore y)) ; does not appear in expansion
                   `(compute-something-else ,z ,x)))
        (assert (compute (eval-arg a)
                         (eval-arg (error "bork"))
                         (eval-arg b)))))
    evals))
(with-test (:name :assert-arg-eval-order)
  (assert (equal (assert-arg-eval-order 1 2) '(2 1))))

(with-test (:name (find-restart :recheck-conditions-and-tests :bug-774410))
  (let ((activep t))
    (restart-bind ((switchable-restart
                     (constantly 'irrelevant)
                     :test-function (lambda (condition)
                                      (declare (ignore condition))
                                      activep)))
      (let ((actual-restart (find-restart 'switchable-restart)))
        ;; Active/inactive because of condition-restarts associations.
        (let ((required-condition (make-condition 'condition))
              (wrong-condition (make-condition 'condition)))
          (with-condition-restarts required-condition (list actual-restart)
            (assert (find-restart actual-restart required-condition))
            (assert (not (find-restart actual-restart wrong-condition)))))

        ;; Inactive because of test-function.
        (setf activep nil)
        (assert (not (find-restart actual-restart)))
        (assert (not (find-restart actual-restart (make-condition 'condition))))))))

(macrolet
    ((with-testing-restart ((&key
                               (condition-var (gensym))
                               (condition-restart-p t))
                            &body body)
       `(block block
          (handler-bind ((condition (lambda (,condition-var)
                                      (declare (ignorable ,condition-var))
                                      ,@body)))
            (restart-bind ((testing-restart
                             (lambda () (return-from block :transfer))
                             :test-function (lambda (condition)
                                              (typep condition 'condition))))
              ,(if condition-restart-p
                   `(let ((condition (make-condition 'condition)))
                      (with-condition-restarts condition (car sb-kernel:*restart-clusters*)
                        (signal condition)))
                   `(signal (make-condition 'condition)))
              :no-transfer)))))

  (with-test (:name (invoke-restart :test-function))

    ;; When given a restart name, there is no condition so
  INVOKE - RESTART can not call the : test - function . SBCL considers
    ;; the restart unsuitable for the requested invocation. See
  comment in INVOKE - RESTART .
    (assert-error (with-testing-restart ()
                    (invoke-restart 'testing-restart))
                  control-error)

  When given a RESTART instance ( which could only have been found
    ;; by passing an appropriate condition to FIND-RESTART),
  INVOKE - RESTART does not call the : test - function . Again , see
  comment in INVOKE - RESTART .
    (assert (eq :transfer
                (with-testing-restart (:condition-var condition)
                  (invoke-restart
                   (find-restart 'testing-restart condition)))))

    ;; Some other condition, even if it passes the :test-function,
    ;; only works if the restart has not been associated to the
    ;; original condition.
    (assert (eq :transfer
                (with-testing-restart (:condition-restart-p nil)
                  (invoke-restart
                   (find-restart 'testing-restart (make-condition 'condition))))))
    (with-testing-restart ()
      (assert (not (find-restart 'testing-restart (make-condition 'condition))))))

  (with-test (:name (invoke-restart-interactively :test-function))
    ;; Comments in (INVOKE-RESTART :TEST-FUNCTION) apply here as well.
    (assert-error
     (with-testing-restart ()
       (invoke-restart-interactively 'testing-restart))
     control-error)

    (assert (eq :transfer
                (with-testing-restart (:condition-var condition)
                  (invoke-restart-interactively
                   (find-restart 'testing-restart condition)))))

    (assert (eq :transfer
                (with-testing-restart (:condition-restart-p nil)
                  (invoke-restart-interactively
                   (find-restart 'testing-restart (make-condition 'condition))))))))

(defun case-failure-example (x) (etypecase x (function 1) (symbol 2)))
  The : report method should not print " wanted one of # ' SYMBOL "
(with-test (:name :case-failure-report-pprint-silliness)
  (handler-case (case-failure-example 3)
    (condition (c)
      (let ((str (write-to-string c :escape nil :pretty t)))
        (assert (not (search "#'SYMBOL" str)))))))

(define-condition a-condition-with-a-classy-slot ()
  ((a :allocation :class :initform 'foo)))

(defvar *a-classy-classoid*
  (sb-kernel:find-classoid 'a-condition-with-a-classy-slot))
;; precondition to the test
(assert (= (length (sb-kernel::condition-classoid-class-slots
                    *a-classy-classoid*))
           1))

(define-condition a-condition-with-a-classy-slot ()
  ((b :allocation :class :initform 'baz)
   (a :allocation :class :initform 'foo)))

(with-test (:name :condition-classoid-redef-with-class-slot)
  (assert (= (length (sb-kernel::condition-classoid-class-slots
                      *a-classy-classoid*))
             2)))

(defun some-silly-handler (x) (declare (ignore x)))

;; Note, you should exercise extreme caution when printing *HANDLER-CLUSTERS*
  from the REPL or you will likely confuse yourself .
;; At any point, the clusters are composed of a chain of dx conses.
  One way to print them is like this :
;;  (funcall (lambda () (print sb-kernel::*handler-clusters*) nil))

(with-test (:name :handler-bind-expansion-variations)

  exercise all 3 possibilities for the TEST of a clause
  (handler-bind ((error #'print))
  first cluster , first binding , first part
    (let ((test (caaar sb-kernel:*handler-clusters*)))
      (assert (eq test (sb-kernel:find-classoid-cell 'error)))))
  (locally (declare (muffle-conditions style-warning))
    (handler-bind (((satisfies some-silly-fun) #'print))
      (let ((test (caaar sb-kernel:*handler-clusters*)))
        (assert (eq test 'some-silly-fun)))))
  (handler-bind (((or warning error) #'print))
    (let ((test (caaar sb-kernel:*handler-clusters*)))
      (assert (functionp test))))

  exercise all 3 possibilities for the HANDLER of a clause

  (flet ((frob (x) (print x)))
    (handler-bind ((warning
                    (lambda (c) (frob (frob c)))))
  first cluster , first binding , second part
      (let ((fn (cdaar sb-kernel:*handler-clusters*)))
        (assert (functionp fn)))))

  (handler-bind ((warning 'some-silly-handler))
    (let ((fn (cdaar sb-kernel:*handler-clusters*)))
      ;; the function is stored as an fdefn
      (assert (eq fn 'some-silly-handler))))

  (handler-bind ((warning 'muffle-warning))
    (let ((fn (cdaar sb-kernel:*handler-clusters*)))
      ;; the function is stored directly because it's a builtin.
      (assert (eq fn (symbol-function 'muffle-warning))))))

  Oddly enough , at least one other Lisp considers this example
;; *not* to fail, quite explicitly - the handler function in the
;; handler-cluster is a lambda that returns a function that is
;; the real handler function.
(defun this-should-fail ()
  (declare (muffle-conditions style-warning))
  (declare (optimize safety))
  (handler-bind ((condition #'some-nonexistent-handler))
    (random 100)))

(with-test (:name :handler-bind-evals-handlers-immediately)
  (assert-error (this-should-fail))
  (defun some-nonexistent-handler (x) x)
  (assert (integerp (this-should-fail)))) ; but not now it shouldn't

(defun (setf thing) (a b) (declare (ignore b)) a)

(with-test (:name :undefined-restart
            :skipped-on (not :undefined-fun-restarts))
  (let* ((name (gensym))
         (tail-call (checked-compile `(lambda () (,name)) :allow-style-warnings t))
         (call (checked-compile `(lambda () (1+ (,name))) :allow-style-warnings t))
         (return (checked-compile `(lambda () #',name) :allow-style-warnings t))
         (value-lambda (lambda () 10)))
    (flet ((test-continue (fun)
             (fmakunbound name)
             (handler-bind ((undefined-function
                              (lambda (c)
                                (declare (ignore c))
                                (setf (fdefinition name)
                                      (lambda () 123))
                                (invoke-restart 'continue))))
               (funcall fun)))
           (test-use-value (fun value)
             (fmakunbound name)
             (handler-bind ((undefined-function
                              (lambda (c)
                                (declare (ignore c))
                                (invoke-restart 'use-value value))))
               (funcall fun))))
      (assert (eq (test-continue tail-call) 123))
      (assert (eq (test-continue call) 124))
      (assert (eq (test-continue return) (fdefinition name)))
      (assert (eq (test-use-value tail-call value-lambda) 10))
      (assert (eq (test-use-value call value-lambda) 11))
      (assert (eq (test-use-value return value-lambda) value-lambda))
      (assert (eq (test-use-value return '(setf thing)) #'(setf thing)))
      (assert (eq (test-use-value return #'(setf thing)) #'(setf thing))))))

  Assert that the USE - VALUE restart for SYMBOL - FUNCTION
;;; lets you specify any function.
(with-test (:name :undefined-restart-symbol-function)
  (flet ((test-use-value (value-to-use)
           (let ((f (handler-bind
                        ((undefined-function
                          (lambda (c)
                            (declare (ignore c))
                            (use-value value-to-use))))
                      (symbol-function 'nonexistent-fun))))
             (assert (eq :win (funcall f :win 'whatever))))))
    (test-use-value #'(setf thing))
    (test-use-value '(setf thing))))

(with-test (:name :unknown-key-restart
                  :fails-on :sparc)
  (handler-bind ((sb-ext:unknown-keyword-argument
                   (lambda (c)
                     (assert (eq (sb-ext:unknown-keyword-argument-name c)
                                 :bogus))
                     (continue c))))
    (assert (= (funcall (checked-compile '(lambda (&key abc) (1+ abc)))
                        :bogus 30 :abc 20)
               21))))

(define-condition allocation-class-default-initargs ()
  ((a :initarg :a :initform :initform :allocation :class))
  (:default-initargs :a :default-initarg))

(with-test (:name :allocation-class-default-initargs)
  (assert (eql (slot-value (make-condition 'allocation-class-default-initargs) 'a)
               :default-initarg))
  (assert (eql (slot-value (make-condition 'allocation-class-default-initargs :a 10) 'a)
               10)))

(define-condition allocation-class-unbound ()
  ((a :initarg :a :allocation :class)))

(with-test (:name :allocation-class-unbound)
  (assert-error (slot-value (make-condition 'allocation-class-unbound) 'a)))

(define-condition allocation-class-initarg-order ()
  ((a :initarg :a :initarg :b :allocation :class)))

(with-test (:name :allocation-class-initarg-order)
  (assert (eql (slot-value (make-condition 'allocation-class-initarg-order :a 10 :b 20) 'a)
               10))
  (assert (eql (slot-value (make-condition 'allocation-class-initarg-order :b 10 :a 20) 'a)
               10)))

(defvar *ggg*)
(declaim (integer *ggg*))
(defun ggg+1 () (1+ *ggg*))

(with-test (:name :restart-unbound-variable
                  :skipped-on (not (and (or :arm64 :x86-64) :sb-thread)))
  (handler-bind
      ((type-error
         (lambda (c)
           (assert (eql (type-error-datum c) :nope))
           (use-value 1 c)))
       (unbound-variable
         (lambda (e)
           (store-value :nope e))))
    (assert (eql (ggg+1) 2))))

(with-test (:name :restart-type-error
                  :skipped-on :sparc) ; hangs
  (let ((fun (checked-compile '(lambda (x)
                                (sb-kernel:the* (fixnum :restart t) x)))))
    (handler-bind
        ((type-error
           (lambda (c)
             (use-value 2 c))))
      (assert (eql (funcall fun 'a) 2)))))

 more information.

 files (like this one) were written from scratch after the fork

 This software is in the public domain and is provided with
 absolutely no warranty. See the COPYING and CREDITS files for
 more information.
 Bug from CLOCC.
 /
 This test asserts that:
  - an accessor can shadow an identically-named inherited accessor
     and read/write a different slot
 The PICKY-RESTART should be applicable for the
 PRINT-OBJECT method --- the PRINT-OBJECT code implicitly assumed
 format control, which seems to be a preANSIism.

 (The spec for DEFINE-CONDITION says that if :REPORT is not
 supplied, "information about how to report this type of condition
 forbid the inherited printer from trying to read slots which
 aren't portably specified for the condition, but it doesn't seem
 reasonable for the inherited printer to do so. It does seem
 reasonable for app code to derive a new condition from
 a :REPORT method for its new condition, and expect to inherit from
 the application's printer all the cruft required for describing
 the location of the error in the input.)
 instances created initializing all the slots specified in
 should be printable
 whether escaped or not
 cause infinite recursion.
 CLASS-DIRECT-DEFAULT-INITARGS used to return nil for all
 condition classes.
 The default initarg handling for condition classes used to
 confuse constant functions (thus +ERROR-WHEN-CALLED+) and
 initfunctions. This lead to +ERROR-WHEN-CALLED+ being called as
 if it was an initfunction.
 Same problem
 bug-1164969
 Redefining conditions could lead to multiple evaluations of
 initfunctions for slots and default initargs. We need all the
 combinations of make-condition/instance and eval/compile because
 they failed differently.
 Allow optimizations.
 bug-789497
 Constant and variables => no special report.
 Special operators => no special report.
 Functions with constant and non-constant arguments => include
 non-constant arguments in report.
 Same for local functions.
 to local vars so that it can show them on failure. But it would accidentally
 treat a local macro as a function if its name coincided with a global.
 does not appear in expansion
 Active/inactive because of condition-restarts associations.
 Inactive because of test-function.
 When given a restart name, there is no condition so
 the restart unsuitable for the requested invocation. See
 by passing an appropriate condition to FIND-RESTART),
 Some other condition, even if it passes the :test-function,
 only works if the restart has not been associated to the
 original condition.
 Comments in (INVOKE-RESTART :TEST-FUNCTION) apply here as well.
 precondition to the test
 Note, you should exercise extreme caution when printing *HANDLER-CLUSTERS*
 At any point, the clusters are composed of a chain of dx conses.
  (funcall (lambda () (print sb-kernel::*handler-clusters*) nil))
 the function is stored as an fdefn
 the function is stored directly because it's a builtin.
 *not* to fail, quite explicitly - the handler function in the
 handler-cluster is a lambda that returns a function that is
 the real handler function.
 but not now it shouldn't
 lets you specify any function.
 hangs
  This software is part of the SBCL system . See the README file for
  While most of SBCL is derived from the CMU CL system , the test
  from CMU CL .

(defpackage :p1
  (:use :cl)
  (:export #:code #:code-msg #:%code-msg))
(define-condition p1:code ()
  ((p1::msg :reader p1:code-msg :reader p1:%code-msg :initarg :msg)))

(defpackage :p2
  (:use :cl :p1))
(define-condition p2::code1 (p1:code)
  ((p2::msg :accessor p1:code-msg :initarg :msg)))

   - distinct symbols create distinct slots , unlike with DEFSTRUCT
      where slots are compared by string=
   - two slots can be initialized by one initarg
(with-test (:name :condition-slot-package-confusion)
  (let ((code (make-condition 'p1:code :msg 1)))
    (assert (typep code 'p1:code))
    (assert (eql (p1:code-msg code) 1))
    (assert (eql (p1:%code-msg code) 1)))
  (let ((code (make-condition 'p2::code1 :msg 1)))
    (assert (typep code 'p1:code))
    (assert (eql (p1:code-msg code) 1))
    (assert (eql (p1:%code-msg code) 1))
    (setf (p1:code-msg code) 2)
    (assert (eql (p1:code-msg code) 2))
    (assert (eql (p1:%code-msg code) 1))))

  Check that initializing the condition class metaobject does n't create
  any instances . Reported by   on sbcl - devel Mon , 05 Jul 2004 .
(defvar *condition-count* 0)
(define-condition counted-condition () ((slot :initform (incf *condition-count*))))
  What purpose was this DEFMETHOD serving ? None as far as I can tell .
  ( defmethod frob - counted - condition ( ( x counted - condition ) ) x )
(assert (= 0 *condition-count*))
(assert (typep (sb-mop:class-prototype (find-class 'counted-condition))
               '(and condition counted-condition)))
(opaque-identity (make-condition 'counted-condition))
(assert (= 1 *condition-count*))

(define-condition picky-condition () ())

(with-test (:name (:picky-condition compute-restarts))
  (restart-case
      (handler-case
          (error 'picky-condition)
        (picky-condition (c)
  PICKY - CONDITION and all other cases .
          (assert (eq (restart-name (first (compute-restarts))) 'picky-restart))
          (assert (eq (restart-name (first (compute-restarts c))) 'picky-restart))
          (assert (eq (car (compute-restarts)) (car (compute-restarts c))))
  ANOTHER - PICKY - RESTART should not be applicable for the
  PICKY - CONDITION , but all other cases .
          (assert (not (find 'another-picky-restart (compute-restarts c)
                             :key #'restart-name)))
          (assert (find 'another-picky-restart (compute-restarts)
                        :key #'restart-name))
          :ok))
    (picky-restart ()
      :report "Do nothing."
      :test (lambda (c) (typep c '(or null picky-condition))))
    (another-picky-restart ()
      :report "Do nothing as well"
      :test (lambda (c) (typep c '(not picky-condition))))))

  adapted from   on cmucl - imp
(with-test (:name (:picky-condition invoke-restart))
  (assert (eq 'it
              (restart-case
                  (handler-case
                      (error 'picky-condition)
                    (picky-condition (c)
                      (invoke-restart (find-restart 'give-it c))))
                (give-it ()
                  :test (lambda (c) (typep c 'picky-condition))
                  'it)))))

  In sbcl-1.0.9 , a condition derived from CL : STREAM - ERROR ( or
  CL : READER - ERROR or or CL : PARSE - ERROR ) did n't inherit a usable
  that CL : STREAM - ERROR was like a SIMPLE - CONDITION , with args and
  is inherited from the PARENT - TYPE . " The spec does n't explicitly
  CL : READER - ERROR ( perhaps for an error in a readmacro ) or
  CL : PARSE - ERROR ( perhaps for an error in an operator
  READ - MY - FAVORITE - DATA - STRUCTURE ) or CL : STREAM - ERROR ( dunno why
  offhand , but perhaps for some Gray - stream - ish reason ) , not define
(define-condition my-stream-error-1-0-9 (stream-error) ())
(define-condition parse-foo-error-1-0-9 (parse-error) ())
(define-condition read-bar-error-1-0-9 (reader-error) ())
(with-test (:name :printable-conditions)
  ANSI CL
        (parse-foo-error-1-0-9 (make-condition 'parse-foo-error-1-0-9
                                               :stream *standard-input*))
        (read-foo-error-1-0-9 (make-condition 'read-bar-error-1-0-9
                                              :stream *standard-input*))
        (my-stream-error-1-0-9 (make-condition 'my-stream-error-1-0-9
                                               :stream *standard-input*)))
    (dolist (c (list
                my-stream-error-1-0-9
                parse-foo-error-1-0-9
                read-foo-error-1-0-9))
      (dolist (*print-escape* '(nil t))
        (write c :stream (make-string-output-stream))))))

  Reported by   : restart computation in : TEST - FUNCTION used to
(defun restart-test-finds-restarts ()
  (restart-bind
      ((bar (lambda ()
              (return-from restart-test-finds-restarts 42))
         :test-function
         (lambda (condition)
           (declare (ignore condition))
           (find-restart 'qux))))
    (when (find-restart 'bar)
      (invoke-restart 'bar))))
(assert (not (restart-test-finds-restarts)))

(with-test (:name :bug-896379)
  (let ((*evaluator-mode* :compile))
    (handler-bind ((style-warning #'error))
      (let ((reader (gensym "READER"))
            (name (gensym "FOO-ERROR")))
        (eval `(define-condition ,name (error)
                 ((slot :initarg :slot :reader ,reader))
                 (:report (lambda (c stream)
                            (format stream "Oops: ~S" (,reader c))))))))))

(with-test (:name :define-condition-result)
  (let ((name (gensym "CONDITION")))
    (assert
     (eq (eval `(define-condition ,name () ()))
         name))))

  bug-1164970

(define-condition condition-with-default-initargs (condition)
  ()
  (:default-initargs :foo 1))

(with-test (:name (sb-mop:class-direct-default-initargs :for-condition-class
                   :bug-1164970))
  (let ((initargs (sb-mop:class-direct-default-initargs
                   (find-class 'condition-with-default-initargs))))
    (assert (equal (subseq (first initargs) 0 2) '(:foo 1)))))

  bug-539517

(defconstant +error-when-called+ (lambda () (error "oops")))

(define-condition condition-with-constant-function-initarg ()
  ((foo :initarg :foo
        :reader condition-with-constant-function-initarg-foo))
  (:default-initargs :foo +error-when-called+))

(with-test (:name (:condition-with-constant-function-initarg :bug-539517))
  (assert (functionp
           (condition-with-constant-function-initarg-foo
            (make-condition 'condition-with-constant-function-initarg))))
  (assert (functionp
           (condition-with-constant-function-initarg-foo
            (make-instance 'condition-with-constant-function-initarg)))))


(define-condition condition-with-constant-function-initform ()
  ((foo :initarg :foo
        :reader condition-with-constant-function-initform-foo
        :initform +error-when-called+)))

(with-test (:name (:condition-with-constant-function-slot-initform))
  (assert (functionp
           (condition-with-constant-function-initform-foo
            (make-condition 'condition-with-constant-function-initform))))
  (assert (functionp
           (condition-with-constant-function-initform-foo
            (make-instance 'condition-with-constant-function-initform)))))


(defvar bar-counter 0)

(defvar baz-counter 0)

(define-condition condition-with-non-constant-default-initarg ()
  ((bar :initarg :bar
        :reader condition-with-non-constant-default-initarg-bar)
   (baz :initarg :baz
        :reader condition-with-non-constant-default-initarg-baz
        :initform (incf baz-counter)))
  (:default-initargs :bar (incf bar-counter)))
(define-condition condition-with-non-constant-default-initarg ()
  ((bar :initarg :bar
        :reader condition-with-non-constant-default-initarg-bar)
   (baz :initarg :baz
        :reader condition-with-non-constant-default-initarg-baz
        :initform (incf baz-counter)))
  (:default-initargs :bar (incf bar-counter)))

(with-test (:name (:redefining-condition-with-non-constant-default-initarg
                   :bug-1164969))
  (macrolet ((test (case &body body)
               `(progn
                  (setf bar-counter 0
                        baz-counter 0)
                  (let ((instance (progn ,@body)))
                    (assert
                     (= 1 (condition-with-non-constant-default-initarg-bar
                           instance))
                     nil
                     ,(format nil "Assertion failed for default initarg initfunction for ~A"
                              case))
                    (assert
                     (= 1 (condition-with-non-constant-default-initarg-baz
                           instance))
                     nil
                     ,(format nil "Assertion failed for slot initfunction for ~A"
                              case)))
                  (assert (= 1 bar-counter))
                  (assert (= 1 baz-counter)))))

  Go through EVAL to avoid optimizations .
    (test :eval+make-condition
      (eval '(make-condition
              'condition-with-non-constant-default-initarg)))
    (test :eval+make-instance
      (eval '(make-instance
              'condition-with-non-constant-default-initarg)))

    (test :compile+make-condition
      (make-condition
       'condition-with-non-constant-default-initarg))
    (test :compile+make-instance
      (make-instance
       'condition-with-non-constant-default-initarg))))

  bug-1049404

(define-condition condition-with-class-allocation ()
  ((count :accessor condition-with-class-allocation-count
          :initform 0
          :allocation :class)))

(with-test (:name (:condition-with-class-allocation :bug-1049404))
  (loop repeat 5 do
           (incf (condition-with-class-allocation-count
                  (make-condition 'condition-with-class-allocation))))
  (assert (= 5 (condition-with-class-allocation-count
                (make-condition 'condition-with-class-allocation)))))


(with-test (:name (assert :print-intermediate-results :bug-789497))
  (macrolet ((test (bindings expression expected-message)
               `(let ,bindings
                  (handler-case (assert ,expression)
                    (simple-error (condition)
                      (assert (string= (princ-to-string condition)
                                       ,expected-message)))))))
    (test () nil "The assertion NIL failed.")
    (test ((a nil)) a "The assertion A failed.")
    (test ((a nil) (b nil)) (or a b) "The assertion (OR A B) failed.")
    (test ((a nil) (b t)) (and a b) "The assertion (AND A B) failed.")
    (test ((a t)) (not a) "The assertion (NOT A) failed with A = T.")
    (test () (not t) "The assertion (NOT T) failed.")
    (test ((a -1)) (plusp (signum a))
          "The assertion (PLUSP (SIGNUM A)) failed with (SIGNUM A) = -1.")
    (flet ((my-not (x) (not x))
           (my-plusp (x) (plusp x)))
      (test ((a t)) (my-not a) "The assertion (MY-NOT A) failed with A = T.")
      (test () (my-not t) "The assertion (MY-NOT T) failed.")
      (test ((a -1)) (my-plusp (signum a))
            "The assertion (MY-PLUSP (SIGNUM A)) failed with (SIGNUM A) = -1."))))

  If  thinks it 's checking a function call form , it binds the arguments
(defun compute (a b) (declare (ignore a b)))
(defun compute-something-else (a b) (list a b))
(defun assert-arg-eval-order (a b)
  (let ((evals))
    (flet ((eval-arg (arg) (setq evals (nconc evals (list arg))) arg))
      (macrolet ((compute (x y z)
                   `(compute-something-else ,z ,x)))
        (assert (compute (eval-arg a)
                         (eval-arg (error "bork"))
                         (eval-arg b)))))
    evals))
(with-test (:name :assert-arg-eval-order)
  (assert (equal (assert-arg-eval-order 1 2) '(2 1))))

(with-test (:name (find-restart :recheck-conditions-and-tests :bug-774410))
  (let ((activep t))
    (restart-bind ((switchable-restart
                     (constantly 'irrelevant)
                     :test-function (lambda (condition)
                                      (declare (ignore condition))
                                      activep)))
      (let ((actual-restart (find-restart 'switchable-restart)))
        (let ((required-condition (make-condition 'condition))
              (wrong-condition (make-condition 'condition)))
          (with-condition-restarts required-condition (list actual-restart)
            (assert (find-restart actual-restart required-condition))
            (assert (not (find-restart actual-restart wrong-condition)))))

        (setf activep nil)
        (assert (not (find-restart actual-restart)))
        (assert (not (find-restart actual-restart (make-condition 'condition))))))))

(macrolet
    ((with-testing-restart ((&key
                               (condition-var (gensym))
                               (condition-restart-p t))
                            &body body)
       `(block block
          (handler-bind ((condition (lambda (,condition-var)
                                      (declare (ignorable ,condition-var))
                                      ,@body)))
            (restart-bind ((testing-restart
                             (lambda () (return-from block :transfer))
                             :test-function (lambda (condition)
                                              (typep condition 'condition))))
              ,(if condition-restart-p
                   `(let ((condition (make-condition 'condition)))
                      (with-condition-restarts condition (car sb-kernel:*restart-clusters*)
                        (signal condition)))
                   `(signal (make-condition 'condition)))
              :no-transfer)))))

  (with-test (:name (invoke-restart :test-function))

  INVOKE - RESTART can not call the : test - function . SBCL considers
  comment in INVOKE - RESTART .
    (assert-error (with-testing-restart ()
                    (invoke-restart 'testing-restart))
                  control-error)

  When given a RESTART instance ( which could only have been found
  INVOKE - RESTART does not call the : test - function . Again , see
  comment in INVOKE - RESTART .
    (assert (eq :transfer
                (with-testing-restart (:condition-var condition)
                  (invoke-restart
                   (find-restart 'testing-restart condition)))))

    (assert (eq :transfer
                (with-testing-restart (:condition-restart-p nil)
                  (invoke-restart
                   (find-restart 'testing-restart (make-condition 'condition))))))
    (with-testing-restart ()
      (assert (not (find-restart 'testing-restart (make-condition 'condition))))))

  (with-test (:name (invoke-restart-interactively :test-function))
    (assert-error
     (with-testing-restart ()
       (invoke-restart-interactively 'testing-restart))
     control-error)

    (assert (eq :transfer
                (with-testing-restart (:condition-var condition)
                  (invoke-restart-interactively
                   (find-restart 'testing-restart condition)))))

    (assert (eq :transfer
                (with-testing-restart (:condition-restart-p nil)
                  (invoke-restart-interactively
                   (find-restart 'testing-restart (make-condition 'condition))))))))

(defun case-failure-example (x) (etypecase x (function 1) (symbol 2)))
  The : report method should not print " wanted one of # ' SYMBOL "
(with-test (:name :case-failure-report-pprint-silliness)
  (handler-case (case-failure-example 3)
    (condition (c)
      (let ((str (write-to-string c :escape nil :pretty t)))
        (assert (not (search "#'SYMBOL" str)))))))

(define-condition a-condition-with-a-classy-slot ()
  ((a :allocation :class :initform 'foo)))

(defvar *a-classy-classoid*
  (sb-kernel:find-classoid 'a-condition-with-a-classy-slot))
(assert (= (length (sb-kernel::condition-classoid-class-slots
                    *a-classy-classoid*))
           1))

(define-condition a-condition-with-a-classy-slot ()
  ((b :allocation :class :initform 'baz)
   (a :allocation :class :initform 'foo)))

(with-test (:name :condition-classoid-redef-with-class-slot)
  (assert (= (length (sb-kernel::condition-classoid-class-slots
                      *a-classy-classoid*))
             2)))

(defun some-silly-handler (x) (declare (ignore x)))

  from the REPL or you will likely confuse yourself .
  One way to print them is like this :

(with-test (:name :handler-bind-expansion-variations)

  exercise all 3 possibilities for the TEST of a clause
  (handler-bind ((error #'print))
  first cluster , first binding , first part
    (let ((test (caaar sb-kernel:*handler-clusters*)))
      (assert (eq test (sb-kernel:find-classoid-cell 'error)))))
  (locally (declare (muffle-conditions style-warning))
    (handler-bind (((satisfies some-silly-fun) #'print))
      (let ((test (caaar sb-kernel:*handler-clusters*)))
        (assert (eq test 'some-silly-fun)))))
  (handler-bind (((or warning error) #'print))
    (let ((test (caaar sb-kernel:*handler-clusters*)))
      (assert (functionp test))))

  exercise all 3 possibilities for the HANDLER of a clause

  (flet ((frob (x) (print x)))
    (handler-bind ((warning
                    (lambda (c) (frob (frob c)))))
  first cluster , first binding , second part
      (let ((fn (cdaar sb-kernel:*handler-clusters*)))
        (assert (functionp fn)))))

  (handler-bind ((warning 'some-silly-handler))
    (let ((fn (cdaar sb-kernel:*handler-clusters*)))
      (assert (eq fn 'some-silly-handler))))

  (handler-bind ((warning 'muffle-warning))
    (let ((fn (cdaar sb-kernel:*handler-clusters*)))
      (assert (eq fn (symbol-function 'muffle-warning))))))

  Oddly enough , at least one other Lisp considers this example
(defun this-should-fail ()
  (declare (muffle-conditions style-warning))
  (declare (optimize safety))
  (handler-bind ((condition #'some-nonexistent-handler))
    (random 100)))

(with-test (:name :handler-bind-evals-handlers-immediately)
  (assert-error (this-should-fail))
  (defun some-nonexistent-handler (x) x)

(defun (setf thing) (a b) (declare (ignore b)) a)

(with-test (:name :undefined-restart
            :skipped-on (not :undefined-fun-restarts))
  (let* ((name (gensym))
         (tail-call (checked-compile `(lambda () (,name)) :allow-style-warnings t))
         (call (checked-compile `(lambda () (1+ (,name))) :allow-style-warnings t))
         (return (checked-compile `(lambda () #',name) :allow-style-warnings t))
         (value-lambda (lambda () 10)))
    (flet ((test-continue (fun)
             (fmakunbound name)
             (handler-bind ((undefined-function
                              (lambda (c)
                                (declare (ignore c))
                                (setf (fdefinition name)
                                      (lambda () 123))
                                (invoke-restart 'continue))))
               (funcall fun)))
           (test-use-value (fun value)
             (fmakunbound name)
             (handler-bind ((undefined-function
                              (lambda (c)
                                (declare (ignore c))
                                (invoke-restart 'use-value value))))
               (funcall fun))))
      (assert (eq (test-continue tail-call) 123))
      (assert (eq (test-continue call) 124))
      (assert (eq (test-continue return) (fdefinition name)))
      (assert (eq (test-use-value tail-call value-lambda) 10))
      (assert (eq (test-use-value call value-lambda) 11))
      (assert (eq (test-use-value return value-lambda) value-lambda))
      (assert (eq (test-use-value return '(setf thing)) #'(setf thing)))
      (assert (eq (test-use-value return #'(setf thing)) #'(setf thing))))))

  Assert that the USE - VALUE restart for SYMBOL - FUNCTION
(with-test (:name :undefined-restart-symbol-function)
  (flet ((test-use-value (value-to-use)
           (let ((f (handler-bind
                        ((undefined-function
                          (lambda (c)
                            (declare (ignore c))
                            (use-value value-to-use))))
                      (symbol-function 'nonexistent-fun))))
             (assert (eq :win (funcall f :win 'whatever))))))
    (test-use-value #'(setf thing))
    (test-use-value '(setf thing))))

(with-test (:name :unknown-key-restart
                  :fails-on :sparc)
  (handler-bind ((sb-ext:unknown-keyword-argument
                   (lambda (c)
                     (assert (eq (sb-ext:unknown-keyword-argument-name c)
                                 :bogus))
                     (continue c))))
    (assert (= (funcall (checked-compile '(lambda (&key abc) (1+ abc)))
                        :bogus 30 :abc 20)
               21))))

(define-condition allocation-class-default-initargs ()
  ((a :initarg :a :initform :initform :allocation :class))
  (:default-initargs :a :default-initarg))

(with-test (:name :allocation-class-default-initargs)
  (assert (eql (slot-value (make-condition 'allocation-class-default-initargs) 'a)
               :default-initarg))
  (assert (eql (slot-value (make-condition 'allocation-class-default-initargs :a 10) 'a)
               10)))

(define-condition allocation-class-unbound ()
  ((a :initarg :a :allocation :class)))

(with-test (:name :allocation-class-unbound)
  (assert-error (slot-value (make-condition 'allocation-class-unbound) 'a)))

(define-condition allocation-class-initarg-order ()
  ((a :initarg :a :initarg :b :allocation :class)))

(with-test (:name :allocation-class-initarg-order)
  (assert (eql (slot-value (make-condition 'allocation-class-initarg-order :a 10 :b 20) 'a)
               10))
  (assert (eql (slot-value (make-condition 'allocation-class-initarg-order :b 10 :a 20) 'a)
               10)))

(defvar *ggg*)
(declaim (integer *ggg*))
(defun ggg+1 () (1+ *ggg*))

(with-test (:name :restart-unbound-variable
                  :skipped-on (not (and (or :arm64 :x86-64) :sb-thread)))
  (handler-bind
      ((type-error
         (lambda (c)
           (assert (eql (type-error-datum c) :nope))
           (use-value 1 c)))
       (unbound-variable
         (lambda (e)
           (store-value :nope e))))
    (assert (eql (ggg+1) 2))))

(with-test (:name :restart-type-error
  (let ((fun (checked-compile '(lambda (x)
                                (sb-kernel:the* (fixnum :restart t) x)))))
    (handler-bind
        ((type-error
           (lambda (c)
             (use-value 2 c))))
      (assert (eql (funcall fun 'a) 2)))))
