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)))