From f67527e241844d6a878a4580d660f6d7a900ed70 Mon Sep 17 00:00:00 2001 From: camm <camm@localhost> Date: Sat, 24 Jul 2004 15:16:21 +0000 Subject: [PATCH] *** empty log message *** --- ansi-tests/printer-aux.lsp | 154 ++++++++++++++++++------------------- 1 file changed, 76 insertions(+), 78 deletions(-) diff --git a/ansi-tests/printer-aux.lsp b/ansi-tests/printer-aux.lsp index b7bbbb06..821c0a24 100644 --- a/ansi-tests/printer-aux.lsp +++ b/ansi-tests/printer-aux.lsp @@ -59,84 +59,82 @@ settings before trying a test. This is intended for cases where the error that occurs is fatal.") -(defun randomly-check-readability (&rest r) nil) - -;(defun randomly-check-readability (obj &key -; (can-fail nil) -; (test #'equal) -; (readable t) -; (circle nil circle-p) -; (escape nil escape-p) -; (gensym nil gensym-p) -; (debug *random-read-check-debug*)) -; (declare (type function test)) -; ;; Generate random printer-control values -; (my-with-standard-io-syntax -; (let ((*print-array* (coin)) -; (*print-base* (+ 2 (random 34))) -; (*print-radix* (coin)) -; (*print-case* (random-from-seq #(:upcase :downcase :capitalize))) -; (*print-circle* (if circle-p circle (coin))) -; (*print-escape* (if escape-p escape (coin))) -; (*print-gensym* (if gensym-p gensym (coin))) -; (*print-level* (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* readable) -; (*read-default-float-format* (rcase (1 'short-float) (1 'single-float) -; (1 'double-float) (1 'long-float) -; (1 *read-default-float-format*))) -; (*readtable* (copy-readtable)) -; (readcase (random-from-seq #(:upcase :downcase :preserve :invert))) -; ) -; (flet ((%params () -; (list (list '*print-readably* *print-readably*) -; (list '*print-array* *print-array*) -; (list '*print-base* *print-base*) -; (list '*print-radix* *print-radix*) -; (list '*print-case* *print-case*) -; (list '*print-circle* *print-circle*) -; (list '*print-escape* *print-escape*) -; (list '*print-gensym* *print-gensym*) -; (list '*print-level* *print-level*) -; (list '*print-length* *print-length*) -; (list '*print-lines* *print-lines*) -; (list '*print-miser-width* *print-miser-width*) -; (list '*print-pretty* *print-pretty*) -; (list '*print-right-margin* *print-right-margin*) -; (list '*read-default-float-format* *read-default-float-format*) -; (list 'readtable-case readcase)))) -; (when t -; (let ((params (%params))) -; (with-standard-io-syntax (format *debug-io* "~%~A~%" params))) -; (finish-output *debug-io*)) -; -;; (setf (readtable-case *readtable*) readcase) -; (let* ((str (handler-case -; (with-output-to-string (s) (write obj :stream s)) -; (print-not-readable -; () -; (if can-fail -; (return-from randomly-check-readability nil) -; ":print-not-readable-error")))) -; (obj2 (let ((*read-base* *print-base*)) -; (handler-case -; (let ((*readtable* (if *print-readably* -; (copy-readtable nil) -; *readtable*))) -; (read-from-string str)) -; (reader-error () :reader-error) -; (end-of-file () :end-of-file) -; (stream-error () :stream-error) -; (file-error () :file-error) -; )))) -; (unless (funcall test obj obj2) -; (list -; (list* obj str obj2 (%params) -; )))))))) +(defun randomly-check-readability (obj &key + (can-fail nil) + (test #'equal) + (readable t) + (circle nil circle-p) + (escape nil escape-p) + (gensym nil gensym-p) + (debug *random-read-check-debug*)) + (declare (type function test)) + ;; Generate random printer-control values + (my-with-standard-io-syntax + (let ((*print-array* (coin)) + (*print-base* (+ 2 (random 34))) + (*print-radix* (coin)) + (*print-case* (random-from-seq #(:upcase :downcase :capitalize))) + (*print-circle* (if circle-p circle (coin))) + (*print-escape* (if escape-p escape (coin))) + (*print-gensym* (if gensym-p gensym (coin))) + (*print-level* (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* readable) + (*read-default-float-format* (rcase (1 'short-float) (1 'single-float) + (1 'double-float) (1 'long-float) + (1 *read-default-float-format*))) + (*readtable* (copy-readtable)) + (readcase (random-from-seq #(:upcase :downcase :preserve :invert))) + ) + (flet ((%params () + (list (list '*print-readably* *print-readably*) + (list '*print-array* *print-array*) + (list '*print-base* *print-base*) + (list '*print-radix* *print-radix*) + (list '*print-case* *print-case*) + (list '*print-circle* *print-circle*) + (list '*print-escape* *print-escape*) + (list '*print-gensym* *print-gensym*) + (list '*print-level* *print-level*) + (list '*print-length* *print-length*) + (list '*print-lines* *print-lines*) + (list '*print-miser-width* *print-miser-width*) + (list '*print-pretty* *print-pretty*) + (list '*print-right-margin* *print-right-margin*) + (list '*read-default-float-format* *read-default-float-format*) + (list 'readtable-case readcase)))) + (when debug + (let ((params (%params))) + (with-standard-io-syntax (format *debug-io* "~%~A~%" params))) + (finish-output *debug-io*)) + + (setf (readtable-case *readtable*) readcase) + (let* ((str (handler-case + (with-output-to-string (s) (write obj :stream s)) + (print-not-readable + () + (if can-fail + (return-from randomly-check-readability nil) + ":print-not-readable-error")))) + (obj2 (let ((*read-base* *print-base*)) + (handler-case + (let ((*readtable* (if *print-readably* + (copy-readtable nil) + *readtable*))) + (read-from-string str)) + (reader-error () :reader-error) + (end-of-file () :end-of-file) + (stream-error () :stream-error) + (file-error () :file-error) + )))) + (unless (funcall test obj obj2) + (list + (list* obj str obj2 (%params) + )))))))) (defun parse-escaped-string (string) "Parse a string into a list of either characters (representing -- GitLab