;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Mon Feb 23 04:41:29 2004
;;;; Contains: Tests of COPY-PPRINT-DISPATCH



(deftest copy-pprint-dispatch.1
  (with-standard-io-syntax
   (let ((obj '(foo bar))
         (*package* (find-package :cl-test))
         (*print-readably* nil)
         (*print-pretty* t))
     (values
      (prin1-to-string obj)
      (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
        (set-pprint-dispatch
         `(eql ,obj)
         #'(lambda (s obj2) (let ((*print-pretty* nil))
                              (format s "#.'~S" obj2))))
        (prin1-to-string obj))
     (prin1-to-string obj))))
  "(FOO BAR)"
  "#.'(FOO BAR)"
  "(FOO BAR)")

(deftest copy-pprint-dispatch.2
  (with-standard-io-syntax
   (let ((obj '(foo bar))
         (*package* (find-package :cl-test))
         (*print-readably* nil)
         (*print-pretty* t))
     (values
      (prin1-to-string obj)
      (let ((*print-pprint-dispatch* (copy-pprint-dispatch
                                      *print-pprint-dispatch*)))
        (set-pprint-dispatch
         `(eql ,obj)
         #'(lambda (s obj2) (let ((*print-pretty* nil))
                              (format s "#.'~S" obj2))))
        (prin1-to-string obj))
      (prin1-to-string obj))))
  "(FOO BAR)"
  "#.'(FOO BAR)"
  "(FOO BAR)")

(deftest copy-pprint-dispatch.3
  (with-standard-io-syntax
   (let ((obj '(foo bar))
         (*package* (find-package :cl-test))
         (*print-readably* nil)
         (*print-pretty* t))
     (values
      (prin1-to-string obj)
      (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)))
        (set-pprint-dispatch
         `(eql ,obj)
         #'(lambda (s obj2) (let ((*print-pretty* nil))
                              (format s "#.'~S" obj2))))
        (prin1-to-string obj))
      (prin1-to-string obj))))
  "(FOO BAR)"
  "#.'(FOO BAR)"
  "(FOO BAR)")

(deftest copy-pprint-dispatch.4
  (with-standard-io-syntax
   (let ((obj '(foo bar))
         (*package* (find-package :cl-test))
         (*print-readably* nil)
         (*print-pretty* t))
     (values
      (prin1-to-string obj)
      (let ((table (copy-pprint-dispatch)))
        (set-pprint-dispatch
         `(eql ,obj)
         #'(lambda (s obj2) (let ((*print-pretty* nil))
                              (format s "#.'~S" obj2)))
         0
         table)
        (let ((*print-pprint-dispatch* (copy-pprint-dispatch table)))
          (prin1-to-string obj)))
      (prin1-to-string obj))))
  "(FOO BAR)"
  "#.'(FOO BAR)"
  "(FOO BAR)")

(deftest copy-pprint-dispatch.5
  (let ((new-table (copy-pprint-dispatch)))
    (values
     (eql new-table *print-pprint-dispatch*)
     (member new-table *universe*)))
  nil nil)

(deftest copy-pprint-dispatch.6
  (let ((new-table (copy-pprint-dispatch *print-pprint-dispatch*)))
    (values
     (eql new-table *print-pprint-dispatch*)
     (member new-table *universe*)))
  nil nil)

(deftest copy-pprint-dispatch.7
  (let ((new-table (copy-pprint-dispatch nil)))
    (values
     (eql new-table *print-pprint-dispatch*)
     (member new-table *universe*)))
  nil nil)


(deftest copy-pprint-dispatch.8
  (let* ((table1 (copy-pprint-dispatch))
         (table2 (copy-pprint-dispatch table1)))
    (eql table1 table2))
  nil)

;;; Error tests

(deftest copy-pprint-dispatch.error.1
  (signals-error (copy-pprint-dispatch nil nil) program-error)
  t)

(deftest copy-pprint-dispatch.error.2
  (check-type-error #'copy-pprint-dispatch #'null)
  nil)