From 6100caa66384151bfcc93435b4c00fbd4268436b Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Sun, 27 Jun 2004 03:03:59 +0000
Subject: [PATCH] More pprint-fill tests, and pprint-linear tests.

---
 ansi-tests/load-printer.lsp  |   3 +-
 ansi-tests/pprint-fill.lsp   | 131 +++++++++++++++++++++++------------
 ansi-tests/pprint-linear.lsp | 129 ++++++++++++++++++++++++++++++++++
 3 files changed, 218 insertions(+), 45 deletions(-)
 create mode 100644 ansi-tests/pprint-linear.lsp

diff --git a/ansi-tests/load-printer.lsp b/ansi-tests/load-printer.lsp
index 9b6bfb24..fe47830b 100644
--- a/ansi-tests/load-printer.lsp
+++ b/ansi-tests/load-printer.lsp
@@ -26,4 +26,5 @@
 (load "print-structure.lsp")
 (load "printer-control-vars.lsp")
 (load "pprint-dispatch.lsp")
-(load "pprint-fill.lsp")
\ No newline at end of file
+(load "pprint-fill.lsp")
+(load "pprint-linear.lsp")
\ No newline at end of file
diff --git a/ansi-tests/pprint-fill.lsp b/ansi-tests/pprint-fill.lsp
index 84055e12..a33bb827 100644
--- a/ansi-tests/pprint-fill.lsp
+++ b/ansi-tests/pprint-fill.lsp
@@ -14,7 +14,9 @@
 	   nconc
 	   (and (not (listp obj))
 		(let ((s1 (write-to-string obj))
-		      (s2 (with-output-to-string (s) (assert (null (pprint-fill s obj))))))
+		      (s2 (with-output-to-string (s) (assert (equal (multiple-value-list
+								     (pprint-fill s obj))
+								    '(nil))))))
 		  (unless (equal s1 s2)
 		    (list (list obj s1 s2))))))))
   nil)
@@ -27,66 +29,107 @@
 	   nconc
 	   (and (not (listp obj))
 		(let ((s1 (write-to-string obj))
-		      (s2 (with-output-to-string (s) (assert (null (pprint-fill s obj))))))
+		      (s2 (with-output-to-string (s) (assert (equal (multiple-value-list
+								     (pprint-fill s obj))
+								    '(nil))))))
 		  (unless (equal s1 s2)
 		    (list (list obj s1 s2))))))))
   nil)
 
