src/code/cmacros.lisp

   1 ;;;; Compiler macros that are important for the target system
   2
   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.
  11
  12 (in-package "SB!IMPL")
  13
  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.
  20
  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)
  27
  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)))
  38
  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)
  69                             x)
  70                           (setf seen (logior (ash 1 index) seen)
  71                                 (nth index list) (copy-symbol key)))))
  72             (push (list var (pop keys)) bind))))))
  73
  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))
  97
  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))
 102       (setf (sb!xc:compiler-macro-function f) #'uncross))
 103
 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)))))))