src/backquote.lisp

   1 ;;; backquote.lisp ---
   2
   3 ;; JSCL is free software: you can redistribute it and/or
   4 ;; modify it under the terms of the GNU General Public License as
   5 ;; published by the Free Software Foundation, either version 3 of the
   6 ;; License, or (at your option) any later version.
   7 ;;
   8 ;; JSCL is distributed in the hope that it will be useful, but
   9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;; General Public License for more details.
  12 ;;
  13 ;; You should have received a copy of the GNU General Public License
  14 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
  15
  16 ;;; Backquote implementation.
  17 ;;;
  18 ;;;    Author: Guy L. Steele Jr.     Date: 27 December 1985
  19 ;;;    Tested under Symbolics Common Lisp and Lucid Common Lisp.
  20 ;;;    This software is in the public domain.
  21
  22 ;;;    The following are unique tokens used during processing.
  23 ;;;    They need not be symbols; they need not even be atoms.
  24 (defvar *comma* 'unquote)
  25 (defvar *comma-atsign* 'unquote-splicing)
  26
  27 (defvar *bq-list* (make-symbol "BQ-LIST"))
  28 (defvar *bq-append* (make-symbol "BQ-APPEND"))
  29 (defvar *bq-list** (make-symbol "BQ-LIST*"))
  30 (defvar *bq-nconc* (make-symbol "BQ-NCONC"))
  31 (defvar *bq-clobberable* (make-symbol "BQ-CLOBBERABLE"))
  32 (defvar *bq-quote* (make-symbol "BQ-QUOTE"))
  33 (defvar *bq-quote-nil* (list *bq-quote* nil))
  34
  35 ;;; BACKQUOTE is an ordinary macro (not a read-macro) that processes
  36 ;;; the expression foo, looking for occurrences of #:COMMA,
  37 ;;; #:COMMA-ATSIGN, and #:COMMA-DOT.  It constructs code in strict
  38 ;;; accordance with the rules on pages 349-350 of the first edition
  39 ;;; (pages 528-529 of this second edition).  It then optionally
  40 ;;; applies a code simplifier.
  41
  42 ;;; If the value of *BQ-SIMPLIFY* is non-NIL, then BACKQUOTE
  43 ;;; processing applies the code simplifier.  If the value is NIL,
  44 ;;; then the code resulting from BACKQUOTE is exactly that
  45 ;;; specified by the official rules.
  46 (defparameter *bq-simplify* t)
  47
  48 (defmacro backquote (x)
  49   (bq-completely-process x))
  50
  51 ;;; Backquote processing proceeds in three stages:
  52 ;;;
  53 ;;; (1) BQ-PROCESS applies the rules to remove occurrences of
  54 ;;; #:COMMA, #:COMMA-ATSIGN, and #:COMMA-DOT corresponding to
  55 ;;; this level of BACKQUOTE.  (It also causes embedded calls to
  56 ;;; BACKQUOTE to be expanded so that nesting is properly handled.)
  57 ;;; Code is produced that is expressed in terms of functions
  58 ;;; #:BQ-LIST, #:BQ-APPEND, and #:BQ-CLOBBERABLE.  This is done
  59 ;;; so that the simplifier will simplify only list construction
  60 ;;; functions actually generated by BACKQUOTE and will not involve
  61 ;;; any user code in the simplification.  #:BQ-LIST means LIST,
  62 ;;; #:BQ-APPEND means APPEND, and #:BQ-CLOBBERABLE means IDENTITY
  63 ;;; but indicates places where "%." was used and where NCONC may
  64 ;;; therefore be introduced by the simplifier for efficiency.
  65 ;;;
  66 ;;; (2) BQ-SIMPLIFY, if used, rewrites the code produced by
  67 ;;; BQ-PROCESS to produce equivalent but faster code.  The
  68 ;;; additional functions #:BQ-LIST* and #:BQ-NCONC may be
  69 ;;; introduced into the code.
  70 ;;;
  71 ;;; (3) BQ-REMOVE-TOKENS goes through the code and replaces
  72 ;;; #:BQ-LIST with LIST, #:BQ-APPEND with APPEND, and so on.
  73 ;;; #:BQ-CLOBBERABLE is simply eliminated (a call to it being
  74 ;;; replaced by its argument).  #:BQ-LIST* is replaced by either
  75 ;;; LIST* or CONS (the latter is used in the two-argument case,
  76 ;;; purely to make the resulting code a tad more readable).
  77
  78 (defun bq-completely-process (x)
  79   (let ((raw-result (bq-process x)))
  80     (bq-remove-tokens (if *bq-simplify*
  81                           (bq-simplify raw-result)
  82                           raw-result))))
  83
  84 (defun bq-process (x)
  85   (cond ((atom x)
  86          (list *bq-quote* x))
  87         ((eq (car x) 'backquote)
  88          (bq-process (bq-completely-process (cadr x))))
  89         ((eq (car x) *comma*) (cadr x))
  90         ((eq (car x) *comma-atsign*)
  91          (error ",@~S after `" (cadr x)))
  92         ;; ((eq (car x) *comma-dot*)
  93         ;;  ;; (error ",.~S after `" (cadr x))
  94         ;;  (error "ill-formed"))
  95         (t (do ((p x (cdr p))
  96                 (q '() (cons (bracket (car p)) q)))
  97                ((atom p)
  98                 (cons *bq-append*
  99                       (nreconc q (list (list *bq-quote* p)))))
 100              (when (eq (car p) *comma*)
 101                (unless (null (cddr p))
 102                  (error "Malformed ,~S" p))
 103                (return (cons *bq-append*
 104                              (nreconc q (list (cadr p))))))
 105              (when (eq (car p) *comma-atsign*)
 106                (error "Dotted ,@~S" p))
 107              ;; (when (eq (car p) *comma-dot*)
 108              ;;   ;; (error "Dotted ,.~S" p)
 109              ;;   (error "Dotted"))
 110              ))))
 111
 112 ;;; This implements the bracket operator of the formal rules.
 113 (defun bracket (x)
 114   (cond ((atom x)
 115          (list *bq-list* (bq-process x)))
 116         ((eq (car x) *comma*)
 117          (list *bq-list* (cadr x)))
 118         ((eq (car x) *comma-atsign*)
 119          (cadr x))
 120         ;; ((eq (car x) *comma-dot*)
 121         ;;  (list *bq-clobberable* (cadr x)))
 122         (t (list *bq-list* (bq-process x)))))
 123
 124 ;;; This auxiliary function is like MAPCAR but has two extra
 125 ;;; purposes: (1) it handles dotted lists; (2) it tries to make
 126 ;;; the result share with the argument x as much as possible.
 127 (defun maptree (fn x)
 128   (if (atom x)
 129       (funcall fn x)
 130       (let ((a (funcall fn (car x)))
 131             (d (maptree fn (cdr x))))
 132         (if (and (eql a (car x)) (eql d (cdr x)))
 133             x
 134             (cons a d)))))
 135
 136 ;;; This predicate is true of a form that when read looked
 137 ;;; like %@foo or %.foo.
 138 (defun bq-splicing-frob (x)
 139   (and (consp x)
 140        (or (eq (car x) *comma-atsign*)
 141            ;; (eq (car x) *comma-dot*)
 142            )))
 143
 144 ;;; This predicate is true of a form that when read
 145 ;;; looked like %@foo or %.foo or just plain %foo.
 146 (defun bq-frob (x)
 147   (and (consp x)
 148        (or (eq (car x) *comma*)
 149            (eq (car x) *comma-atsign*)
 150            ;; (eq (car x) *comma-dot*)
 151            )))
 152
 153 ;;; The simplifier essentially looks for calls to #:BQ-APPEND and
 154 ;;; tries to simplify them.  The arguments to #:BQ-APPEND are
 155 ;;; processed from right to left, building up a replacement form.
 156 ;;; At each step a number of special cases are handled that,
 157 ;;; loosely speaking, look like this:
 158 ;;;
 159 ;;;  (APPEND (LIST a b c) foo) => (LIST* a b c foo)
 160 ;;;       provided a, b, c are not splicing frobs
 161 ;;;  (APPEND (LIST* a b c) foo) => (LIST* a b (APPEND c foo))
 162 ;;;       provided a, b, c are not splicing frobs
 163 ;;;  (APPEND (QUOTE (x)) foo) => (LIST* (QUOTE x) foo)
 164 ;;;  (APPEND (CLOBBERABLE x) foo) => (NCONC x foo)
 165 (defun bq-simplify (x)
 166   (if (atom x)
 167       x
 168       (let ((x (if (eq (car x) *bq-quote*)
 169                    x
 170                    (maptree #'bq-simplify x))))
 171         (if (not (eq (car x) *bq-append*))
 172             x
 173             (bq-simplify-args x)))))
 174
 175 (defun bq-simplify-args (x)
 176   (do ((args (reverse (cdr x)) (cdr args))
 177        (result
 178          nil
 179          (cond ((atom (car args))
 180                 (bq-attach-append *bq-append* (car args) result))
 181                ((and (eq (caar args) *bq-list*)
 182                      (notany #'bq-splicing-frob (cdar args)))
 183                 (bq-attach-conses (cdar args) result))
 184                ((and (eq (caar args) *bq-list**)
 185                      (notany #'bq-splicing-frob (cdar args)))
 186                 (bq-attach-conses
 187                   (reverse (cdr (reverse (cdar args))))
 188                   (bq-attach-append *bq-append*
 189                                     (car (last (car args)))
 190                                     result)))
 191                ((and (eq (caar args) *bq-quote*)
 192                      (consp (cadar args))
 193                      (not (bq-frob (cadar args)))
 194                      (null (cddar args)))
 195                 (bq-attach-conses (list (list *bq-quote*
 196                                               (caadar args)))
 197                                   result))
 198                ((eq (caar args) *bq-clobberable*)
 199                 (bq-attach-append *bq-nconc* (cadar args) result))
 200                (t (bq-attach-append *bq-append*
 201                                     (car args)
 202                                     result)))))
 203       ((null args) result)))
 204
 205 (defun null-or-quoted (x)
 206   (or (null x) (and (consp x) (eq (car x) *bq-quote*))))
 207
 208 ;;; When BQ-ATTACH-APPEND is called, the OP should be #:BQ-APPEND
 209 ;;; or #:BQ-NCONC.  This produces a form (op item result) but
 210 ;;; some simplifications are done on the fly:
 211 ;;;
 212 ;;;  (op '(a b c) '(d e f g)) => '(a b c d e f g)
 213 ;;;  (op item 'nil) => item, provided item is not a splicable frob
 214 ;;;  (op item 'nil) => (op item), if item is a splicable frob
 215 ;;;  (op item (op a b c)) => (op item a b c)
 216 (defun bq-attach-append (op item result)
 217   (cond ((and (null-or-quoted item) (null-or-quoted result))
 218          (list *bq-quote* (append (cadr item) (cadr result))))
 219         ((or (null result) (equal result *bq-quote-nil*))
 220          (if (bq-splicing-frob item) (list op item) item))
 221         ((and (consp result) (eq (car result) op))
 222          (list* (car result) item (cdr result)))
 223         (t (list op item result))))
 224
 225 ;;; The effect of BQ-ATTACH-CONSES is to produce a form as if by
 226 ;;; `(LIST* ,@items ,result) but some simplifications are done
 227 ;;; on the fly.
 228 ;;;
 229 ;;;  (LIST* 'a 'b 'c 'd) => '(a b c . d)
 230 ;;;  (LIST* a b c 'nil) => (LIST a b c)
 231 ;;;  (LIST* a b c (LIST* d e f g)) => (LIST* a b c d e f g)
 232 ;;;  (LIST* a b c (LIST d e f g)) => (LIST a b c d e f g)
 233 (defun bq-attach-conses (items result)
 234   (cond ((and (every #'null-or-quoted items)
 235               (null-or-quoted result))
 236          (list *bq-quote*
 237                (append (mapcar #'cadr items) (cadr result))))
 238         ((or (null result) (equal result *bq-quote-nil*))
 239          (cons *bq-list* items))
 240         ((and (consp result)
 241               (or (eq (car result) *bq-list*)
 242                   (eq (car result) *bq-list**)))
 243          (cons (car result) (append items (cdr result))))
 244         (t (cons *bq-list** (append items (list result))))))
 245
 246 ;;; Removes funny tokens and changes (#:BQ-LIST* a b) into
 247 ;;; (CONS a b) instead of (LIST* a b), purely for readability.
 248 (defun bq-remove-tokens (x)
 249   (cond ((eq x *bq-list*) 'list)
 250         ((eq x *bq-append*) 'append)
 251         ((eq x *bq-nconc*) 'nconc)
 252         ((eq x *bq-list**) 'list*)
 253         ((eq x *bq-quote*) 'quote)
 254         ((atom x) x)
 255         ((eq (car x) *bq-clobberable*)
 256          (bq-remove-tokens (cadr x)))
 257         ((and (eq (car x) *bq-list**)
 258               (consp (cddr x))
 259               (null (cdddr x)))
 260          (cons 'cons (maptree #'bq-remove-tokens (cdr x))))
 261         (t (maptree #'bq-remove-tokens x))))