Commit f67527e2 authored by camm's avatar camm

*** empty log message ***

parent c0ee9397
......@@ -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
......
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