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