-(deftest pprint-fill.3
+(defmacro def-pprint-fill-test (name args expected-value &key (margin 100) (circle nil))
+  `(deftest ,name
+     (let ((*print-pretty* t)
+	   (*print-readably* nil)
+	   (*print-right-margin* ,margin)
+	   (*print-circle* ,circle))
+       (with-output-to-string
+	 (s)
+	 (assert (equal '(nil) (multiple-value-list (pprint-fill s ,@args))))))
+     ,expected-value))
+
+(def-pprint-fill-test pprint-fill.3 ('(cl-user::|A|)) "(A)")
+(def-pprint-fill-test pprint-fill.4 ('(cl-user::|A|) t) "(A)")
+(def-pprint-fill-test pprint-fill.5 ('(cl-user::|A|) nil) "A")
+(def-pprint-fill-test pprint-fill.6 ('(1 2 3 4 5)) "(1 2 3 4 5)")
+(def-pprint-fill-test pprint-fill.7 ('((1) (2) #(3) "abc" 5) nil) "(1) (2) #(3) \"abc\" 5")
+
+;;; The fourth argument is ignored
+(def-pprint-fill-test pprint-fill.8 ('(1 2 3 4 5) t nil) "(1 2 3 4 5)")
+(def-pprint-fill-test pprint-fill.9 ('(1 2 3 4 5) nil t) "1 2 3 4 5")
+
+;;; Takes T, NIL as stream designators
+
+(deftest pprint-fill.10
   (my-with-standard-io-syntax
    (let ((*print-pretty* nil)
 	 (*print-readably* nil)
 	 (*print-right-margin* 100))
-     (with-output-to-string
-       (s)
-       (assert (null (pprint-fill s '(cl-user::|A|)))))))
-  "(A)")
+     (with-output-to-string (*terminal-io*) (pprint-fill t '(1 2 3)))))
+  "(1 2 3)")
 
-(deftest pprint-fill.4
+(deftest pprint-fill.11
   (my-with-standard-io-syntax
-   (let ((*print-pretty* nil)
+   (let ((*print-pretty* t)
 	 (*print-readably* nil)
 	 (*print-right-margin* 100))
-     (with-output-to-string
-       (s)
-       (assert (null (pprint-fill s '(cl-user::|A|) t))))))
-  "(A)")
+     (with-output-to-string (*standard-output*) (pprint-fill nil '(1 2 3)))))
+  "(1 2 3)")
 
-(deftest pprint-fill.5
-  (my-with-standard-io-syntax
-   (let ((*print-pretty* nil)
-	 (*print-readably* nil)
-	 (*print-right-margin* 100))
-     (with-output-to-string
-       (s)
-       (assert (null (pprint-fill s '(cl-user::|A|) nil))))))
-  "A")
 
-(deftest pprint-fill.6
-  (my-with-standard-io-syntax
-   (let ((*print-pretty* nil)
-	 (*print-readably* nil)
-	 (*print-right-margin* 100))
-     (with-output-to-string
-       (s)
-       (assert (null (pprint-fill s '(1 2 3 4 5)))))))
-  "(1 2 3 4 5)")
+;;; Now tests for cases that should be wrapped
+;;; It's not entirely clear what they should be doing
+;;; but check for some obvious properties
 
-(deftest pprint-fill.7
+(deftest pprint-fill.12
   (my-with-standard-io-syntax
-   (let ((*print-pretty* nil)
+   (let ((*print-pretty* t)
 	 (*print-readably* nil)
-	 (*print-right-margin* 100))
-     (with-output-to-string
-       (s)
-       (assert (null (pprint-fill s '((1) (2) #(3) "abc" 5) nil))))))
-  "(1) (2) #(3) \"abc\" 5")
-
-
-
-
-
-
+	 (*package* (find-package :cl-test))
+	 (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M|)))
+     (loop for i from 1 to 10
+	   for result =
+	   (let* ((*print-right-margin* i)
+		  (s (with-output-to-string (os)
+					    (terpri os)
+					    (pprint-fill os obj))))
+	     (cond
+	      ((not (eql (elt s 0) #\Newline))
+	       (list :bad1 s))
+	      ((not (equal (read-from-string s) obj))
+	       (list :bad2 s))
+	      ((not (find #\Newline s :start 1))
+	       (list :bad3 s))
+	      (t t)))
+	   unless (eql result t)
+	   collect (list i result))))
+  nil)
 
 
+(deftest pprint-fill.13
+  (my-with-standard-io-syntax
+   (let ((*print-pretty* t)
+	 (*print-readably* nil)
+	 (*package* (find-package :cl-test))
+	 (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M| |M|)))
+     (loop for i from 1 to 10
+	   for result =
+	   (let* ((*print-right-margin* i)
+		  (s (with-output-to-string (os)
+					    (terpri os)
+					    (pprint-fill os obj nil))))
+	     (cond
+	      ((not (eql (elt s 0) #\Newline))
+	       (list :bad1 s))
+	      ((not (equal (read-from-string (concatenate 'string "(" s ")"))
+			   obj))
+	       (list :bad2 s))
+	      ((not (find #\Newline s :start 1))
+	       (list :bad3 s))
+	      (t t)))
+	   unless (eql result t)
+	   collect (list i result))))
+  nil)
 
+;;; 
+(def-pprint-fill-test pprint-fill.14 ((let ((x (list 'CL-USER::|A|))) (list x x)))
+  "(#1=(A) #1#)" :circle t)
diff --git a/ansi-tests/pprint-linear.lsp b/ansi-tests/pprint-linear.lsp
new file mode 100644
index 00000000..f29f6956
--- /dev/null
+++ b/ansi-tests/pprint-linear.lsp
@@ -0,0 +1,129 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Jun 26 21:55:26 2004
+;;;; Contains: Tests of PPRINT-LINEAR
+
+(in-package :cl-test)
+
+;;; When printing a non-list, the result is the same as calling WRITE."
+(deftest pprint-linear.1
+  (my-with-standard-io-syntax
+   (let ((*print-pretty* t)
+	 (*print-readably* nil))
+     (loop for obj in *mini-universe*
+	   nconc
+	   (and (not (listp obj))
+		(let ((s1 (write-to-string obj))
+		      (s2 (with-output-to-string (s) (assert (equal (multiple-value-list
+								     (pprint-linear s obj))
+								    '(nil))))))
+		  (unless (equal s1 s2)
+		    (list (list obj s1 s2))))))))
+  nil)
+
+(deftest pprint-linear.2
+  (my-with-standard-io-syntax
+   (let ((*print-pretty* nil)
+	 (*print-readably* nil))
+     (loop for obj in *mini-universe*
+	   nconc
+	   (and (not (listp obj))
+		(let ((s1 (write-to-string obj))
+		      (s2 (with-output-to-string (s) (assert (equal (multiple-value-list
+								     (pprint-linear s obj))
+								    '(nil))))))
+		  (unless (equal s1 s2)
+		    (list (list obj s1 s2))))))))
+  nil)
+
+(defmacro def-pprint-linear-test (name args expected-value &key (margin 100) (circle nil))
+  `(deftest ,name
+     (let ((*print-pretty* t)
+	   (*print-readably* nil)
+	   (*print-right-margin* ,margin)
+	   (*print-circle* ,circle))
+       (with-output-to-string
+	 (s)
+	 (assert (equal '(nil) (multiple-value-list (pprint-linear s ,@args))))))
+     ,expected-value))
+
+(def-pprint-linear-test pprint-linear.3 ('(cl-user::|A|)) "(A)")
+(def-pprint-linear-test pprint-linear.4 ('(cl-user::|A|) t) "(A)")
+(def-pprint-linear-test pprint-linear.5 ('(cl-user::|A|) nil) "A")
+(def-pprint-linear-test pprint-linear.6 ('(1 2 3 4 5)) "(1 2 3 4 5)")
+(def-pprint-linear-test pprint-linear.7 ('((1) (2) #(3) "abc" 5) nil) "(1) (2) #(3) \"abc\" 5")
+
+;;; The fourth argument is ignored
+(def-pprint-linear-test pprint-linear.8 ('(1 2 3 4 5) t nil) "(1 2 3 4 5)")
+(def-pprint-linear-test pprint-linear.9 ('(1 2 3 4 5) nil t) "1 2 3 4 5")
+
+;;; Takes T, NIL as stream designators
+
+(deftest pprint-linear.10
+  (my-with-standard-io-syntax
+   (let ((*print-pretty* nil)
+	 (*print-readably* nil)
+	 (*print-right-margin* 100))
+     (with-output-to-string (*terminal-io*) (pprint-linear t '(1 2 3)))))
+  "(1 2 3)")
+
+(deftest pprint-linear.11
+  (my-with-standard-io-syntax
+   (let ((*print-pretty* t)
+	 (*print-readably* nil)
+	 (*print-right-margin* 100))
+     (with-output-to-string (*standard-output*) (pprint-linear nil '(1 2 3)))))
+  "(1 2 3)")
+
+(deftest pprint-linear.12
+  (my-with-standard-io-syntax
+   (let ((*print-pretty* t)
+	 (*print-readably* nil)
+	 (*package* (find-package :cl-test))
+	 (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M|)))
+     (loop for i from 1 to 10
+	   for result =
+	   (let* ((*print-right-margin* i)
+		  (s (with-output-to-string (os)
+					    (terpri os)
+					    (pprint-linear os obj))))
+	     (cond
+	      ((not (eql (elt s 0) #\Newline))
+	       (list :bad1 s))
+	      ((not (equal (read-from-string s) obj))
+	       (list :bad2 s))
+	      ((< (count #\Newline s) (length obj))
+	       (list :bad3 s))
+	      (t t)))
+	   unless (eql result t)
+	   collect (list i result))))
+  nil)
+
+(deftest pprint-linear.13
+  (my-with-standard-io-syntax
+   (let ((*print-pretty* t)
+	 (*print-readably* nil)
+	 (*package* (find-package :cl-test))
+	 (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M| |M|)))
+     (loop for i from 1 to 10
+	   for result =
+	   (let* ((*print-right-margin* i)
+		  (s (with-output-to-string (os)
+					    (terpri os)
+					    (pprint-linear os obj nil))))
+	     (cond
+	      ((not (eql (elt s 0) #\Newline))
+	       (list :bad1 s))
+	      ((not (equal (read-from-string (concatenate 'string "(" s ")"))
+			   obj))
+	       (list :bad2 s))
+	      ((< (count #\Newline s) (length obj))
+	       (list :bad3 s))
+	      (t t)))
+	   unless (eql result t)
+	   collect (list i result))))
+  nil)
+
+;;; 
+(def-pprint-linear-test pprint-linear.14 ((let ((x (list 'CL-USER::|A|))) (list x x)))
+  "(#1=(A) #1#)" :circle t)
-- 
GitLab