mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-15 10:30:25 -08:00
Code Issues Projects Releases Wiki Activity

Cleanup cl-macs namespace. Add macro helpers in macroexp.el.

Browse source 
* emacs-lisp/macroexp.el (macroexp-progn, macroexp-let*, macroexp-if)
(macroexp-let², macroexp--const-symbol-p, macroexp-const-p)
(macroexp-copyable-p): New functions and macros.
* emacs-lisp/edebug.el (edebug-unwrap):
* emacs-lisp/disass.el (disassemble-internal): Use macroexp-progn.
* emacs-lisp/pcase.el: Use macroexp-let*, macroexp-if, ...
(pcase--let*): Remove.
* emacs-lisp/bytecomp.el (byte-compile-const-symbol-p)
(byte-compile-constp): Remove.  Use macroexp--const-symbol-p and
macroexp-const-p instead.
* emacs-lisp/byte-opt.el: Use macroexp-const-p and macroexp-progn.

* emacs-lisp/cl-macs.el: Clean up the name space by using "cl--"
instead of "cl-" for internal definitions.  Use macroexp-const-p.
(cl-old-bc-file-form): Remove var.
(cl-const-exprs-p): Remove fun.
(cl-labels, cl-macrolet): Use backquote.
(cl-lexical-let): Use cl-symbol-macrolet.  Don't use cl-defun-expander.
(cl-defun-expander, cl-byte-compile-compiler-macro): Remove fun.
(cl-define-setf-expander): Rename from cl-define-setf-method.
* emacs-lisp/cl.el: Adjust alias for define-setf-method.

* international/mule-cmds.el: Don't require CL.
(view-hello-file): Don't use `letf'.
This commit is contained in:
Stefan Monnier 2012-06-07 15:25:48 -04:00
parent 7287f2f345
commit 4dd1c416d1
11 changed files with 535 additions and 498 deletions
Download patch file Download diff file Expand all files Collapse all files

27
lisp/ChangeLog
View file

@ -1,3 +1,30 @@
2012-06-07 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/macroexp.el (macroexp-progn, macroexp-let*, macroexp-if)
(macroexp-let², macroexp--const-symbol-p, macroexp-const-p)
(macroexp-copyable-p): New functions and macros.
* emacs-lisp/edebug.el (edebug-unwrap):
* emacs-lisp/disass.el (disassemble-internal): Use macroexp-progn.
* emacs-lisp/pcase.el: Use macroexp-let*, macroexp-if, ...
(pcase--let*): Remove.
* emacs-lisp/bytecomp.el (byte-compile-const-symbol-p)
(byte-compile-constp): Remove. Use macroexp--const-symbol-p and
macroexp-const-p instead.
* emacs-lisp/byte-opt.el: Use macroexp-const-p and macroexp-progn.
* emacs-lisp/cl-macs.el: Clean up the name space by using "cl--"
instead of "cl-" for internal definitions. Use macroexp-const-p.
(cl-old-bc-file-form): Remove var.
(cl-const-exprs-p): Remove fun.
(cl-labels, cl-macrolet): Use backquote.
(cl-lexical-let): Use cl-symbol-macrolet. Don't use cl-defun-expander.
(cl-defun-expander, cl-byte-compile-compiler-macro): Remove fun.
(cl-define-setf-expander): Rename from cl-define-setf-method.
* emacs-lisp/cl.el: Adjust alias for define-setf-method.
* international/mule-cmds.el: Don't require CL.
(view-hello-file): Don't use `letf'.
2012-06-07 Stefan Monnier <monnier@iro.umontreal.ca>
* tmm.el (tmm-prompt): Use string-prefix-p.

21
lisp/emacs-lisp/byte-opt.el
View file

