LCOV - code coverage report
Current view: top level - lisp/emacs-lisp - backquote.el (source / functions) Hit Total Coverage
Test: tramp-tests.info Lines: 96 109 88.1 %
Date: 2017-08-27 09:44:50 Functions: 5 6 83.3 %

          Line data    Source code
       1             : ;;; backquote.el --- implement the ` Lisp construct
       2             : 
       3             : ;; Copyright (C) 1990, 1992, 1994, 2001-2017 Free Software Foundation,
       4             : ;; Inc.
       5             : 
       6             : ;; Author: Rick Sladkey <jrs@world.std.com>
       7             : ;; Maintainer: emacs-devel@gnu.org
       8             : ;; Keywords: extensions, internal
       9             : ;; Package: emacs
      10             : 
      11             : ;; This file is part of GNU Emacs.
      12             : 
      13             : ;; GNU Emacs is free software: you can redistribute it and/or modify
      14             : ;; it under the terms of the GNU General Public License as published by
      15             : ;; the Free Software Foundation, either version 3 of the License, or
      16             : ;; (at your option) any later version.
      17             : 
      18             : ;; GNU Emacs is distributed in the hope that it will be useful,
      19             : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
      20             : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
      21             : ;; GNU General Public License for more details.
      22             : 
      23             : ;; You should have received a copy of the GNU General Public License
      24             : ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
      25             : 
      26             : ;;; Commentary:
      27             : 
      28             : ;; When the Lisp reader sees `(...), it generates (\` (...)).
      29             : ;; When it sees ,... inside such a backquote form, it generates (\, ...).
      30             : ;; For ,@... it generates (\,@ ...).
      31             : 
      32             : ;; This backquote will generate calls to the backquote-list* form.
      33             : ;; Both a function version and a macro version are included.
      34             : ;; The macro version is used by default because it is faster
      35             : ;; and needs no run-time support.  It should really be a subr.
      36             : 
      37             : ;;; Code:
      38             : 
      39             : (provide 'backquote)
      40             : 
      41             : ;; function and macro versions of backquote-list*
      42             : 
      43             : (defun backquote-list*-function (first &rest list)
      44             :   "Like `list' but the last argument is the tail of the new list.
      45             : 
      46             : For example (backquote-list* \\='a \\='b \\='c) => (a b . c)"
      47             :   ;; The recursive solution is much nicer:
      48             :   ;; (if list (cons first (apply 'backquote-list*-function list)) first))
      49             :   ;; but Emacs is not very good at efficiently processing recursion.
      50           0 :   (if list
      51           0 :       (let* ((rest list) (newlist (cons first nil)) (last newlist))
      52           0 :         (while (cdr rest)
      53           0 :           (setcdr last (cons (car rest) nil))
      54           0 :           (setq last (cdr last)
      55           0 :                 rest (cdr rest)))
      56           0 :         (setcdr last (car rest))
      57           0 :         newlist)
      58           0 :     first))
      59             : 
      60             : (defmacro backquote-list*-macro (first &rest list)
      61             :   "Like `list' but the last argument is the tail of the new list.
      62             : 
      63             : For example (backquote-list* \\='a \\='b \\='c) => (a b . c)"
      64             :   ;; The recursive solution is much nicer:
      65             :   ;; (if list (list 'cons first (cons 'backquote-list*-macro list)) first))
      66             :   ;; but Emacs is not very good at efficiently processing such things.
      67         279 :   (setq list (nreverse (cons first list))
      68         279 :         first (car list)
      69         279 :         list (cdr list))
      70         279 :   (if list
      71         279 :       (let* ((second (car list))
      72         279 :              (rest (cdr list))
      73         279 :              (newlist (list 'cons second first)))
      74         956 :         (while rest
      75         677 :           (setq newlist (list 'cons (car rest) newlist)
      76         677 :                 rest (cdr rest)))
      77         279 :         newlist)
      78         279 :     first))
      79             : 
      80             : (defalias 'backquote-list* (symbol-function 'backquote-list*-macro))
      81             : 
      82             : ;; A few advertised variables that control which symbols are used
      83             : ;; to represent the backquote, unquote, and splice operations.
      84             : (defconst backquote-backquote-symbol '\`
      85             :   "Symbol used to represent a backquote or nested backquote.")
      86             : 
      87             : (defconst backquote-unquote-symbol '\,
      88             :   "Symbol used to represent an unquote inside a backquote.")
      89             : 
      90             : (defconst backquote-splice-symbol '\,@
      91             :   "Symbol used to represent a splice inside a backquote.")
      92             : 
      93             : (defmacro backquote (structure)
      94             :   "Argument STRUCTURE describes a template to build.
      95             : 
      96             : The whole structure acts as if it were quoted except for certain
      97             : places where expressions are evaluated and inserted or spliced in.
      98             : 
      99             : For example:
     100             : 
     101             : b              => (ba bb bc)         ; assume b has this value
     102             : \\=`(a b c)       => (a b c)         ; backquote acts like quote
     103             : \\=`(a ,b c)      => (a (ba bb bc) c)        ; insert the value of b
     104             : \\=`(a ,@b c)     => (a ba bb bc c)  ; splice in the value of b
     105             : 
     106             : Vectors work just like lists.  Nested backquotes are permitted."
     107        3235 :   (cdr (backquote-process structure)))
     108             : 
     109             : ;; GNU Emacs has no reader macros
     110             : 
     111             : (defalias '\` (symbol-function 'backquote))
     112             : 
     113             : ;; backquote-process returns a dotted-pair of a tag (0, 1, or 2) and
     114             : ;; the backquote-processed structure.  0 => the structure is
     115             : ;; constant, 1 => to be unquoted, 2 => to be spliced in.
     116             : ;; The top-level backquote macro just discards the tag.
     117             : 
     118             : (defun backquote-delay-process (s level)
     119             :   "Process a (un|back|splice)quote inside a backquote.
     120             : This simply recurses through the body."
     121           2 :   (let ((exp (backquote-listify (list (cons 0 (list 'quote (car s))))
     122           2 :                                 (backquote-process (cdr s) level))))
     123           2 :     (cons (if (eq (car-safe exp) 'quote) 0 1) exp)))
     124             : 
     125             : (defun backquote-process (s &optional level)
     126             :   "Process the body of a backquote.
     127             : S is the body.  Returns a cons cell whose cdr is piece of code which
     128             : is the macro-expansion of S, and whose car is a small integer whose value
     129             : can either indicate that the code is constant (0), or not (1), or returns
     130             : a list which should be spliced into its environment (2).
     131             : LEVEL is only used internally and indicates the nesting level:
     132             : 0 (the default) is for the toplevel nested inside a single backquote."
     133       24665 :   (unless level (setq level 0))
     134       24665 :   (cond
     135       24665 :    ((vectorp s)
     136          28 :     (let ((n (backquote-process (append s ()) level)))
     137          28 :       (if (= (car n) 0)
     138          25 :           (cons 0 s)
     139           3 :         (cons 1 (cond
     140           3 :                  ((not (listp (cdr n)))
     141           0 :                   (list 'vconcat (cdr n)))
     142           3 :                  ((eq (nth 1 n) 'list)
     143           1 :                   (cons 'vector (nthcdr 2 n)))
     144           2 :                  ((eq (nth 1 n) 'append)
     145           0 :                   (cons 'vconcat (nthcdr 2 n)))
     146             :                  (t
     147          28 :                   (list 'apply '(function vector) (cdr n))))))))
     148       24637 :    ((atom s)
     149             :     ;; FIXME: Use macroexp-quote!
     150       11863 :     (cons 0 (if (or (null s) (eq s t) (not (symbolp s)))
     151        6224 :                 s
     152       11863 :               (list 'quote s))))
     153       12774 :    ((eq (car s) backquote-unquote-symbol)
     154        3937 :     (if (<= level 0)
     155        3936 :         (cond
     156        3936 :          ((> (length s) 2)
     157             :           ;; We could support it with: (cons 2 `(list . ,(cdr s)))
     158             :           ;; But let's not encourage such uses.
     159           0 :           (error "Multiple args to , are not supported: %S" s))
     160        3936 :          (t (cons (if (eq (car-safe (nth 1 s)) 'quote) 0 1)
     161        3936 :                   (nth 1 s))))
     162        3937 :       (backquote-delay-process s (1- level))))
     163        8837 :    ((eq (car s) backquote-splice-symbol)
     164        2074 :     (if (<= level 0)
     165        2074 :         (if (> (length s) 2)
     166             :             ;; (cons 2 `(append . ,(cdr s)))
     167           0 :             (error "Multiple args to ,@ are not supported: %S" s)
     168        2074 :           (cons 2 (nth 1 s)))
     169        2074 :       (backquote-delay-process s (1- level))))
     170        6763 :    ((eq (car s) backquote-backquote-symbol)
     171           1 :       (backquote-delay-process s (1+ level)))
     172             :    (t
     173        6762 :     (let ((rest s)
     174             :           item firstlist list lists expression)
     175             :       ;; Scan this list-level, setting LISTS to a list of forms,
     176             :       ;; each of which produces a list of elements
     177             :       ;; that should go in this level.
     178             :       ;; The order of LISTS is backwards.
     179             :       ;; If there are non-splicing elements (constant or variable)
     180             :       ;; at the beginning, put them in FIRSTLIST,
     181             :       ;; as a list of tagged values (TAG . FORM).
     182             :       ;; If there are any at the end, they go in LIST, likewise.
     183       23445 :       (while (and (consp rest)
     184             :                   ;; Stop if the cdr is an expression inside a backquote or
     185             :                   ;; unquote since this needs to go recursively through
     186             :                   ;; backquote-process.
     187       16784 :                   (not (or (eq (car rest) backquote-unquote-symbol)
     188       23445 :                            (eq (car rest) backquote-backquote-symbol))))
     189       16683 :         (setq item (backquote-process (car rest) level))
     190       16683 :         (cond
     191       16683 :          ((= (car item) 2)
     192             :           ;; Put the nonspliced items before the first spliced item
     193             :           ;; into FIRSTLIST.
     194        2074 :           (if (null lists)
     195        2061 :               (setq firstlist list
     196        2074 :                     list nil))
     197             :           ;; Otherwise, put any preceding nonspliced items into LISTS.
     198        2074 :           (if list
     199        2074 :               (push (backquote-listify list '(0 . nil)) lists))
     200        4148 :           (push (cdr item) lists)
     201        2074 :           (setq list nil))
     202             :          (t
     203       16683 :           (setq list (cons item list))))
     204       16683 :         (setq rest (cdr rest)))
     205             :       ;; Handle nonsplicing final elements, and the tail of the list
     206             :       ;; (which remains in REST).
     207        6762 :       (if (or rest list)
     208        4717 :           (push (backquote-listify list (backquote-process rest level))
     209        9434 :                 lists))
     210             :       ;; Turn LISTS into a form that produces the combined list.
     211        6762 :       (setq expression
     212        6762 :             (if (or (cdr lists)
     213        6762 :                     (eq (car-safe (car lists)) backquote-splice-symbol))
     214          21 :                 (cons 'append (nreverse lists))
     215        6762 :               (car lists)))
     216             :       ;; Tack on any initial elements.
     217        6762 :       (if firstlist
     218        6762 :           (setq expression (backquote-listify firstlist (cons 1 expression))))
     219       24665 :       (cons (if (eq (car-safe expression) 'quote) 0 1) expression)))))
     220             : 
     221             : ;; backquote-listify takes (tag . structure) pairs from backquote-process
     222             : ;; and decides between append, list, backquote-list*, and cons depending
     223             : ;; on which tags are in the list.
     224             : 
     225             : (defun backquote-listify (list old-tail)
     226        6777 :   (let ((heads nil) (tail (cdr old-tail)) (list-tail list) (item nil))
     227        6777 :     (if (= (car old-tail) 0)
     228        4617 :         (setq tail (eval tail)
     229        6777 :               old-tail nil))
     230       21388 :     (while (consp list-tail)
     231       14611 :       (setq item (car list-tail))
     232       14611 :       (setq list-tail (cdr list-tail))
     233       14611 :       (if (or heads old-tail (/= (car item) 0))
     234        8446 :           (setq heads (cons (cdr item) heads))
     235       14611 :         (setq tail (cons (eval (cdr item)) tail))))
     236        6777 :     (cond
     237        6777 :      (tail
     238        4634 :       (if (null old-tail)
     239        4634 :           (setq tail (list 'quote tail)))
     240        4634 :       (if heads
     241        2462 :           (let ((use-list* (or (cdr heads)
     242        2183 :                                (and (consp (car heads))
     243         207 :                                     (eq (car (car heads))
     244        2462 :                                         backquote-splice-symbol)))))
     245        2462 :             (cons (if use-list* 'backquote-list* 'cons)
     246        2462 :                   (append heads (list tail))))
     247        4634 :         tail))
     248        6777 :      (t (cons 'list heads)))))
     249             : 
     250             : 
     251             : ;; Give `,' and `,@' documentation strings which can be examined by C-h f.
     252             : (put '\, 'function-documentation
     253             :      "See `\\=`' (also `pcase') for the usage of `,'.")
     254             : (put '\, 'reader-construct t)
     255             : 
     256             : (put '\,@ 'function-documentation
     257             :      "See `\\=`' for the usage of `,@'.")
     258             : (put '\,@ 'reader-construct t)
     259             : 
     260             : ;;; backquote.el ends here

Generated by: LCOV version 1.12