Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Karsten Poeck
ansi-test
Commits
b5139fe4
Commit
b5139fe4
authored
Jun 15, 2004
by
pfdietz
Browse files
Initial version
parent
3460f188
Changes
1
Hide whitespace changes
Inline
Side-by-side
ansi-tests/pprint-dispatch.lsp
0 → 100644
View file @
b5139fe4
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sat Jun 12 13:14:53 2004
;;;; Contains: Tests of PPRINT-DISPATCH, SET-PPRINT-DISPATCH
(in-package :cl-test)
(deftest pprint-dispatch.1
(loop for x in *universe*
for vals = (multiple-value-list (pprint-dispatch x))
for vals2 = (multiple-value-list (pprint-dispatch
x
*print-pprint-dispatch*))
unless
(and (= (length vals) 2)
(= (length vals2) 2)
(destructuring-bind (fun foundp)
vals
(if foundp
(and (or (typep fun 'function)
(and (symbolp fun)
(symbol-function fun)))
(destructuring-bind (fun2 foundp2)
vals2
(and (equal fun fun2)
foundp2)))
(not (cadr vals2)))))
collect (list x vals vals2))
nil)
(deftest pprint-dispatch.2
(loop for sym in *cl-symbols*
for x = (list sym nil nil)
for vals = (multiple-value-list (pprint-dispatch x))
for vals2 = (multiple-value-list (pprint-dispatch
x
*print-pprint-dispatch*))
unless
(and (= (length vals) 2)
(= (length vals2) 2)
(destructuring-bind (fun foundp)
vals
(if foundp
(and (or (typep fun 'function)
(and (symbolp fun)
(symbol-function fun)))
(destructuring-bind (fun2 foundp2)
vals2
(and (equal fun fun2)
foundp2)))
(not (cadr vals2)))))
collect (list x vals vals2))
nil)
(deftest pprint-dispatch.3
(my-with-standard-io-syntax
(let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))
(*print-readably* nil)
(*print-escape* nil)
(*print-pretty* t))
(let ((f #'(lambda (stream obj)
(declare (ignore obj))
(write "ABC" :stream stream))))
(values
(write-to-string '|X|)
(set-pprint-dispatch '(eql |X|) f)
(write-to-string '|X|)
(set-pprint-dispatch '(eql |X|) nil)
(write-to-string '|X|)))))
"X" nil "ABC" nil "X")
(deftest pprint-dispatch.4
(my-with-standard-io-syntax
(loop for v1 in (delete-if-not #'realp *universe*)
unless
(equal
(let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))
(*print-readably* nil)
(*print-escape* nil)
(*print-pretty* t))
(let ((f #'(lambda (stream obj)
(declare (ignore obj))
(write "ABC" :stream stream))))
(list
(write-to-string '|X|)
(set-pprint-dispatch '(eql |X|) f v1)
(write-to-string '|X|)
(set-pprint-dispatch '(eql |X|) nil)
(write-to-string '|X|))))
'("X" nil "ABC" nil "X"))
collect v1))
nil)
(deftest pprint-dispatch.5
(my-with-standard-io-syntax
(loop for v1 in (delete-if-not #'realp *universe*)
unless
(equal
(let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))
(*print-readably* nil)
(*print-escape* nil)
(*print-pretty* t))
(let ((f #'(lambda (stream obj)
(declare (ignore obj))
(write "ABC" :stream stream))))
(list
(write-to-string '|X|)
(set-pprint-dispatch '(eql |X|) f)
(write-to-string '|X|)
(set-pprint-dispatch '(eql |X|) nil v1)
(write-to-string '|X|))))
'("X" nil "ABC" nil "X"))
collect v1))
nil)
(deftest pprint-dispatch.6
(my-with-standard-io-syntax
(let ((other-ppd-table (copy-pprint-dispatch nil))
(*print-pprint-dispatch* (copy-pprint-dispatch nil))
(*print-readably* nil)
(*print-escape* nil)
(*print-pretty* t))
(let ((f #'(lambda (stream obj)
(declare (ignore obj))
(write "ABC" :stream stream))))
(values
(write-to-string '|X|)
(set-pprint-dispatch '(eql |X|) f 0 other-ppd-table)
(write-to-string '|X|)
(let ((*print-pprint-dispatch* other-ppd-table))
(write-to-string '|X|))
(set-pprint-dispatch '(eql |X|) f)
(write-to-string '|X|)
(set-pprint-dispatch '(eql |X|) nil)
(write-to-string '|X|)))))
"X" nil "X" "ABC" nil "ABC" nil "X")
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment