tests/format.pure.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   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
   6 ;;;; from CMU CL.
   7 ;;;;
   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.
  11
  12 (enable-test-parallelism)
  13
  14 (defvar *format-mode*)
  15
  16 (defun format* (format-control &rest arguments)
  17   (ecase *format-mode*
  18     (:interpret
  19      (eval `(format nil ,format-control ,@arguments)))
  20     (:compile
  21      (let ((names (sb-int:make-gensym-list (length arguments))))
  22        (funcall (checked-compile
  23                  `(lambda ,names (format nil ,format-control ,@names)))
  24                 arguments)))))
  25
  26 (defmacro with-compiled-and-interpreted-format (() &body body)
  27   `(flet ((run-body (mode)
  28             (let ((*format-mode* mode))
  29               (handler-case
  30                   (progn ,@body)
  31                 (error (condition)
  32                   (error "~@<Error in ~A FORMAT: ~A~@:>"
  33                          mode condition))))))
  34      (run-body :interpret)
  35      (run-body :compile)))
  36
  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)))
  40
  41 (deftype format-error-with-control-string ()
  42   `(and sb-format:format-error
  43         (satisfies format-error-format-control-string-p)))
  44
  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/"))
  50
  51 (with-test (:name (:[-directive :non-integer-argument))
  52   (with-compiled-and-interpreted-format ()
  53     (assert-error (format* "~[~]" 1d0) format-error-with-control-string)))
  54
  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)))
  58
  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)))
  63
  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)))))
  76
  77 (with-test (:name :non-simple-string)
  78   (let ((control (make-array 2 :element-type 'base-char
  79                                :initial-element #\A
  80                                :fill-pointer 1)))
  81     (checked-compile-and-assert
  82         ()
  83         `(lambda () (with-output-to-string (stream)
  84                       (funcall (formatter ,control) stream)))
  85       (() "A" :test #'equal))
  86     (checked-compile-and-assert
  87         ()
  88         `(lambda () (format nil ,control))
  89       (() "A" :test #'equal))
  90     (checked-compile-and-assert
  91         ()
  92         `(lambda () (cerror ,control ,control))
  93       (() (condition 'simple-error)))
  94     (checked-compile-and-assert
  95         ()
  96         `(lambda () (error ,control))
  97       (() (condition 'simple-error)))))
  98
  99 (with-test (:name :tokenize-curly-brace-nonliteral-empty)
 100   (flet ((try (string)
 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 "~{~}".
 107     (try "~{~
 108 ~}")
 109     (try "~{~0|~}")
 110     (try "~{~0~~}")
 111     (try "~{~0%~}")
 112     ;; these are also each three parsed tokens:
 113     ;; 0 newlines plus an ignored newline
 114     (try "~{~0%~
 115 ~}")
 116     ;; 0 newlines, an ignored newline, and 0 tildes
 117     (try "~{~0%~
 118 ~0|~0~~}")))
 119
 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)
 123   (checked-compile
 124    '(lambda (x) (declare (optimize speed)) (princ x))
 125    :allow-notes nil)
 126   (checked-compile
 127    '(lambda ()  (declare (optimize speed)) (formatter "~:*"))))
 128
 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))
 135
 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))))
 141
 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)))
 148           (s2
 149            (progn
 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)")))))
 154
 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)))))