Commit ec579775 authored by pfdietz's avatar pfdietz

Add more symbol printing tests. Some of them are suspect, so they're commented out for now.

parent d08d197b
......@@ -408,3 +408,163 @@
(%p '|1| :invert :capitalize '("1" "\\1" "|1|"))
))))
t t t t t t t t t t t t)
;;; Random symbol printing tests when *print-escape* is true
;;; and *print-readably* is false.
;;; I AM NOT SURE THESE ARE CORRECT, SO THEY ARE COMMENTED OUT FOR NOW -- PFD
#|
(deftest print.symbol.escaped-random.1
(let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE"))
(when (find-package pkg-name)
(delete-package pkg-name))
(prog1
(let ((*package* (make-package pkg-name))
(result
(loop for c across +standard-chars+
for s = (intern (string c))
append
(loop repeat 50
nconc (randomly-check-readability
s
:readable nil
:escape t)))))
(subseq result 0 (min (length result) 10)))
;; (delete-package pkg-name)
))
nil)
(deftest print.symbol.escaped-random.2
(let ((result
(loop for c across +standard-chars+
for s = (make-symbol (string c))
nconc
(loop repeat 50
nconc (randomly-check-readability
s
:readable nil
:escape t
:gensym t
:test #'similar-uninterned-symbols)))))
(subseq result 0 (min (length result) 10)))
nil)
(deftest print.symbol.escaped-random.3
(let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE"))
(when (find-package pkg-name)
(delete-package pkg-name))
(prog1
(let ((*package* (make-package pkg-name))
(result
(loop for i below 256
for c = (code-char i)
when c
nconc
(let ((s (intern (string c))))
(loop repeat 50
nconc (randomly-check-readability
s
:readable nil
:escape t))))))
(subseq result 0 (min (length result) 10)))
;; (delete-package pkg-name)
))
nil)
(deftest print.symbol.escaped-random.4
(let ((result
(loop for i below 256
for c = (code-char i)
when c
nconc
(let ((s (make-symbol (string c))))
(loop repeat 50
nconc (randomly-check-readability
s
:readable nil
:escape t
:gensym t
:test #'similar-uninterned-symbols))))))
(subseq result 0 (min (length result) 10)))
nil)
(deftest print.symbol.escaped-random.5
(loop for s in *universe*
when (and (symbolp s) (symbol-package s) )
nconc
(loop repeat 50
nconc (randomly-check-readability
s
:readable nil
:escape t)))
nil)
(deftest print.symbol.escaped-random.6
(let ((*package* (find-package "KEYWORD")))
(loop for s in *universe*
when (and (symbolp s) (symbol-package s))
nconc
(loop repeat 50
nconc (randomly-check-readability
s
:readable nil
:escape t))))
nil)
(deftest print.symbol.escaped-random.7
(loop for s in *universe*
when (and (symbolp s) (not (symbol-package s)))
nconc
(loop repeat 50
nconc (randomly-check-readability
s
:readable nil
:escape t
:gensym t
:test #'similar-uninterned-symbols)))
nil)
(deftest print.symbol.escaped-random.8
(let ((*package* (find-package "KEYWORD")))
(loop for s in *universe*
when (and (symbolp s) (not (symbol-package s)))
nconc
(loop repeat 50
nconc (randomly-check-readability
s
:readable nil
:escape t
:gensym t
:test #'similar-uninterned-symbols))))
nil)
(deftest print.symbol.escaped.9
(let* ((*package* (find-package "CL-TEST"))
(s (intern "()")))
(randomly-check-readability s :readable nil :escape t))
nil)
(deftest print.symbol.escaped.10
(let* ((*package* (find-package "KEYWORD"))
(s (intern "()")))
(randomly-check-readability s :readable nil :escape t))
nil)
|#
;;; Tests of printing package prefixes
(deftest print.symbol.prefix.1
(with-standard-io-syntax
(let ((s (write-to-string (make-symbol "ABC") :gensym t :case :upcase)))
(if (string= s "#:ABC") t s)))
t)
(deftest print.symbol.prefix.2
(with-standard-io-syntax
(let ((s (write-to-string (make-symbol "ABC") :gensym nil :case :upcase)))
(if (string= s "ABC") t s)))
t)
\ No newline at end of file
......@@ -22,7 +22,11 @@
;;; the object and the printer variable bindings otherwise. They key
;;; argument TEST is used to compared the reread object and obj.
(defun randomly-check-readability (obj &key (test #'equal))
(defun randomly-check-readability (obj &key
(test #'equal)
(readable t)
(escape nil escape-p)
(gensym nil gensym-p))
(declare (type function test))
;; Generate random printer-control values
(with-standard-io-syntax
......@@ -31,15 +35,15 @@
(*print-radix* (coin))
(*print-case* (random-from-seq #(:upcase :downcase :capitalize)))
(*print-circle* (coin))
(*print-escape* (coin))
(*print-gensym* (coin))
(*print-escape* (if escape-p escape (coin)))
(*print-gensym* (if gensym-p gensym (coin)))
(*print-level* (random 50))
(*print-length* (random 50))
(*print-lines* (random 50))
(*print-length* (if readable (random 50) nil))
(*print-lines* (if readable (random 50) nil))
(*print-miser-width* (and (coin) (random 100)))
(*print-pretty* (coin))
(*print-right-margin* (and (coin) (random 100)))
(*print-readably* t)
(*print-readably* readable)
(*read-default-float-format* (rcase (1 'short-float) (1 'single-float)
(1 'double-float) (1 'long-float)
(1 *read-default-float-format*)))
......@@ -50,13 +54,14 @@
(let* ((str (with-output-to-string (s) (write obj :stream s)))
(obj2 (let ((*read-base* *print-base*))
(handler-case
(let ((*readtable* (copy-readtable nil)))
(let ((*readtable* (if *print-readably* (copy-readtable nil)
*readtable*)))
(read-from-string str))
(reader-error () :error)))))
(unless (funcall test obj obj2)
(list
(list obj str obj2
;; Note: (*print-readably* t) always holds
(list '*print-readably* *print-readably*)
(list '*print-array* *print-array*)
(list '*print-base* *print-base*)
(list '*print-radix* *print-radix*)
......@@ -126,3 +131,11 @@
always
(and (if is-escaped1 is-escaped2 t)
(char= c1 c2)))))
(defun similar-uninterned-symbols (s1 s2)
(and (symbolp s1)
(symbolp s2)
(null (symbol-package s1))
(null (symbol-package s2))
(string= (symbol-name s1)
(symbol-name s2))))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment