Skip to content
Snippets Groups Projects
Commit c0ee9397 authored by camm's avatar camm
Browse files

*** empty log message ***

parent d2bf5a92
No related branches found
No related tags found
No related merge requests found
...@@ -59,82 +59,84 @@ ...@@ -59,82 +59,84 @@
settings before trying a test. This is intended for cases where the settings before trying a test. This is intended for cases where the
error that occurs is fatal.") error that occurs is fatal.")
(defun randomly-check-readability (obj &key (defun randomly-check-readability (&rest r) nil)
(can-fail nil)
(test #'equal) ;(defun randomly-check-readability (obj &key
(readable t) ; (can-fail nil)
(circle nil circle-p) ; (test #'equal)
(escape nil escape-p) ; (readable t)
(gensym nil gensym-p) ; (circle nil circle-p)
(debug *random-read-check-debug*)) ; (escape nil escape-p)
(declare (type function test)) ; (gensym nil gensym-p)
;; Generate random printer-control values ; (debug *random-read-check-debug*))
(my-with-standard-io-syntax ; (declare (type function test))
(let ((*print-array* (coin)) ; ;; Generate random printer-control values
(*print-base* (+ 2 (random 34))) ; (my-with-standard-io-syntax
(*print-radix* (coin)) ; (let ((*print-array* (coin))
(*print-case* (random-from-seq #(:upcase :downcase :capitalize))) ; (*print-base* (+ 2 (random 34)))
(*print-circle* (if circle-p circle (coin))) ; (*print-radix* (coin))
(*print-escape* (if escape-p escape (coin))) ; (*print-case* (random-from-seq #(:upcase :downcase :capitalize)))
(*print-gensym* (if gensym-p gensym (coin))) ; (*print-circle* (if circle-p circle (coin)))
(*print-level* (random 50)) ; (*print-escape* (if escape-p escape (coin)))
(*print-length* (if readable (random 50) nil)) ; (*print-gensym* (if gensym-p gensym (coin)))
(*print-lines* (if readable (random 50) nil)) ; (*print-level* (random 50))
(*print-miser-width* (and (coin) (random 100))) ; (*print-length* (if readable (random 50) nil))
(*print-pretty* (coin)) ; (*print-lines* (if readable (random 50) nil))
(*print-right-margin* (and (coin) (random 100))) ; (*print-miser-width* (and (coin) (random 100)))
(*print-readably* readable) ; (*print-pretty* (coin))
(*read-default-float-format* (rcase (1 'short-float) (1 'single-float) ; (*print-right-margin* (and (coin) (random 100)))
(1 'double-float) (1 'long-float) ; (*print-readably* readable)
(1 *read-default-float-format*))) ; (*read-default-float-format* (rcase (1 'short-float) (1 'single-float)
(*readtable* (copy-readtable)) ; (1 'double-float) (1 'long-float)
(readcase (random-from-seq #(:upcase :downcase :preserve :invert))) ; (1 *read-default-float-format*)))
) ; (*readtable* (copy-readtable))
(flet ((%params () ; (readcase (random-from-seq #(:upcase :downcase :preserve :invert)))
(list (list '*print-readably* *print-readably*) ; )
(list '*print-array* *print-array*) ; (flet ((%params ()
(list '*print-base* *print-base*) ; (list (list '*print-readably* *print-readably*)
(list '*print-radix* *print-radix*) ; (list '*print-array* *print-array*)
(list '*print-case* *print-case*) ; (list '*print-base* *print-base*)
(list '*print-circle* *print-circle*) ; (list '*print-radix* *print-radix*)
(list '*print-escape* *print-escape*) ; (list '*print-case* *print-case*)
(list '*print-gensym* *print-gensym*) ; (list '*print-circle* *print-circle*)
(list '*print-level* *print-level*) ; (list '*print-escape* *print-escape*)
(list '*print-length* *print-length*) ; (list '*print-gensym* *print-gensym*)
(list '*print-lines* *print-lines*) ; (list '*print-level* *print-level*)
(list '*print-miser-width* *print-miser-width*) ; (list '*print-length* *print-length*)
(list '*print-pretty* *print-pretty*) ; (list '*print-lines* *print-lines*)
(list '*print-right-margin* *print-right-margin*) ; (list '*print-miser-width* *print-miser-width*)
(list '*read-default-float-format* *read-default-float-format*) ; (list '*print-pretty* *print-pretty*)
(list 'readtable-case readcase)))) ; (list '*print-right-margin* *print-right-margin*)
(when debug ; (list '*read-default-float-format* *read-default-float-format*)
(let ((params (%params))) ; (list 'readtable-case readcase))))
(with-standard-io-syntax (format *debug-io* "~%~A~%" params))) ; (when t
(finish-output *debug-io*)) ; (let ((params (%params)))
; (with-standard-io-syntax (format *debug-io* "~%~A~%" params)))
; (setf (readtable-case *readtable*) readcase) ; (finish-output *debug-io*))
(let* ((str (handler-case ;
(with-output-to-string (s) (write obj :stream s)) ;; (setf (readtable-case *readtable*) readcase)
(print-not-readable ; (let* ((str (handler-case
() ; (with-output-to-string (s) (write obj :stream s))
(if can-fail ; (print-not-readable
(return-from randomly-check-readability nil) ; ()
":print-not-readable-error")))) ; (if can-fail
(obj2 (let ((*read-base* *print-base*)) ; (return-from randomly-check-readability nil)
(handler-case ; ":print-not-readable-error"))))
(let ((*readtable* (if *print-readably* ; (obj2 (let ((*read-base* *print-base*))
(copy-readtable nil) ; (handler-case
*readtable*))) ; (let ((*readtable* (if *print-readably*
(read-from-string str)) ; (copy-readtable nil)
(reader-error () :reader-error) ; *readtable*)))
(end-of-file () :end-of-file) ; (read-from-string str))
(stream-error () :stream-error) ; (reader-error () :reader-error)
(file-error () :file-error) ; (end-of-file () :end-of-file)
)))) ; (stream-error () :stream-error)
(unless (funcall test obj obj2) ; (file-error () :file-error)
(list ; ))))
(list* obj str obj2 (%params) ; (unless (funcall test obj obj2)
)))))))) ; (list
; (list* obj str obj2 (%params)
; ))))))))
(defun parse-escaped-string (string) (defun parse-escaped-string (string)
"Parse a string into a list of either characters (representing "Parse a string into a list of either characters (representing
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment