1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; While most of SBCL is derived from the CMU CL system, the test
5 ;;;; files (like this one) were written from scratch after the fork
8 ;;;; This software is in the public domain and is provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
10 ;;;; more information.
12 (enable-test-parallelism)
14 (defvar *format-mode
*)
16 (defun format* (format-control &rest arguments
)
19 (eval `(format nil
,format-control
,@arguments
)))
21 (let ((names (sb-int:make-gensym-list
(length arguments
))))
22 (funcall (checked-compile
23 `(lambda ,names
(format nil
,format-control
,@names
)))
26 (defmacro with-compiled-and-interpreted-format
(() &body body
)
27 `(flet ((run-body (mode)
28 (let ((*format-mode
* mode
))
32 (error "~@<Error in ~A FORMAT: ~A~@:>"
37 (defun format-error-format-control-string-p (condition)
38 (and (typep condition
'sb-format
:format-error
)
39 (sb-format::format-error-control-string condition
)))
41 (deftype format-error-with-control-string
()
42 `(and sb-format
:format-error
43 (satisfies format-error-format-control-string-p
)))
45 (with-test (:name
:combine-directives
)
46 ;; The scratch buffer for rematerializing a control string after extracting
47 ;; user-fun directives (~//) needs to account for the expansion of the input
48 ;; if a directive is converted immediately to a run of literal characters.
49 (sb-format::extract-user-fun-directives
"Oh hello~10%~/f/"))
51 (with-test (:name
(:[-directive
:non-integer-argument
))
52 (with-compiled-and-interpreted-format ()
53 (assert-error (format* "~[~]" 1d0
) format-error-with-control-string
)))
55 (with-test (:name
(:P-directive
:no-previous-argument
))
56 (with-compiled-and-interpreted-format ()
57 (assert-error (format* "~@<~:P~@:>" '()) format-error-with-control-string
)))
59 (with-test (:name
(:*-directive
:out-of-bounds
))
60 (with-compiled-and-interpreted-format ()
61 (assert-error (format* "~2@*" '()) format-error-with-control-string
)
62 (assert-error (format* "~1:*" '()) format-error-with-control-string
)))
64 (with-test (:name
:encapsulated-~
/-formatter
65 :broken-on
(and :gc-stress
:x86-64
))
66 (let ((s (make-string-output-stream)))
67 (declare (notinline format
))
68 (sb-int:encapsulate
'sb-ext
:print-symbol-with-prefix
'test
69 (lambda (f stream obj
&rest args
)
70 (write-string "{{" stream
)
71 (apply f stream obj args
)
72 (write-string "}}" stream
)))
73 (format s
"~/sb-ext:print-symbol-with-prefix/" 'cl-user
::test
)
74 (sb-int:unencapsulate
'sb-ext
:print-symbol-with-prefix
'test
)
75 (assert (string= "{{COMMON-LISP-USER::TEST}}" (get-output-stream-string s
)))))
77 (with-test (:name
:non-simple-string
)
78 (let ((control (make-array 2 :element-type
'base-char
81 (checked-compile-and-assert
83 `(lambda () (with-output-to-string (stream)
84 (funcall (formatter ,control
) stream
)))
85 (() "A" :test
#'equal
))
86 (checked-compile-and-assert
88 `(lambda () (format nil
,control
))
89 (() "A" :test
#'equal
))
90 (checked-compile-and-assert
92 `(lambda () (cerror ,control
,control
))
93 (() (condition 'simple-error
)))
94 (checked-compile-and-assert
96 `(lambda () (error ,control
))
97 (() (condition 'simple-error
)))))
99 (with-test (:name
:tokenize-curly-brace-nonliteral-empty
)
101 (let ((tokens (sb-format::tokenize-control-string string
)))
102 (assert (and (= (length tokens
) 3)
103 (string= (second tokens
) ""))))))
104 ;; Each of these curly-brace-wrapped expressions needs to preserve
105 ;; the insides as an empty string so that it does not degenerate
106 ;; to the control string "~{~}".
112 ;; these are also each three parsed tokens:
113 ;; 0 newlines plus an ignored newline
116 ;; 0 newlines, an ignored newline, and 0 tildes
120 (with-test (:name
:no-compiler-notes
)
121 ;; you should't see optimization notes from compiling format strings.
122 ;; (the FORMATTER macro is a heavy user of PRINC)
124 '(lambda (x) (declare (optimize speed
)) (princ x
))
127 '(lambda () (declare (optimize speed
)) (formatter "~:*"))))
129 (defun format-to-string-stream (thing string-stream
)
130 (declare (notinline format
))
131 ;; Tokenizing this string will cons about 224 bytes
132 (format string-stream
"Test ~D" thing
)
133 ;; CLEAR-OUTPUT should work, but doesn't
134 (file-position string-stream
0))
136 (with-test (:name
:cached-tokenized-string
137 :skipped-on
:interpreter
)
138 (let ((stream (make-string-output-stream)))
139 (format-to-string-stream 45678 stream
)
140 (ctu:assert-no-consing
(format-to-string-stream 45678 stream
))))
142 (with-test (:name
:uncached-tokenized-string
)
143 (let ((control-string
144 ;; super-smart compiler might see that the result of
145 ;; this call is constantly "hello ~a"
146 (locally (declare (notinline format
)) (format nil
"hello ~~a"))))
147 (let ((s1 (format nil control-string
'(1 2)))
150 (setf (aref control-string
0) #\Y
)
151 (format nil control-string
'(1 2)))))
152 (assert (string= s1
"hello (1 2)"))
153 (assert (string= s2
"Yello (1 2)")))))
155 (with-test (:name
:return-value
)
156 (let ((formatter (funcall (checked-compile `(lambda () (formatter "~a"))))))
157 (with-output-to-string (s)
158 (assert (null (funcall formatter s
1)))
159 (assert (equal (funcall formatter s
1 2) '(2))))
160 (assert (null (format (make-array 3 :element-type
'character
:fill-pointer
0) formatter
1 2)))))