;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t; coding: utf-8 -*-
;;
-;; Copyright (C) 2004-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2004-2015 Free Software Foundation, Inc.
;;
;; Author: Miles Bader <miles@gnu.org>
;; Keywords: lisp, compiler, macros
(condition-case err
(apply handler form (cdr form))
(error
- (message "--------------------------------------------------")
- (backtrace)
(message "Compiler-macro error for %S: %S" (car form) err)
form)))
form))))))))
(t form)))
+(defun macroexp-macroexpand (form env)
+ "Like `macroexpand' but checking obsolescence."
+ (let ((new-form
+ (macroexpand form env)))
+ (if (and (not (eq form new-form)) ;It was a macro call.
+ (car-safe form)
+ (symbolp (car form))
+ (get (car form) 'byte-obsolete-info)
+ (or (not (fboundp 'byte-compile-warning-enabled-p))
+ (byte-compile-warning-enabled-p 'obsolete)))
+ (let* ((fun (car form))
+ (obsolete (get fun 'byte-obsolete-info)))
+ (macroexp--warn-and-return
+ (macroexp--obsolete-warning
+ fun obsolete
+ (if (symbolp (symbol-function fun))
+ "alias" "macro"))
+ new-form))
+ new-form)))
+
(defun macroexp--expand-all (form)
"Expand all macros in FORM.
This is an internal version of `macroexpand-all'.
(macroexpand (macroexp--all-forms form 1)
macroexpand-all-environment)
;; Normal form; get its expansion, and then expand arguments.
- (let ((new-form
- (macroexpand form macroexpand-all-environment)))
- (setq form
- (if (and (not (eq form new-form)) ;It was a macro call.
- (car-safe form)
- (symbolp (car form))
- (get (car form) 'byte-obsolete-info)
- (or (not (fboundp 'byte-compile-warning-enabled-p))
- (byte-compile-warning-enabled-p 'obsolete)))
- (let* ((fun (car form))
- (obsolete (get fun 'byte-obsolete-info)))
- (macroexp--warn-and-return
- (macroexp--obsolete-warning
- fun obsolete
- (if (symbolp (symbol-function fun))
- "alias" "macro"))
- new-form))
- new-form)))
+ (setq form (macroexp-macroexpand form macroexpand-all-environment))
(pcase form
(`(cond . ,clauses)
(macroexp--cons 'cond (macroexp--all-clauses clauses) form))
(format "%s quoted with ' rather than with #'"
(list 'lambda (nth 1 f) '...))
(macroexp--expand-all `(,fun ,arg1 ,f . ,args))))
- (`(funcall (,(or 'quote 'function) ,(and f (pred symbolp) . ,_)) . ,args)
+ (`(funcall (,(or 'quote 'function) ,(and f (pred symbolp)) . ,_) . ,args)
;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo'
;; has a compiler-macro.
(macroexp--expand-all `(,f . ,args)))
;;; Handy functions to use in macros.
+(defun macroexp-parse-body (body)
+ "Parse a function BODY into (DECLARATIONS . EXPS)."
+ (let ((decls ()))
+ (while (and (cdr body)
+ (let ((e (car body)))
+ (or (stringp e)
+ (memq (car-safe e)
+ '(:documentation declare interactive cl-declare)))))
+ (push (pop body) decls))
+ (cons (nreverse decls) body)))
+
(defun macroexp-progn (exps)
"Return an expression equivalent to `(progn ,@EXPS)."
(if (cdr exps) `(progn ,@exps) (car exps)))
(macroexp-let* (list (list ,var ,expsym))
,bodysym)))))
+(defmacro macroexp-let2* (test bindings &rest body)
+ "Bind each binding in BINDINGS as `macroexp-let2' does."
+ (declare (indent 2) (debug (sexp (&rest (sexp form)) body)))
+ (pcase-exhaustive bindings
+ (`nil (macroexp-progn body))
+ (`((,var ,exp) . ,tl)
+ `(macroexp-let2 ,test ,var ,exp
+ (macroexp-let2* ,test ,tl ,@body)))))
+
(defun macroexp--maxsize (exp size)
(cond ((< size 0) size)
((symbolp exp) (1- size))
(defvar macroexp--pending-eager-loads nil
"Stack of files currently undergoing eager macro-expansion.")
+(defvar macroexp--debug-eager nil)
+
(defun internal-macroexpand-for-load (form full-p)
;; Called from the eager-macroexpansion in readevalloop.
(cond
(tail (member elem (cdr (member elem bt)))))
(if tail (setcdr tail (list '…)))
(if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt)))
- (message "Warning: Eager macro-expansion skipped due to cycle:\n %s"
- (mapconcat #'prin1-to-string (nreverse bt) " => "))
+ (if macroexp--debug-eager
+ (debug 'eager-macroexp-cycle)
+ (message "Warning: Eager macro-expansion skipped due to cycle:\n %s"
+ (mapconcat #'prin1-to-string (nreverse bt) " => ")))
(push 'skip macroexp--pending-eager-loads)
form))
(t