copy-pprint-dispatch.lsp 3.44 KB
Newer Older
pfdietz's avatar
pfdietz committed
1 2 3 4 5 6 7 8
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Mon Feb 23 04:41:29 2004
;;;; Contains: Tests of COPY-PPRINT-DISPATCH

(in-package :cl-test)

(deftest copy-pprint-dispatch.1
9 10
  (with-standard-io-syntax
   (let ((obj '(foo bar))
sds's avatar
sds committed
11 12 13
         (*package* (find-package :cl-test))
         (*print-readably* nil)
         (*print-pretty* t))
14 15 16
     (values
      (prin1-to-string obj)
      (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
sds's avatar
sds committed
17 18 19 20 21
        (set-pprint-dispatch
         `(eql ,obj)
         #'(lambda (s obj2) (let ((*print-pretty* nil))
                              (format s "#.'~S" obj2))))
        (prin1-to-string obj))
22
     (prin1-to-string obj))))
pfdietz's avatar
pfdietz committed
23 24 25 26 27
  "(FOO BAR)"
  "#.'(FOO BAR)"
  "(FOO BAR)")

(deftest copy-pprint-dispatch.2
28 29
  (with-standard-io-syntax
   (let ((obj '(foo bar))
sds's avatar
sds committed
30 31 32
         (*package* (find-package :cl-test))
         (*print-readably* nil)
         (*print-pretty* t))
33 34 35
     (values
      (prin1-to-string obj)
      (let ((*print-pprint-dispatch* (copy-pprint-dispatch
sds's avatar
sds committed
36 37 38 39 40 41
                                      *print-pprint-dispatch*)))
        (set-pprint-dispatch
         `(eql ,obj)
         #'(lambda (s obj2) (let ((*print-pretty* nil))
                              (format s "#.'~S" obj2))))
        (prin1-to-string obj))
42
      (prin1-to-string obj))))
pfdietz's avatar
pfdietz committed
43 44 45 46 47
  "(FOO BAR)"
  "#.'(FOO BAR)"
  "(FOO BAR)")

(deftest copy-pprint-dispatch.3
48 49
  (with-standard-io-syntax
   (let ((obj '(foo bar))
sds's avatar
sds committed
50 51 52
         (*package* (find-package :cl-test))
         (*print-readably* nil)
         (*print-pretty* t))
53 54 55
     (values
      (prin1-to-string obj)
      (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)))
sds's avatar
sds committed
56 57 58 59 60
        (set-pprint-dispatch
         `(eql ,obj)
         #'(lambda (s obj2) (let ((*print-pretty* nil))
                              (format s "#.'~S" obj2))))
        (prin1-to-string obj))
61
      (prin1-to-string obj))))
pfdietz's avatar
pfdietz committed
62 63 64 65 66
  "(FOO BAR)"
  "#.'(FOO BAR)"
  "(FOO BAR)")

(deftest copy-pprint-dispatch.4
67 68
  (with-standard-io-syntax
   (let ((obj '(foo bar))
sds's avatar
sds committed
69 70 71
         (*package* (find-package :cl-test))
         (*print-readably* nil)
         (*print-pretty* t))
72 73 74
     (values
      (prin1-to-string obj)
      (let ((table (copy-pprint-dispatch)))
sds's avatar
sds committed
75 76 77 78 79 80 81 82
        (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)))
83
      (prin1-to-string obj))))
pfdietz's avatar
pfdietz committed
84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111
  "(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))
sds's avatar
sds committed
112
         (table2 (copy-pprint-dispatch table1)))
pfdietz's avatar
pfdietz committed
113 114 115 116 117 118 119 120 121 122
    (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
123
  (check-type-error #'copy-pprint-dispatch #'null)
pfdietz's avatar
pfdietz committed
124
  nil)