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