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 (in-package :cl-user)
  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 (:[-directive :non-integer-argument))
  46   (with-compiled-and-interpreted-format ()
  47     (assert-error (format* "~[~]" 1d0) format-error-with-control-string)))
  48
  49 (with-test (:name (:P-directive :no-previous-argument))
  50   (with-compiled-and-interpreted-format ()
  51     (assert-error (format* "~@<~:P~@:>" '()) format-error-with-control-string)))
  52
  53 (with-test (:name (:*-directive :out-of-bounds))
  54   (with-compiled-and-interpreted-format ()
  55     (assert-error (format* "~2@*" '()) format-error-with-control-string)
  56     (assert-error (format* "~1:*" '()) format-error-with-control-string)))
  57
  58 (with-test (:name :encapsulated-~/-formatter)
  59   (let ((s (make-string-output-stream)))
  60     (declare (notinline format))
  61     (sb-int:encapsulate 'sb-ext:print-symbol-with-prefix 'test
  62                         (lambda (f stream obj &rest args)
  63                           (write-string "{{" stream)
  64                           (apply f stream obj args)
  65                           (write-string "}}" stream)))
  66     (format s "~/sb-ext:print-symbol-with-prefix/" 'cl-user::test)
  67     (sb-int:unencapsulate 'sb-ext:print-symbol-with-prefix 'test)
  68     (assert (string= "{{COMMON-LISP-USER::TEST}}" (get-output-stream-string s)))))
  69
  70 (with-test (:name :non-simple-string)
  71   (let ((control (make-array 2 :element-type 'base-char
  72                                :initial-element #\A
  73                                :fill-pointer 1)))
  74     (checked-compile-and-assert
  75         ()
  76         `(lambda () (with-output-to-string (stream)
  77                       (funcall (formatter ,control) stream)))
  78       (() "A" :test #'equal))
  79     (checked-compile-and-assert
  80         ()
  81         `(lambda () (format nil ,control))
  82       (() "A" :test #'equal))
  83     (checked-compile-and-assert
  84         ()
  85         `(lambda () (cerror ,control ,control))
  86       (() (condition 'simple-error)))
  87     (checked-compile-and-assert
  88         ()
  89         `(lambda () (error ,control))
  90       (() (condition 'simple-error)))))
  91
  92