src/code/backq.lisp

   1 ;;;; the backquote reader macro
   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 (/show0 "entering backq.lisp")
  15
  16 ;;; The flags passed back by BACKQUOTIFY can be interpreted as follows:
  17 ;;;
  18 ;;;   |`,|: [a] => a
  19 ;;;    NIL: [a] => a            ;the NIL flag is used only when a is NIL
  20 ;;;      T: [a] => a            ;the T flag is used when a is self-evaluating
  21 ;;;  QUOTE: [a] => (QUOTE a)
  22 ;;; APPEND: [a] => (APPEND . a)
  23 ;;;  NCONC: [a] => (NCONC . a)
  24 ;;;   LIST: [a] => (LIST . a)
  25 ;;;  LIST*: [a] => (LIST* . a)
  26 ;;;
  27 ;;; The flags are combined according to the following set of rules:
  28 ;;;  ([a] means that a should be converted according to the previous table)
  29 ;;;
  30 ;;;   \ car  ||    otherwise    |    QUOTE or     |     |`,@|      |     |`,.|
  31 ;;;cdr \     ||                 |    T or NIL     |                |
  32 ;;;================================================================================
  33 ;;;  |`,|    || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC  (a [d])
  34 ;;;  NIL     || LIST    ([a])   | QUOTE    (a)    | <hair>    a    | <hair>    a
  35 ;;;QUOTE or T|| LIST* ([a] [d]) | QUOTE  (a . d)  | APPEND (a [d]) | NCONC (a [d])
  36 ;;; APPEND   || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a . d) | NCONC (a [d])
  37 ;;; NCONC    || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a . d)
  38 ;;;  LIST    || LIST  ([a] . d) | LIST  ([a] . d) | APPEND (a [d]) | NCONC (a [d])
  39 ;;;  LIST*   || LIST* ([a] . d) | LIST* ([a] . d) | APPEND (a [d]) | NCONC  (a [d])
  40 ;;;
  41 ;;;<hair> involves starting over again pretending you had read ".,a)" instead
  42 ;;; of ",@a)"
  43
  44 (defvar *backquote-count* 0 #!+sb-doc "how deep we are into backquotes")
  45 (defvar *bq-comma-flag* '(|,|))
  46 (defvar *bq-at-flag* '(|,@|))
  47 (defvar *bq-dot-flag* '(|,.|))
  48 (defvar *bq-vector-flag* '(|bqv|))
  49 (defvar *bq-error* "Comma not inside a backquote.")
  50
  51 (/show0 "backq.lisp 50")
  52
  53 ;;; the actual character macro
  54 (defun backquote-macro (stream ignore)
  55   (declare (ignore ignore))
  56   (let ((*backquote-count* (1+ *backquote-count*)))
  57     (multiple-value-bind (flag thing)
  58         (backquotify stream (read stream t nil t))
  59       (when (eq flag *bq-at-flag*)
  60         (simple-reader-error stream ",@ after backquote in ~S" thing))
  61       (when (eq flag *bq-dot-flag*)
  62         (simple-reader-error stream ",. after backquote in ~S" thing))
  63       (backquotify-1 flag thing))))
  64
  65 (/show0 "backq.lisp 64")
  66
  67 (defun comma-macro (stream ignore)
  68   (declare (ignore ignore))
  69   (unless (> *backquote-count* 0)
  70     (when *read-suppress*
  71       (return-from comma-macro nil))
  72     (simple-reader-error stream *bq-error*))
  73   (let ((c (read-char stream))
  74         (*backquote-count* (1- *backquote-count*)))
  75     (flet ((check (what)
  76              (let ((x (peek-char t stream t nil t)))
  77                (when (and (char= x #\)) (eq #'read-right-paren (get-macro-character #\))))
  78                  ;; Easier to figure out than an "unmatched parenthesis".
  79                  (simple-reader-error stream "Trailing ~A in backquoted expression." what)))))
  80       (cond ((char= c #\@)
  81              (check "comma-at")
  82              (cons *bq-at-flag* (read stream t nil t)))
  83             ((char= c #\.)
  84              (check "comma-dot")
  85              (cons *bq-dot-flag* (read stream t nil t)))
  86             (t
  87              (unread-char c stream)
  88              (check "comma")
  89              (cons *bq-comma-flag* (read stream t nil t)))))))
  90
  91 (/show0 "backq.lisp 83")
  92
  93 ;;;
  94 (defun expandable-backq-expression-p (object)
  95   (and (consp object)
  96        (let ((flag (car object)))
  97          (or (eq flag *bq-at-flag*)
  98              (eq flag *bq-dot-flag*)))))
  99
 100 (defun backquote-splice (method dflag a d what stream)
 101   (cond (dflag
 102          (values method
 103                  (cond ((eq dflag method)
 104                         (cons a d))
 105                        (t (list a (backquotify-1 dflag d))))))
 106         ((expandable-backq-expression-p a)
 107          (values method (list a)))
 108         ((not (and (atom a) (backq-constant-p a)))
 109          ;; COMMA special cases a few constant atoms, which
 110          ;; are illegal in splices.
 111          (comma a))
 112         (t
 113          (simple-reader-error stream "Invalid splice in backquote: ~A~A" what a))))
 114
 115 ;;; This does the expansion from table 2.
 116 (defun backquotify (stream code)
 117   (cond ((atom code)
 118          (cond ((null code) (values nil nil))
 119                ((or (consp code)
 120                     (symbolp code))
 121                 ;; Keywords are self-evaluating. Install after packages.
 122                 (values 'quote code))
 123                (t (values t code))))
 124         ((or (eq (car code) *bq-at-flag*)
 125              (eq (car code) *bq-dot-flag*))
 126          (values (car code) (cdr code)))
 127         ((eq (car code) *bq-comma-flag*)
 128          (comma (cdr code)))
 129         ((eq (car code) *bq-vector-flag*)
 130          (multiple-value-bind (dflag d) (backquotify stream (cdr code))
 131            (values 'vector (backquotify-1 dflag d))))
 132         (t (multiple-value-bind (aflag a) (backquotify stream (car code))
 133              (multiple-value-bind (dflag d) (backquotify stream (cdr code))
 134                (when (eq dflag *bq-at-flag*)
 135                  ;; Get the errors later.
 136                  (simple-reader-error stream ",@ after dot in ~S" code))
 137                (when (eq dflag *bq-dot-flag*)
 138                  (simple-reader-error stream ",. after dot in ~S" code))
 139                (cond
 140                 ((eq aflag *bq-at-flag*)
 141                  (backquote-splice 'append dflag a d ",@" stream))
 142                 ((eq aflag *bq-dot-flag*)
 143                  (backquote-splice 'nconc dflag a d ",." stream))
 144                 ((null dflag)
 145                  (if (member aflag '(quote t nil))
 146                      (values 'quote (list a))
 147                      (values 'list (list (backquotify-1 aflag a)))))
 148                 ((member dflag '(quote t))
 149                  (if (member aflag '(quote t nil))
 150                      (values 'quote (cons a d ))
 151                      (values 'list* (list (backquotify-1 aflag a)
 152                                           (backquotify-1 dflag d)))))
 153                 (t (setq a (backquotify-1 aflag a))
 154                    (if (member dflag '(list list*))
 155                        (values dflag (cons a d))
 156                        (values 'list*
 157                                (list a (backquotify-1 dflag d)))))))))))
 158
 159 (/show0 "backq.lisp 139")
 160
 161 (defun backq-constant-p (x)
 162   (or (numberp x) (eq x t)))
 163
 164 ;;; This handles the <hair> cases.
 165 (defun comma (code)
 166   (cond ((atom code)
 167          (cond ((null code)
 168                 (values nil nil))
 169                ((backq-constant-p code)
 170                 (values t code))
 171                (t
 172                 (values *bq-comma-flag* code))))
 173         ((and (eq (car code) 'quote)
 174               (not (expandable-backq-expression-p (cadr code))))
 175          (values (car code) (cadr code)))
 176         ((member (car code) '(append list list* nconc))
 177          (values (car code) (cdr code)))
 178         ((eq (car code) 'cons)
 179          (values 'list* (cdr code)))
 180         (t (values *bq-comma-flag* code))))
 181
 182 (/show0 "backq.lisp 157")
 183
 184 ;;; This handles table 1.
 185 (defun backquotify-1 (flag thing)
 186   (cond ((or (eq flag *bq-comma-flag*)
 187              (member flag '(t nil)))
 188          thing)
 189         ((eq flag 'quote)
 190          (list  'quote thing))
 191         ((eq flag 'list*)
 192          (cond ((and (null (cddr thing))
 193                      (not (expandable-backq-expression-p (car thing)))
 194                      (not (expandable-backq-expression-p (cadr thing))))
 195                 (cons 'backq-cons thing))
 196                ((expandable-backq-expression-p (car (last thing)))
 197                 (list 'backq-append
 198                       (cons 'backq-list (butlast thing))
 199                       ;; Can it be optimized further? -- APD, 2001-12-21
 200                       (car (last thing))))
 201                (t
 202                 (cons 'backq-list* thing))))
 203         ((eq flag 'vector)
 204          (list 'backq-vector thing))
 205         (t (cons (ecase flag
 206                    ((list) 'backq-list)
 207                    ((append) 'backq-append)
 208                    ((nconc) 'backq-nconc))
 209                  thing))))
 210 \f
 211 ;;;; magic BACKQ- versions of builtin functions
 212
 213 (/show0 "backq.lisp 184")
 214
 215 ;;; Define synonyms for the lisp functions we use, so that by using
 216 ;;; them, the backquoted material will be recognizable to the
 217 ;;; pretty-printer.
 218 (macrolet ((def (b-name name)
 219                ;; FIXME: This function should be INLINE so that the lists
 220                ;; aren't consed twice, but I ran into an optimizer bug the
 221                ;; first time I tried to make this work for BACKQ-LIST. See
 222                ;; whether there's still an optimizer bug, and fix it if so, and
 223                ;; then make these INLINE.
 224                `(defun ,b-name (&rest rest)
 225                   (declare (truly-dynamic-extent rest))
 226                   (apply #',name rest))))
 227   (def backq-list list)
 228   (def backq-list* list*)
 229   (def backq-append append)
 230   (def backq-nconc nconc)
 231   (def backq-cons cons))
 232
 233 (/show0 "backq.lisp 204")
 234
 235 (defun backq-vector (list)
 236   (declare (list list))
 237   (coerce list 'simple-vector))
 238 \f
 239 ;;;; initialization
 240
 241 (/show0 "backq.lisp 212")
 242
 243 ;;; Install BACKQ stuff in the current *READTABLE*.
 244 ;;;
 245 ;;; In the target Lisp, we have to wait to do this until the readtable
 246 ;;; has been created. In the cross-compilation host Lisp, we can do
 247 ;;; this right away. (You may ask: In the cross-compilation host,
 248 ;;; which already has its own implementation of the backquote
 249 ;;; readmacro, why do we do this at all? Because the cross-compilation
 250 ;;; host might -- as SBCL itself does -- express the backquote
 251 ;;; expansion in terms of internal, nonportable functions. By
 252 ;;; redefining backquote in terms of functions which are guaranteed to
 253 ;;; exist on the target Lisp, we ensure that backquote expansions in
 254 ;;; code-generating code work properly.)
 255 (defun !backq-cold-init ()
 256   (set-macro-character #\` #'backquote-macro)
 257   (set-macro-character #\, #'comma-macro))
 258 #+sb-xc-host (!backq-cold-init)
 259
 260 ;;; The pretty-printer needs to know about our special tokens
 261 (defvar *backq-tokens*
 262   '(backq-comma backq-comma-at backq-comma-dot backq-list
 263     backq-list* backq-append backq-nconc backq-cons backq-vector))
 264
 265 ;;; Since our backquote is installed on the host lisp, and since
 266 ;;; developers make mistakes with backquotes and commas too, let's
 267 ;;; ensure that we can report errors rather than get an undefined
 268 ;;; function condition on SIMPLE-READER-ERROR.
 269 #+sb-xc-host ; proper definition happens for the target
 270 (defun simple-reader-error (stream format-string &rest format-args)
 271   (bug "READER-ERROR on stream ~S: ~?" stream format-string format-args))
 272
 273 (/show0 "done with backq.lisp")