1 ;;;; Compiler macros that are important for the target system
3 ;;;; This software is part of the SBCL system. See the README file for
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
))
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
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
)
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
)
45 ;; the :START, :END, :PRESERVE-WHITESPACE defaults respectively
46 (list (list 0 nil nil
))
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
))
58 ,@(when ignore
`((declare (ignore ,@ignore
))))
59 (%read-from-string
,@positionals
,@list
)))))
60 (let* ((key (pop keys
))
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")))
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
)))
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
))))
84 (flet ((subst-arg (new) `(,@(ldiff form arg
) ,new
,@(cdr arg
))))
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
)))
95 (subst-arg `(if ,(second s
) ,new1
,new2
))))))))
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
)
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
))