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

*** empty log message ***

parent c0ee9397
No related branches found
No related tags found
No related merge requests found
...@@ -59,84 +59,82 @@ ...@@ -59,84 +59,82 @@
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 (&rest r) nil) (defun randomly-check-readability (obj &key
(can-fail nil)
;(defun randomly-check-readability (obj &key (test #'equal)
; (can-fail nil) (readable t)
; (test #'equal) (circle nil circle-p)
; (readable t) (escape nil escape-p)
; (circle nil circle-p) (gensym nil gensym-p)
; (escape nil escape-p) (debug *random-read-check-debug*))
; (gensym nil gensym-p) (declare (type function test))
; (debug *random-read-check-debug*)) ;; Generate random printer-control values
; (declare (type function test)) (my-with-standard-io-syntax
; ;; Generate random printer-control values (let ((*print-array* (coin))
; (my-with-standard-io-syntax (*print-base* (+ 2 (random 34)))
; (let ((*print-array* (coin)) (*print-radix* (coin))
; (*print-base* (+ 2 (random 34))) (*print-case* (random-from-seq #(:upcase :downcase :capitalize)))
; (*print-radix* (coin)) (*print-circle* (if circle-p circle (coin)))
; (*print-case* (random-from-seq #(:upcase :downcase :capitalize))) (*print-escape* (if escape-p escape (coin)))
; (*print-circle* (if circle-p circle (coin))) (*print-gensym* (if gensym-p gensym (coin)))
; (*print-escape* (if escape-p escape (coin))) (*print-level* (random 50))
; (*print-gensym* (if gensym-p gensym (coin))) (*print-length* (if readable (random 50) nil))
; (*print-level* (random 50)) (*print-lines* (if readable (random 50) nil))
; (*print-length* (if readable (random 50) nil)) (*print-miser-width* (and (coin) (random 100)))
; (*print-lines* (if readable (random 50) nil)) (*print-pretty* (coin))
; (*print-miser-width* (and (coin) (random 100))) (*print-right-margin* (and (coin) (random 100)))
; (*print-pretty* (coin)) (*print-readably* readable)
; (*print-right-margin* (and (coin) (random 100))) (*read-default-float-format* (rcase (1 'short-float) (1 'single-float)
; (*print-readably* readable) (1 'double-float) (1 'long-float)
; (*read-default-float-format* (rcase (1 'short-float) (1 'single-float) (1 *read-default-float-format*)))
; (1 'double-float) (1 'long-float) (*readtable* (copy-readtable))
; (1 *read-default-float-format*))) (readcase (random-from-seq #(:upcase :downcase :preserve :invert)))
; (*readtable* (copy-readtable)) )
; (readcase (random-from-seq #(:upcase :downcase :preserve :invert))) (flet ((%params ()
; ) (list (list '*print-readably* *print-readably*)
; (flet ((%params () (list '*print-array* *print-array*)
; (list (list '*print-readably* *print-readably*) (list '*print-base* *print-base*)
; (list '*print-array* *print-array*) (list '*print-radix* *print-radix*)
; (list '*print-base* *print-base*) (list '*print-case* *print-case*)
; (list '*print-radix* *print-radix*) (list '*print-circle* *print-circle*)
; (list '*print-case* *print-case*) (list '*print-escape* *print-escape*)
; (list '*print-circle* *print-circle*) (list '*print-gensym* *print-gensym*)
; (list '*print-escape* *print-escape*) (list '*print-level* *print-level*)
; (list '*print-gensym* *print-gensym*) (list '*print-length* *print-length*)
; (list '*print-level* *print-level*) (list '*print-lines* *print-lines*)
; (list '*print-length* *print-length*) (list '*print-miser-width* *print-miser-width*)
; (list '*print-lines* *print-lines*) (list '*print-pretty* *print-pretty*)
; (list '*print-miser-width* *print-miser-width*) (list '*print-right-margin* *print-right-margin*)
; (list '*print-pretty* *print-pretty*) (list '*read-default-float-format* *read-default-float-format*)
; (list '*print-right-margin* *print-right-margin*) (list 'readtable-case readcase))))
; (list '*read-default-float-format* *read-default-float-format*) (when debug
; (list 'readtable-case readcase)))) (let ((params (%params)))
; (when t (with-standard-io-syntax (format *debug-io* "~%~A~%" params)))
; (let ((params (%params))) (finish-output *debug-io*))
; (with-standard-io-syntax (format *debug-io* "~%~A~%" params)))
; (finish-output *debug-io*)) (setf (readtable-case *readtable*) readcase)
; (let* ((str (handler-case
;; (setf (readtable-case *readtable*) readcase) (with-output-to-string (s) (write obj :stream s))
; (let* ((str (handler-case (print-not-readable
; (with-output-to-string (s) (write obj :stream s)) ()
; (print-not-readable (if can-fail
; () (return-from randomly-check-readability nil)
; (if can-fail ":print-not-readable-error"))))
; (return-from randomly-check-readability nil) (obj2 (let ((*read-base* *print-base*))
; ":print-not-readable-error")))) (handler-case
; (obj2 (let ((*read-base* *print-base*)) (let ((*readtable* (if *print-readably*
; (handler-case (copy-readtable nil)
; (let ((*readtable* (if *print-readably* *readtable*)))
; (copy-readtable nil) (read-from-string str))
; *readtable*))) (reader-error () :reader-error)
; (read-from-string str)) (end-of-file () :end-of-file)
; (reader-error () :reader-error) (stream-error () :stream-error)
; (end-of-file () :end-of-file) (file-error () :file-error)
; (stream-error () :stream-error) ))))
; (file-error () :file-error) (unless (funcall test obj obj2)
; )))) (list
; (unless (funcall test obj obj2) (list* obj str obj2 (%params)
; (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