Fix FORMAT compilation on non-simple strings.
[sbcl.git] / src / code / cmacros.lisp
blob3981e875eae3bff8d1fcc42805d16574dc26a73c
1 ;;;; Compiler macros that are important for the target system
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!IMPL")
14 ;;;; We often use a source-transform to do macro-like rewriting of an
15 ;;;; ordinary function call. Source-transforms seem to pre-date the ANSI
16 ;;;; specification and are redundant with compiler-macros.
17 ;;;; In the interest of not multiplying entities needlessly, it should
18 ;;;; be feasible to get rid of source-transforms.
19 ;;;; A problem is namespace clobbering: these must not affect the host Lisp.
21 ;;; A sanity-checker for an extremely common programmer error.
22 (define-compiler-macro format (&whole form destination control &rest args)
23 (declare (ignore control args))
24 (when (stringp destination)
25 (warn "Literal string as destination in FORMAT:~% ~S" form))
26 form)
28 (eval-when (:compile-toplevel :load-toplevel :execute)
29 (defun maybe-note-read-from-string-signature-issue (eof-error-p)
30 ;; The interface is so unintuitive that we explicitly check for the common
31 ;; error.
32 (when (member eof-error-p '(:start :end :preserve-whitespace))
33 (style-warn "~@<~S as EOF-ERROR-P argument to ~S: probable error. ~
34 Two optional arguments must be provided before the ~
35 first keyword argument.~:@>"
36 eof-error-p 'read-from-string)
37 t)))
39 (define-compiler-macro read-from-string (&whole form string &rest args)
40 ;; Check this at compile-time, and rewrite it so we're silent at runtime.
41 (destructuring-bind (&optional (eof-error-p t) eof-value &rest keys) args
42 (if (maybe-note-read-from-string-signature-issue eof-error-p)
43 `(read-from-string ,string t ,eof-value ,@keys)
44 (do ((seen 0)
45 ;; the :START, :END, :PRESERVE-WHITESPACE defaults respectively
46 (list (list 0 nil nil))
47 (bind)
48 ignore)
49 ((not (cdr keys))
50 (if keys
51 form ; Odd number of keys, punt.
52 (let ((positionals (list (copy-symbol 'string)
53 (copy-symbol 'eof-error-p)
54 (copy-symbol 'eof-value))))
55 `(let (,@(mapcar #'list positionals
56 (list string eof-error-p eof-value))
57 ,@(nreverse bind))
58 ,@(when ignore `((declare (ignore ,@ignore))))
59 (%read-from-string ,@positionals ,@list)))))
60 (let* ((key (pop keys))
61 (index (case key
62 (:start 0)
63 (:end 1)
64 (:preserve-whitespace 2)
65 (otherwise (return-from read-from-string form))))
66 (var (if (logbitp index seen)
67 (let ((x (sb!xc:gensym "IGNORE")))
68 (push x ignore)
70 (setf seen (logior (ash 1 index) seen)
71 (nth index list) (copy-symbol key)))))
72 (push (list var (pop keys)) bind))))))
74 (eval-when (:compile-toplevel)
75 (flet ((uncross (form env)
76 (declare (ignore env))
77 (let ((s (cadr form)))
78 (when (stringp s)
79 (let ((new (!xc-preprocess-format-control s)))
80 (when (string/= new s)
81 (return-from uncross `(,(car form) ,new ,@(cddr form)))))))
82 (let* ((arg (cdr (member :format-control (cddr form))))
83 (s (car arg)))
84 (flet ((subst-arg (new) `(,@(ldiff form arg) ,new ,@(cdr arg))))
85 (when (stringp s)
86 (let ((new (!xc-preprocess-format-control s)))
87 (when (string/= new s)
88 (return-from uncross (subst-arg new)))))
89 (when (typep s '(cons (eql if) ; KLUDGE for 'ir1report'
90 (cons t (cons string (cons string null)))))
91 (let ((new1 (!xc-preprocess-format-control (third s)))
92 (new2 (!xc-preprocess-format-control (fourth s))))
93 (when (or (string/= new1 (third s)) (string/= new2 (fourth s)))
94 (return-from uncross
95 (subst-arg `(if ,(second s) ,new1 ,new2))))))))
96 form))
98 (dolist (f '(bug error warn
99 sb!c:compiler-error sb!c:compiler-notify
100 sb!c:compiler-warn sb!c:compiler-style-warn
101 sb!c::note-lossage sb!format::format-error))
102 (setf (sb!xc:compiler-macro-function f) #'uncross))
104 ;; FORMAT has a macro already. Do what it does, then uncross.
105 (let ((existing-macro (sb!xc:compiler-macro-function 'format)))
106 (setf (sb!xc:compiler-macro-function 'format)
107 (lambda (form env)
108 (funcall existing-macro form env) ; for effect only
109 (let* ((old (caddr form))
110 (new (and (stringp old) (!xc-preprocess-format-control old))))
111 (if (and new (string/= new old))
112 `(format ,(cadr form) ,new ,@(cdddr form))
113 form)))))))