lisp/emacs-lisp/macroexp.el

   1 ;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t; coding: utf-8 -*-
   2 ;;
   3 ;; Copyright (C) 2004-2012 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Miles Bader <miles@gnu.org>
   6 ;; Keywords: lisp, compiler, macros
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24 ;;
  25 ;; This file contains macro-expansions functions that are not defined in
  26 ;; the Lisp core, namely `macroexpand-all', which expands all macros in
  27 ;; a form, not just a top-level one.
  28 ;;
  29
  30 ;;; Code:
  31
  32 ;; Bound by the top-level `macroexpand-all', and modified to include any
  33 ;; macros defined by `defmacro'.
  34 (defvar macroexpand-all-environment nil)
  35
  36 (defun macroexp--cons (car cdr original-cons)
  37   "Return (CAR . CDR), using ORIGINAL-CONS if possible."
  38   (if (and (eq car (car original-cons)) (eq cdr (cdr original-cons)))
  39       original-cons
  40     (cons car cdr)))
  41
  42 ;; We use this special macro to iteratively process forms and share list
  43 ;; structure of the result with the input.  Doing so recursively using
  44 ;; `macroexp--cons' results in excessively deep recursion for very long
  45 ;; input forms.
  46 (defmacro macroexp--accumulate (var+list &rest body)
  47   "Return a list of the results of evaluating BODY for each element of LIST.
  48 Evaluate BODY with VAR bound to each `car' from LIST, in turn.
  49 Return a list of the values of the final form in BODY.
  50 The list structure of the result will share as much with LIST as
  51 possible (for instance, when BODY just returns VAR unchanged, the
  52 result will be eq to LIST).
  53
  54 \(fn (VAR LIST) BODY...)"
  55   (declare (indent 1))
  56   (let ((var (car var+list))
  57         (list (cadr var+list))
  58         (shared (make-symbol "shared"))
  59         (unshared (make-symbol "unshared"))
  60         (tail (make-symbol "tail"))
  61         (new-el (make-symbol "new-el")))
  62     `(let* ((,shared ,list)
  63             (,unshared nil)
  64             (,tail ,shared)
  65             ,var ,new-el)
  66        (while (consp ,tail)
  67          (setq ,var (car ,tail)
  68                ,new-el (progn ,@body))
  69          (unless (eq ,var ,new-el)
  70            (while (not (eq ,shared ,tail))
  71              (push (pop ,shared) ,unshared))
  72            (setq ,shared (cdr ,shared))
  73            (push ,new-el ,unshared))
  74          (setq ,tail (cdr ,tail)))
  75        (nconc (nreverse ,unshared) ,shared))))
  76
  77 (defun macroexp--all-forms (forms &optional skip)
  78   "Return FORMS with macros expanded.  FORMS is a list of forms.
  79 If SKIP is non-nil, then don't expand that many elements at the start of
  80 FORMS."
  81   (macroexp--accumulate (form forms)
  82     (if (or (null skip) (zerop skip))
  83         (macroexp--expand-all form)
  84       (setq skip (1- skip))
  85       form)))
  86
  87 (defun macroexp--all-clauses (clauses &optional skip)
  88   "Return CLAUSES with macros expanded.
  89 CLAUSES is a list of lists of forms; any clause that's not a list is ignored.
  90 If SKIP is non-nil, then don't expand that many elements at the start of
  91 each clause."
  92   (macroexp--accumulate (clause clauses)
  93     (if (listp clause)
  94         (macroexp--all-forms clause skip)
  95       clause)))
  96
  97 (defun macroexp--expand-all (form)
  98   "Expand all macros in FORM.
  99 This is an internal version of `macroexpand-all'.
 100 Assumes the caller has bound `macroexpand-all-environment'."
 101   (if (and (listp form) (eq (car form) 'backquote-list*))
 102       ;; Special-case `backquote-list*', as it is normally a macro that
 103       ;; generates exceedingly deep expansions from relatively shallow input
 104       ;; forms.  We just process it `in reverse' -- first we expand all the
 105       ;; arguments, _then_ we expand the top-level definition.
 106       (macroexpand (macroexp--all-forms form 1)
 107                    macroexpand-all-environment)
 108     ;; Normal form; get its expansion, and then expand arguments.
 109     (let ((new-form (macroexpand form macroexpand-all-environment)))
 110       (when (and (not (eq form new-form)) ;It was a macro call.
 111                  (car-safe form)
 112                  (symbolp (car form))
 113                  (get (car form) 'byte-obsolete-info)
 114                  (fboundp 'byte-compile-warn-obsolete))
 115         (byte-compile-warn-obsolete (car form)))
 116       (setq form new-form))
 117     (pcase form
 118       (`(cond . ,clauses)
 119        (macroexp--cons 'cond (macroexp--all-clauses clauses) form))
 120       (`(condition-case . ,(or `(,err ,body . ,handlers) dontcare))
 121        (macroexp--cons
 122         'condition-case
 123         (macroexp--cons err
 124                     (macroexp--cons (macroexp--expand-all body)
 125                                 (macroexp--all-clauses handlers 1)
 126                                 (cddr form))
 127                     (cdr form))
 128         form))
 129       (`(,(or `defvar `defconst) . ,_) (macroexp--all-forms form 2))
 130       (`(function ,(and f `(lambda . ,_)))
 131        (macroexp--cons 'function
 132                    (macroexp--cons (macroexp--all-forms f 2)
 133                                nil
 134                                (cdr form))
 135                    form))
 136       (`(,(or `function `quote) . ,_) form)
 137       (`(,(and fun (or `let `let*)) . ,(or `(,bindings . ,body) dontcare))
 138        (macroexp--cons fun
 139                    (macroexp--cons (macroexp--all-clauses bindings 1)
 140                                (macroexp--all-forms body)
 141                                (cdr form))
 142                    form))
 143       (`(,(and fun `(lambda . ,_)) . ,args)
 144        ;; Embedded lambda in function position.
 145        (macroexp--cons (macroexp--all-forms fun 2)
 146                    (macroexp--all-forms args)
 147                    form))
 148       ;; The following few cases are for normal function calls that
 149       ;; are known to funcall one of their arguments.  The byte
 150       ;; compiler has traditionally handled these functions specially
 151       ;; by treating a lambda expression quoted by `quote' as if it
 152       ;; were quoted by `function'.  We make the same transformation
 153       ;; here, so that any code that cares about the difference will
 154       ;; see the same transformation.
 155       ;; First arg is a function:
 156       (`(,(and fun (or `funcall `apply `mapcar `mapatoms `mapconcat `mapc))
 157          ',(and f `(lambda . ,_)) . ,args)
 158        (byte-compile-log-warning
 159         (format "%s quoted with ' rather than with #'"
 160                 (list 'lambda (nth 1 f) '...))
 161         t)
 162        ;; We don't use `macroexp--cons' since there's clearly a change.
 163        (cons fun
 164              (cons (macroexp--expand-all (list 'function f))
 165                    (macroexp--all-forms args))))
 166       ;; Second arg is a function:
 167       (`(,(and fun (or `sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args)
 168        (byte-compile-log-warning
 169         (format "%s quoted with ' rather than with #'"
 170                 (list 'lambda (nth 1 f) '...))
 171         t)
 172        ;; We don't use `macroexp--cons' since there's clearly a change.
 173        (cons fun
 174              (cons (macroexp--expand-all arg1)
 175                    (cons (macroexp--expand-all
 176                           (list 'function f))
 177                          (macroexp--all-forms args)))))
 178       (`(,func . ,_)
 179        ;; Macro expand compiler macros.  This cannot be delayed to
 180        ;; byte-optimize-form because the output of the compiler-macro can
 181        ;; use macros.
 182        (let ((handler nil))
 183          (while (and (symbolp func)
 184                      (not (setq handler (get func 'compiler-macro)))
 185                      (fboundp func)
 186                      (or (not (eq (car-safe (symbol-function func))
 187                                   'autoload))
 188                          (ignore-errors
 189                            (load (nth 1 (symbol-function func))
 190                                  'noerror 'nomsg))))
 191            ;; Follow the sequence of aliases.
 192            (setq func (symbol-function func)))
 193          (if (null handler)
 194              ;; No compiler macro.  We just expand each argument (for
 195              ;; setq/setq-default this works alright because the variable names
 196              ;; are symbols).
 197              (macroexp--all-forms form 1)
 198            (let ((newform (condition-case err
 199                               (apply handler form (cdr form))
 200                             (error (message "Compiler-macro error: %S" err)
 201                                    form))))
 202              (if (eq form newform)
 203                  ;; The compiler macro did not find anything to do.
 204                  (if (equal form (setq newform (macroexp--all-forms form 1)))
 205                      form
 206                    ;; Maybe after processing the args, some new opportunities
 207                    ;; appeared, so let's try the compiler macro again.
 208                    (setq form (condition-case err
 209                                   (apply handler newform (cdr newform))
 210                                 (error (message "Compiler-macro error: %S" err)
 211                                        newform)))
 212                    (if (eq newform form)
 213                        newform
 214                      (macroexp--expand-all newform)))
 215                (macroexp--expand-all newform))))))
 216
 217       (t form))))
 218
 219 ;;;###autoload
 220 (defun macroexpand-all (form &optional environment)
 221   "Return result of expanding macros at all levels in FORM.
 222 If no macros are expanded, FORM is returned unchanged.
 223 The second optional arg ENVIRONMENT specifies an environment of macro
 224 definitions to shadow the loaded ones for use in file byte-compilation."
 225   (let ((macroexpand-all-environment environment))
 226     (macroexp--expand-all form)))
 227
 228 ;;; Handy functions to use in macros.
 229
 230 (defun macroexp-progn (exps)
 231   "Return an expression equivalent to `(progn ,@EXPS)."
 232   (if (cdr exps) `(progn ,@exps) (car exps)))
 233
 234 (defun macroexp-unprogn (exp)
 235   "Turn EXP into a list of expressions to execute in sequence."
 236   (if (eq (car-safe exp) 'progn) (cdr exp) (list exp)))
 237
 238 (defun macroexp-let* (bindings exp)
 239   "Return an expression equivalent to `(let* ,bindings ,exp)."
 240   (cond
 241    ((null bindings) exp)
 242    ((eq 'let* (car-safe exp)) `(let* (,@bindings ,@(cadr exp)) ,@(cddr exp)))
 243    (t `(let* ,bindings ,exp))))
 244
 245 (defun macroexp-if (test then else)
 246   "Return an expression equivalent to `(if ,test ,then ,else)."
 247   (cond
 248    ((eq (car-safe else) 'if)
 249     (if (equal test (nth 1 else))
 250         ;; Doing a test a second time: get rid of the redundancy.
 251         `(if ,test ,then ,@(nthcdr 3 else))
 252       `(cond (,test ,then)
 253              (,(nth 1 else) ,(nth 2 else))
 254              (t ,@(nthcdr 3 else)))))
 255    ((eq (car-safe else) 'cond)
 256     `(cond (,test ,then)
 257            ;; Doing a test a second time: get rid of the redundancy, as above.
 258            ,@(remove (assoc test else) (cdr else))))
 259    ;; Invert the test if that lets us reduce the depth of the tree.
 260    ((memq (car-safe then) '(if cond)) (macroexp-if `(not ,test) else then))
 261    (t `(if ,test ,then ,else))))
 262
 263 (defmacro macroexp-let² (test var exp &rest exps)
 264   "Bind VAR to a copyable expression that returns the value of EXP.
 265 This is like `(let ((v ,EXP)) ,EXPS) except that `v' is a new generated
 266 symbol which EXPS can find in VAR.
 267 TEST should be the name of a predicate on EXP checking whether the `let' can
 268 be skipped; if nil, as is usual, `macroexp-const-p' is used."
 269   (declare (indent 3) (debug (sexp form sexp body)))
 270   (let ((bodysym (make-symbol "body"))
 271         (expsym (make-symbol "exp")))
 272     `(let* ((,expsym ,exp)
 273             (,var (if (,(or test #'macroexp-const-p) ,expsym)
 274                       ,expsym (make-symbol "x")))
 275             (,bodysym ,(macroexp-progn exps)))
 276        (if (eq ,var ,expsym) ,bodysym
 277          (macroexp-let* (list (list ,var ,expsym))
 278                         ,bodysym)))))
 279
 280 (defsubst macroexp--const-symbol-p (symbol &optional any-value)
 281   "Non-nil if SYMBOL is constant.
 282 If ANY-VALUE is nil, only return non-nil if the value of the symbol is the
 283 symbol itself."
 284   (or (memq symbol '(nil t))
 285       (keywordp symbol)
 286       (if any-value
 287           (or (memq symbol byte-compile-const-variables)
 288               ;; FIXME: We should provide a less intrusive way to find out
 289               ;; if a variable is "constant".
 290               (and (boundp symbol)
 291                    (condition-case nil
 292                        (progn (set symbol (symbol-value symbol)) nil)
 293                      (setting-constant t)))))))
 294
 295 (defun macroexp-const-p (exp)
 296   "Return non-nil if EXP will always evaluate to the same value."
 297   (cond ((consp exp) (or (eq (car exp) 'quote)
 298                          (and (eq (car exp) 'function)
 299                               (symbolp (cadr exp)))))
 300         ;; It would sometimes make sense to pass `any-value', but it's not
 301         ;; always safe since a "constant" variable may not actually always have
 302         ;; the same value.
 303         ((symbolp exp) (macroexp--const-symbol-p exp))
 304         (t t)))
 305
 306 (defun macroexp-copyable-p (exp)
 307   "Return non-nil if EXP can be copied without extra cost."
 308   (or (symbolp exp) (macroexp-const-p exp)))
 309
 310 (provide 'macroexp)
 311
 312 ;;; macroexp.el ends here