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