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 (file-comment
  15   "$Header$")
  16
  17 ;;; The flags passed back by BACKQUOTIFY can be interpreted as follows:
  18 ;;;
  19 ;;;   |`,|: [a] => a
  20 ;;;    NIL: [a] => a            ;the NIL flag is used only when a is NIL
  21 ;;;      T: [a] => a            ;the T flag is used when a is self-evaluating
  22 ;;;  QUOTE: [a] => (QUOTE a)
  23 ;;; APPEND: [a] => (APPEND . a)
  24 ;;;  NCONC: [a] => (NCONC . a)
  25 ;;;   LIST: [a] => (LIST . a)
  26 ;;;  LIST*: [a] => (LIST* . a)
  27 ;;;
  28 ;;; The flags are combined according to the following set of rules:
  29 ;;;  ([a] means that a should be converted according to the previous table)
  30 ;;;
  31 ;;;   \ car  ||    otherwise    |    QUOTE or     |     |`,@|      |     |`,.|
  32 ;;;cdr \     ||          |    T or NIL     |            |
  33 ;;;================================================================================
  34 ;;;  |`,|    || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC  (a [d])
  35 ;;;  NIL     || LIST    ([a])   | QUOTE    (a)    | <hair>    a    | <hair>    a
  36 ;;;QUOTE or T|| LIST* ([a] [d]) | QUOTE  (a . d)  | APPEND (a [d]) | NCONC (a [d])
  37 ;;; APPEND   || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a . d) | NCONC (a [d])
  38 ;;; NCONC    || 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 ;;;  LIST*   || LIST* ([a] . d) | LIST* ([a] . d) | APPEND (a [d]) | NCONC  (a [d])
  41 ;;;
  42 ;;;<hair> involves starting over again pretending you had read ".,a)" instead
  43 ;;; of ",@a)"
  44
  45 (defvar *backquote-count* 0 #!+sb-doc "how deep we are into backquotes")
  46 (defvar *bq-comma-flag* '(|,|))
  47 (defvar *bq-at-flag* '(|,@|))
  48 (defvar *bq-dot-flag* '(|,.|))
  49 (defvar *bq-vector-flag* '(|bqv|))
  50
  51 ;;; the actual character macro
  52 (defun backquote-macro (stream ignore)
  53   (declare (ignore ignore))
  54   (let ((*backquote-count* (1+ *backquote-count*)))
  55     (multiple-value-bind (flag thing)
  56         (backquotify stream (read stream t nil t))
  57       (if (eq flag *bq-at-flag*)
  58           (%reader-error stream ",@ after backquote in ~S" thing))
  59       (if (eq flag *bq-dot-flag*)
  60           (%reader-error stream ",. after backquote in ~S" thing))
  61       (values (backquotify-1 flag thing) 'list))))
  62
  63 (defun comma-macro (stream ignore)
  64   (declare (ignore ignore))
  65   (unless (> *backquote-count* 0)
  66     (when *read-suppress*
  67       (return-from comma-macro nil))
  68     (%reader-error stream "comma not inside a backquote"))
  69   (let ((c (read-char stream))
  70         (*backquote-count* (1- *backquote-count*)))
  71     (values
  72      (cond ((char= c #\@)
  73             (cons *bq-at-flag* (read stream t nil t)))
  74            ((char= c #\.)
  75             (cons *bq-dot-flag* (read stream t nil t)))
  76            (t (unread-char c stream)
  77               (cons *bq-comma-flag* (read stream t nil t))))
  78      'list)))
  79
  80 ;;; This does the expansion from table 2.
  81 (defun backquotify (stream code)
  82   (cond ((atom code)
  83          (cond ((null code) (values nil nil))
  84                ((or (numberp code)
  85                     (eq code t))
  86                 ;; Keywords are self-evaluating. Install after packages.
  87                 (values t code))
  88                (t (values 'quote code))))
  89         ((or (eq (car code) *bq-at-flag*)
  90              (eq (car code) *bq-dot-flag*))
  91          (values (car code) (cdr code)))
  92         ((eq (car code) *bq-comma-flag*)
  93          (comma (cdr code)))
  94         ((eq (car code) *bq-vector-flag*)
  95          (multiple-value-bind (dflag d) (backquotify stream (cdr code))
  96            (values 'vector (backquotify-1 dflag d))))
  97         (t (multiple-value-bind (aflag a) (backquotify stream (car code))
  98              (multiple-value-bind (dflag d) (backquotify stream (cdr code))
  99                (if (eq dflag *bq-at-flag*)
 100                    ;; Get the errors later.
 101                    (%reader-error stream ",@ after dot in ~S" code))
 102                (if (eq dflag *bq-dot-flag*)
 103                    (%reader-error stream ",. after dot in ~S" code))
 104                (cond
 105                 ((eq aflag *bq-at-flag*)
 106                  (if (null dflag)
 107                      (comma a)
 108                      (values 'append
 109                              (cond ((eq dflag 'append)
 110                                     (cons a d ))
 111                                    (t (list a (backquotify-1 dflag d)))))))
 112                 ((eq aflag *bq-dot-flag*)
 113                  (if (null dflag)
 114                      (comma a)
 115                      (values 'nconc
 116                              (cond ((eq dflag 'nconc)
 117                                     (cons a d))
 118                                    (t (list a (backquotify-1 dflag d)))))))
 119                 ((null dflag)
 120                  (if (member aflag '(quote t nil))
 121                      (values 'quote (list a))
 122                      (values 'list (list (backquotify-1 aflag a)))))
 123                 ((member dflag '(quote t))
 124                  (if (member aflag '(quote t nil))
 125                      (values 'quote (cons a d ))
 126                      (values 'list* (list (backquotify-1 aflag a)
 127                                           (backquotify-1 dflag d)))))
 128                 (t (setq a (backquotify-1 aflag a))
 129                    (if (member dflag '(list list*))
 130                        (values dflag (cons a d))
 131                        (values 'list*
 132                                (list a (backquotify-1 dflag d)))))))))))
 133
 134 ;;; This handles the <hair> cases.
 135 (defun comma (code)
 136   (cond ((atom code)
 137          (cond ((null code)
 138                 (values nil nil))
 139                ((or (numberp code) (eq code 't))
 140                 (values t code))
 141                (t (values *bq-comma-flag* code))))
 142         ((eq (car code) 'quote)
 143          (values (car code) (cadr code)))
 144         ((member (car code) '(append list list* nconc))
 145          (values (car code) (cdr code)))
 146         ((eq (car code) 'cons)
 147          (values 'list* (cdr code)))
 148         (t (values *bq-comma-flag* code))))
 149
 150 ;;; This handles table 1.
 151 (defun backquotify-1 (flag thing)
 152   (cond ((or (eq flag *bq-comma-flag*)
 153              (member flag '(t nil)))
 154          thing)
 155         ((eq flag 'quote)
 156          (list  'quote thing))
 157         ((eq flag 'list*)
 158          (cond ((null (cddr thing))
 159                 (cons 'backq-cons thing))
 160                (t
 161                 (cons 'backq-list* thing))))
 162         ((eq flag 'vector)
 163          (list 'backq-vector thing))
 164         (t (cons (cdr
 165                   (assoc flag
 166                          '((cons . backq-cons)
 167                            (list . backq-list)
 168                            (append . backq-append)
 169                            (nconc . backq-nconc))
 170                          :test #'equal))
 171                  thing))))
 172 \f
 173 ;;;; magic BACKQ- versions of builtin functions
 174
 175 ;;; Define synonyms for the lisp functions we use, so that by using them, we
 176 ;;; backquoted material will be recognizable to the pretty-printer.
 177 (macrolet ((def-frob (b-name name)
 178              (let ((args (gensym "ARGS")))
 179                ;; FIXME: This function should be INLINE so that the lists
 180                ;; aren't consed twice, but I ran into an optimizer bug the
 181                ;; first time I tried to make this work for BACKQ-LIST. See
 182                ;; whether there's still an optimizer bug, and fix it if so, and
 183                ;; then make these INLINE.
 184                `(defun ,b-name (&rest ,args)
 185                   (apply #',name ,args)))))
 186   (def-frob backq-list list)
 187   (def-frob backq-list* list*)
 188   (def-frob backq-append append)
 189   (def-frob backq-nconc nconc)
 190   (def-frob backq-cons cons))
 191
 192 (defun backq-vector (list)
 193   (declare (list list))
 194   (coerce list 'simple-vector))
 195 \f
 196 ;;;; initialization
 197
 198 ;;; Install BACKQ stuff in the current *READTABLE*.
 199 ;;;
 200 ;;; In the target Lisp, we have to wait to do this until the readtable has been
 201 ;;; created. In the cross-compilation host Lisp, we can do this right away.
 202 ;;; (You may ask: In the cross-compilation host, which already has its own
 203 ;;; implementation of the backquote readmacro, why do we do this at all?
 204 ;;; Because the cross-compilation host might -- as SBCL itself does -- express
 205 ;;; the backquote expansion in terms of internal, nonportable functions. By
 206 ;;; redefining backquote in terms of functions which are guaranteed to exist on
 207 ;;; the target Lisp, we ensure that backquote expansions in code-generating
 208 ;;; code work properly.)
 209 (defun !backq-cold-init ()
 210   (set-macro-character #\` #'backquote-macro)
 211   (set-macro-character #\, #'comma-macro))
 212 #+sb-xc-host (!backq-cold-init)