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 ;;;; Source transforms are used by the compiler to make code more
  15 ;;;; canonical so that the compiler can compile it futher; they are
  16 ;;;; not optional. Compiler macros are an optional source rewriting
  17 ;;;; mechanism mainly for compile-time syntax checking and
  18 ;;;; optimizations that can be declined for any reason, but especially
  19 ;;;; through the use of NOTINLINE. Perhaps the actual mechanism
  20 ;;;; outside the decision to do rewriting could be reunified. We also
  21 ;;;; must pay special attention when writing compiler macros for the
  22 ;;;; purposes of cross-compiling. A problem is namespace clobbering:
  23 ;;;; these must not affect the host Lisp.
  24
  25 ;;; The function that corresponds to this macro is defined in src/code/typep.
  26 ;;; This expansion is not particularly good for the interpreter, so just
  27 ;;; call the function when not compiling.
  28 (define-compiler-macro sb-kernel::%typecase-index (layout-lists object sealed)
  29   (let ((exp (sb-impl::optimize-%typecase-index layout-lists object sealed)))
  30     exp))
  31
  32 ;;; A sanity-checker for an extremely common programmer error.
  33 (define-compiler-macro format (&whole form destination control &rest args)
  34   (declare (ignore control args))
  35   (when (stringp destination)
  36     (warn "Literal string as destination in FORMAT:~%  ~S" form))
  37   form)
  38
  39 (eval-when (:compile-toplevel :load-toplevel :execute)
  40 (declaim (inline maybe-note-read-from-string-signature-issue))
  41 (defun maybe-note-read-from-string-signature-issue (eof-error-p)
  42   ;; The interface is so unintuitive that we explicitly check for the common
  43   ;; error.
  44   (when (member eof-error-p '(:start :end :preserve-whitespace))
  45     (style-warn "~@<~S as EOF-ERROR-P argument to ~S: probable error. ~
  46                Two optional arguments must be provided before the ~
  47                first keyword argument.~:@>"
  48                 eof-error-p 'read-from-string)
  49     t)))
  50
  51 (define-compiler-macro read-from-string (&whole form string &rest args
  52                                          &environment env)
  53   ;; Check this at compile-time, and rewrite it so we're silent at runtime.
  54   (destructuring-bind (&optional (eof-error-p t) eof-value &rest keys) args
  55     (if (maybe-note-read-from-string-signature-issue eof-error-p)
  56         `(read-from-string ,string t ,eof-value ,@keys)
  57         (do ((seen 0)
  58              ;; the :START, :END, :PRESERVE-WHITESPACE defaults respectively
  59              (list (list 0 nil nil))
  60              (bind)
  61              ignore)
  62             ((not (cdr keys))
  63              (if keys
  64                  form ; Odd number of keys, punt.
  65                  (let ((positionals (list (copy-symbol 'string)
  66                                           (copy-symbol 'eof-error-p)
  67                                           (copy-symbol 'eof-value)))
  68                        (fun-name (if (sb-c:policy env (= safety 3))
  69                                      '%read-from-string/safe
  70                                      '%read-from-string)))
  71                    `(let (,@(mapcar #'list positionals
  72                                     (list string eof-error-p eof-value))
  73                           ,@(nreverse bind))
  74                       ,@(when ignore `((declare (ignore ,@ignore))))
  75                       (,fun-name ,@positionals ,@list)))))
  76           (let* ((key (pop keys))
  77                  (index (case key
  78                           (:start 0)
  79                           (:end 1)
  80                           (:preserve-whitespace 2)
  81                           (otherwise (return-from read-from-string form))))
  82                  (var (if (logbitp index seen)
  83                           (let ((x (gensym "IGNORE")))
  84                             (push x ignore)
  85                             x)
  86                           (setf seen (logior (ash 1 index) seen)
  87                                 (nth index list) (copy-symbol key)))))
  88             (push (list var (pop keys)) bind))))))
  89
  90 (defmacro def!struct (&rest args) `(defstruct ,@args))