@ -184,6 +184,7 @@
(require 'bytecomp)
(eval-when-compile (require 'cl))
(require 'macroexp)
(defun byte-compile-log-lap-1 (format &rest args)
;; Newer byte codes for stack-ref make the slot 0 non-nil again.
@ -434,11 +435,9 @@
clause))
(cdr form))))
((eq fn 'progn)
;; as an extra added bonus, this simplifies (progn <x>) --> <x>
;; As an extra added bonus, this simplifies (progn <x>) --> <x>.
(if (cdr (cdr form))
(progn
(setq tmp (byte-optimize-body (cdr form) for-effect))
(if (cdr tmp) (cons 'progn tmp) (car tmp)))
(macroexp-progn (byte-optimize-body (cdr form) for-effect))
(byte-optimize-form (nth 1 form) for-effect)))
((eq fn 'prog1)
(if (cdr (cdr form))
@ -577,10 +576,10 @@
(cons fn args)))))))
(defun byte-optimize-all-constp (list)
"Non-nil if all elements of LIST satisfy `byte-compile-constp'."
"Non-nil if all elements of LIST satisfy `macroexp-const-p"
(let ((constant t))
(while (and list constant)
(unless (byte-compile-constp (car list))
(unless (macroexp-const-p (car list))
(setq constant nil))
(setq list (cdr list)))
constant))
@ -870,8 +869,8 @@
(defun byte-optimize-binary-predicate (form)
(if (byte-compile-constp (nth 1 form))
(if (byte-compile-constp (nth 2 form))
(if (macroexp-const-p (nth 1 form))
(if (macroexp-const-p (nth 2 form))
(condition-case ()
(list 'quote (eval form))
(error form))
@ -883,7 +882,7 @@
(let ((ok t)
(rest (cdr form)))
(while (and rest ok)
(setq ok (byte-compile-constp (car rest))
(setq ok (macroexp-const-p (car rest))
rest (cdr rest)))
(if ok
(condition-case ()
@ -949,7 +948,7 @@
(defun byte-optimize-quote (form)
(if (or (consp (nth 1 form))
(and (symbolp (nth 1 form))
(not (byte-compile-const-symbol-p form))))
(not (macroexp--const-symbol-p form))))
form
(nth 1 form)))
@ -1589,7 +1588,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(if (memq (car lap0) '(byte-constant byte-dup))
(progn
(setq tmp (if (or (not tmp)
(byte-compile-const-symbol-p
(macroexp--const-symbol-p
(car (cdr lap0))))
(cdr lap0)
(byte-compile-get-constant t)))

41
lisp/emacs-lisp/bytecomp.el
View file

@ -1464,29 +1464,6 @@ extra args."
nil)
(defsubst byte-compile-const-symbol-p (symbol &optional any-value)
"Non-nil if SYMBOL is constant.
If ANY-VALUE is nil, only return non-nil if the value of the symbol is the
symbol itself."
(or (memq symbol '(nil t))
(keywordp symbol)
(if any-value
(or (memq symbol byte-compile-const-variables)
;; FIXME: We should provide a less intrusive way to find out
;; if a variable is "constant".
(and (boundp symbol)
(condition-case nil
(progn (set symbol (symbol-value symbol)) nil)
(setting-constant t)))))))
(defmacro byte-compile-constp (form)
"Return non-nil if FORM is a constant."
`(cond ((consp ,form) (or (eq (car ,form) 'quote)
(and (eq (car ,form) 'function)
(symbolp (cadr ,form)))))
((not (symbolp ,form)))
((byte-compile-const-symbol-p ,form))))
;; Dynamically bound in byte-compile-from-buffer.
;; NB also used in cl.el and cl-macs.el.
(defvar byte-compile--outbuffer)
@ -2204,7 +2181,7 @@ list that represents a doc string reference.
(put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload)
(defun byte-compile-file-form-autoload (form)
(and (let ((form form))
(while (if (setq form (cdr form)) (byte-compile-constp (car form))))
(while (if (setq form (cdr form)) (macroexp-const-p (car form))))
(null form)) ;Constants only
(eval (nth 5 form)) ;Macro
(eval form)) ;Define the autoload.
@ -2510,7 +2487,7 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(when (symbolp arg)
(byte-compile-set-symbol-position arg))
(cond ((or (not (symbolp arg))
(byte-compile-const-symbol-p arg t))
(macroexp--const-symbol-p arg t))
(error "Invalid lambda variable %s" arg))
((eq arg '&rest)
(unless (cdr list)
@ -2779,7 +2756,7 @@ for symbols generated by the byte compiler itself."
(if (if (eq (car (car rest)) 'byte-constant)
(or (consp tmp)
(and (symbolp tmp)
(not (byte-compile-const-symbol-p tmp)))))
(not (macroexp--const-symbol-p tmp)))))
(if maycall
(setq body (cons (list 'quote tmp) body)))
(setq body (cons tmp body))))
@ -2850,7 +2827,7 @@ for symbols generated by the byte compiler itself."
(let ((byte-compile--for-effect for-effect))
(cond
((not (consp form))
(cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form))
(cond ((or (not (symbolp form)) (macroexp--const-symbol-p form))
(when (symbolp form)
(byte-compile-set-symbol-position form))
(byte-compile-constant form))
@ -2863,7 +2840,7 @@ for symbols generated by the byte compiler itself."
((symbolp (car form))
(let* ((fn (car form))
(handler (get fn 'byte-compile)))
(when (byte-compile-const-symbol-p fn)
(when (macroexp--const-symbol-p fn)
(byte-compile-warn "`%s' called as a function" fn))
(and (byte-compile-warning-enabled-p 'interactive-only)
(memq fn byte-compile-interactive-only-functions)
@ -2997,7 +2974,7 @@ That command is designed for interactive use only" fn))
"Do various error checks before a use of the variable VAR."
(when (symbolp var)
(byte-compile-set-symbol-position var))
(cond ((or (not (symbolp var)) (byte-compile-const-symbol-p var))
(cond ((or (not (symbolp var)) (macroexp--const-symbol-p var))
(when (byte-compile-warning-enabled-p 'constants)
(byte-compile-warn (if (eq access-type 'let-bind)
"attempt to let-bind %s `%s`"
@ -3568,7 +3545,7 @@ discarding."
(byte-compile-form (cons 'progn (nreverse setters))))
(let ((var (car form)))
(and (or (not (symbolp var))
(byte-compile-const-symbol-p var t))
(macroexp--const-symbol-p var t))
(byte-compile-warning-enabled-p 'constants)
(byte-compile-warn
"variable assignment to %s `%s'"
@ -4117,8 +4094,8 @@ binding slots have been popped."
(defun byte-compile-autoload (form)
(byte-compile-set-symbol-position 'autoload)
(and (byte-compile-constp (nth 1 form))
(byte-compile-constp (nth 5 form))
(and (macroexp-const-p (nth 1 form))
(macroexp-const-p (nth 5 form))
(eval (nth 5 form)) ; macro-p
(not (fboundp (eval (nth 1 form))))
(byte-compile-warn

8
lisp/emacs-lisp/cl-loaddefs.el
View file

@ -281,7 +281,7 @@ This also does some trivial optimizations to make the form prettier.
;;;;;; cl-assert cl-check-type cl-typep cl-deftype cl-struct-setf-expander
;;;;;; cl-defstruct cl-define-modify-macro cl-callf2 cl-callf cl-letf*
;;;;;; cl-letf cl-rotatef cl-shiftf cl-remf cl-do-pop cl-psetf cl-setf
;;;;;; cl-get-setf-method cl-defsetf cl-define-setf-method cl-declare
;;;;;; cl-get-setf-method cl-defsetf cl-define-setf-expander cl-declare
;;;;;; cl-the cl-locally cl-multiple-value-setq cl-multiple-value-bind
;;;;;; cl-lexical-let* cl-lexical-let cl-symbol-macrolet cl-macrolet
;;;;;; cl-labels cl-flet cl-progv cl-psetq cl-do-all-symbols cl-do-symbols
@ -289,7 +289,7 @@ This also does some trivial optimizations to make the form prettier.
;;;;;; cl-return cl-block cl-etypecase cl-typecase cl-ecase cl-case
;;;;;; cl-load-time-value cl-eval-when cl-destructuring-bind cl-function
;;;;;; cl-defmacro cl-defun cl-gentemp cl-gensym) "cl-macs" "cl-macs.el"
;;;;;; "f3973150add70d26cadb8530147dfc99")
;;;;;; "25086e27342ec0990f35f1748a5b7b4e")
;;; Generated autoloads from cl-macs.el
(autoload 'cl-gensym "cl-macs" "\
@ -611,7 +611,7 @@ See Info node `(cl)Declarations' for details.
\(fn &rest SPECS)" nil t)
(autoload 'cl-define-setf-method "cl-macs" "\
(autoload 'cl-define-setf-expander "cl-macs" "\
Define a `cl-setf' method.
This method shows how to handle `cl-setf's to places of the form (NAME ARGS...).
The argument forms ARGS are bound according to ARGLIST, as if NAME were
@ -624,7 +624,7 @@ form. See `cl-defsetf' for a simpler way to define most setf-methods.
(autoload 'cl-defsetf "cl-macs" "\
Define a `cl-setf' method.
This macro is an easy-to-use substitute for `cl-define-setf-method' that works
This macro is an easy-to-use substitute for `cl-define-setf-expander' that works
well for simple place forms. In the simple `cl-defsetf' form, `cl-setf's of
the form (cl-setf (NAME ARGS...) VAL) are transformed to function or macro
calls of the form (FUNC ARGS... VAL). Example:

762
lisp/emacs-lisp/cl-macs.el
View file

File diff suppressed because it is too large Load diff

2
lisp/emacs-lisp/cl.el
View file

@ -219,8 +219,8 @@
setf
get-setf-method
defsetf
(define-setf-method . cl-define-setf-expander)
define-setf-expander
define-setf-method
declare
the
locally

4
lisp/emacs-lisp/disass.el
View file

@ -35,6 +35,8 @@
;;; Code:
(require 'macroexp)
;;; The variable byte-code-vector is defined by the new bytecomp.el.
;;; The function byte-decompile-lapcode is defined in byte-opt.el.
;;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt.
@ -155,7 +157,7 @@ redefine OBJECT if it is a symbol."
(t
(insert "Uncompiled body: ")
(let ((print-escape-newlines t))
(prin1 (if (cdr obj) (cons 'progn obj) (car obj))
(prin1 (macroexp-progn obj)
(current-buffer))))))
(if interactive-p
(message "")))

7
lisp/emacs-lisp/edebug.el
View file

@ -51,6 +51,8 @@
;;; Code:
(require 'macroexp)
;;; Bug reporting
(defalias 'edebug-submit-bug-report 'report-emacs-bug)
@ -1251,10 +1253,7 @@ expressions; a `progn' form will be returned enclosing these forms."
((eq 'edebug-after (car sexp))
(nth 3 sexp))
((eq 'edebug-enter (car sexp))
(let ((forms (nthcdr 2 (nth 1 (nth 3 sexp)))))
(if (> (length forms) 1)
(cons 'progn forms) ;; could return (values forms) instead.
(car forms))))
(macroexp-progn (nthcdr 2 (nth 1 (nth 3 sexp)))))
(t sexp);; otherwise it is not wrapped, so just return it.
)
sexp))

78
lisp/emacs-lisp/macroexp.el
View file

@ -225,6 +225,84 @@ definitions to shadow the loaded ones for use in file byte-compilation."
(let ((macroexpand-all-environment environment))
(macroexp--expand-all form)))
;;; Handy functions to use in macros.
(defun macroexp-progn (exps)
"Return an expression equivalent to `(progn ,@EXPS)."
(if (cdr exps) `(progn ,@exps) (car exps)))
(defun macroexp-let* (bindings exp)
"Return an expression equivalent to `(let* ,bindings ,exp)."
(cond
((null bindings) exp)
((eq 'let* (car-safe exp)) `(let* (,@bindings ,@(cadr exp)) ,@(cddr exp)))
(t `(let* ,bindings ,exp))))
(defun macroexp-if (test then else)
"Return an expression equivalent to `(if ,test ,then ,else)."
(cond
((eq (car-safe else) 'if)
(if (equal test (nth 1 else))
;; Doing a test a second time: get rid of the redundancy.
`(if ,test ,then ,@(nthcdr 3 else))
`(cond (,test ,then)
(,(nth 1 else) ,(nth 2 else))
(t ,@(nthcdr 3 else)))))
((eq (car-safe else) 'cond)
`(cond (,test ,then)
;; Doing a test a second time: get rid of the redundancy, as above.
,@(remove (assoc test else) (cdr else))))
;; Invert the test if that lets us reduce the depth of the tree.
((memq (car-safe then) '(if cond)) (macroexp-if `(not ,test) else then))
(t `(if ,test ,then ,else))))
(defmacro macroexp-let² (test var exp &rest exps)
"Bind VAR to a copyable expression that returns the value of EXP.
This is like `(let ((v ,EXP)) ,EXPS) except that `v' is a new generated
symbol which EXPS can find in VAR.
TEST should be the name of a predicate on EXP checking whether the `let' can
be skipped; if nil, as is usual, `macroexp-const-p' is used."
(declare (indent 3) (debug (sexp form sexp body)))
(let ((bodysym (make-symbol "body"))
(expsym (make-symbol "exp")))
`(let* ((,expsym ,exp)
(,var (if (,(or test #'macroexp-const-p) ,expsym)
,expsym (make-symbol "x")))
(,bodysym ,(macroexp-progn exps)))
(if (eq ,var ,expsym) ,bodysym
(macroexp-let* (list (list ,var ,expsym))
,bodysym)))))
(defsubst macroexp--const-symbol-p (symbol &optional any-value)
"Non-nil if SYMBOL is constant.
If ANY-VALUE is nil, only return non-nil if the value of the symbol is the
symbol itself."
(or (memq symbol '(nil t))
(keywordp symbol)
(if any-value
(or (memq symbol byte-compile-const-variables)
;; FIXME: We should provide a less intrusive way to find out
;; if a variable is "constant".
(and (boundp symbol)
(condition-case nil
(progn (set symbol (symbol-value symbol)) nil)
(setting-constant t)))))))
(defun macroexp-const-p (exp)
"Return non-nil if EXP will always evaluate to the same value."
(cond ((consp exp) (or (eq (car exp) 'quote)
(and (eq (car exp) 'function)
(symbolp (cadr exp)))))
;; It would sometimes make sense to pass `any-value', but it's not
;; always safe since a "constant" variable may not actually always have
;; the same value.
((symbolp exp) (macroexp--const-symbol-p exp))
(t t)))
(defun macroexp-copyable-p (exp)
"Return non-nil if EXP can be copied without extra cost."
(or (symbolp exp) (macroexp-const-p exp)))
(provide 'macroexp)
;;; macroexp.el ends here

45
lisp/emacs-lisp/pcase.el
View file

@ -53,6 +53,8 @@
;;; Code:
(require 'macroexp)
;; Macro-expansion of pcase is reasonably fast, so it's not a problem
;; when byte-compiling a file, but when interpreting the code, if the pcase
;; is in a loop, the repeated macro-expansion becomes terribly costly, so we
@ -94,7 +96,7 @@ PRED patterns can refer to variables bound earlier in the pattern.
E.g. you can match pairs where the cdr is larger than the car with a pattern
like `(,a . ,(pred (< a))) or, with more checks:
`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))"
(declare (indent 1) (debug case)) ;FIXME: edebug `guard' and vars.
(declare (indent 1) (debug cl-case)) ;FIXME: edebug `guard' and vars.
;; We want to use a weak hash table as a cache, but the key will unavoidably
;; be based on `exp' and `cases', yet `cases' is a fresh new list each time
;; we're called so it'll be immediately GC'd. So we use (car cases) as key
@ -225,10 +227,10 @@ of the form (UPAT EXP)."
(cdr case))))
cases))))
(if (null defs) main
(pcase--let* defs main))))
(macroexp-let* defs main))))
(defun pcase-codegen (code vars)
;; Don't use let*, otherwise pcase--let* may merge it with some surrounding
;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding
;; let* which might prevent the setcar/setcdr in pcase--expand's fancy
;; codegen from later metamorphosing this let into a funcall.
`(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars)
@ -248,30 +250,7 @@ of the form (UPAT EXP)."
(cond
((eq else :pcase--dontcare) then)
((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen?
((eq (car-safe else) 'if)
(if (equal test (nth 1 else))
;; Doing a test a second time: get rid of the redundancy.
;; FIXME: ideally, this should never happen because the pcase--split-*
;; funs should have eliminated such things, but pcase--split-member
;; is imprecise, so in practice it can happen occasionally.
`(if ,test ,then ,@(nthcdr 3 else))
`(cond (,test ,then)
(,(nth 1 else) ,(nth 2 else))
(t ,@(nthcdr 3 else)))))
((eq (car-safe else) 'cond)
`(cond (,test ,then)
;; Doing a test a second time: get rid of the redundancy, as above.
,@(remove (assoc test else) (cdr else))))
;; Invert the test if that lets us reduce the depth of the tree.
((memq (car-safe then) '(if cond)) (pcase--if `(not ,test) else then))
(t `(if ,test ,then ,else))))
;; Again, try and reduce nesting.
(defun pcase--let* (binders body)
(if (eq (car-safe body) 'let*)
`(let* ,(append binders (nth 1 body))
,@(nthcdr 2 body))
`(let* ,binders ,body)))
(t (macroexp-if test then else))))
(defun pcase--upat (qpattern)
(cond
@ -589,21 +568,17 @@ Otherwise, it defers to REST which is a list of branches of the form
;; A upat of the form (let VAR EXP).
;; (pcase--u1 matches code
;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest)
(let* ((exp
(macroexp-let²
macroexp-copyable-p sym
(let* ((exp (nth 2 upat))
(found (assq exp vars)))
(if found (cdr found)
(let* ((vs (pcase--fgrep (mapcar #'car vars) exp))
(env (mapcar (lambda (v) (list v (cdr (assq v vars))))
vs)))
(if env `(let* ,env ,exp) exp)))))
(sym (if (symbolp exp) exp (make-symbol "x")))
(body
(if env (macroexp-let* env exp) exp))))
(pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches)
code vars rest)))
(if (eq sym exp)
body
`(let* ((,sym ,exp)) ,body))))
((eq (car-safe upat) '\`)
(put sym 'pcase-used t)
(pcase--q1 sym (cadr upat) matches code vars rest))
@ -695,7 +670,7 @@ Otherwise, it defers to REST which is a list of branches of the form
;; can't signal errors and our byte-compiler is not that clever.
;; FIXME: Some of those let bindings occur too early (they are used in
;; `then-body', but only within some sub-branch).
(pcase--let*
(macroexp-let*
`(,@(if (get syma 'pcase-used) `((,syma (car ,sym))))
,@(if (get symd 'pcase-used) `((,symd (cdr ,sym)))))
then-body)

4
lisp/international/mule-cmds.el
View file

@ -30,8 +30,6 @@
;;; Code:
(eval-when-compile (require 'cl)) ; letf
(defvar dos-codepage)
(autoload 'widget-value "wid-edit")
@ -285,7 +283,7 @@ wrong, use this command again to toggle back to the right mode."
"Display the HELLO file, which lists many languages and characters."
(interactive)
;; We have to decode the file in any environment.
(letf ((coding-system-for-read 'iso-2022-7bit))
(let ((coding-system-for-read 'iso-2022-7bit))
(view-file (expand-file-name "HELLO" data-directory))))
(defun universal-coding-system-argument (coding-system)