From 46f8f769aac7b59d25ecd413d9a7d6f75a78b5d2 Mon Sep 17 00:00:00 2001 From: Thuna Date: Tue, 16 Jul 2024 03:44:28 +0200 Subject: [PATCH] Quality of life improvements in macroexp.el * macroexp.el (macroexp-progn macroexp-unprogn): Flatten any nested `progn's. (macroexp-if): Accept multiple ELSE arguments. If TEST is always nil or non-nil, return only TEST or ELSE (as a progn) respectively. (macroexp-null): Define form to check whether a form will always return nil. With this and `macroexp-const-p' we also have a way to check if it will always return non-nil(?). --- lisp/emacs-lisp/macroexp.el | 94 ++++++++++++++++++++++--------------- 1 file changed, 57 insertions(+), 37 deletions(-) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index f4df40249de..c8e0850226e 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -536,50 +536,61 @@ macroexp-parse-body (defun macroexp-progn (exps) "Return EXPS (a list of expressions) with `progn' prepended. -If EXPS is a list with a single expression, `progn' is not -prepended, but that expression is returned instead." - (if (cdr exps) `(progn ,@exps) (car exps))) +If EXPS is a list with a single expression, `progn' is not prepended, +but that expression is returned instead. If EXPS is the empty list, +return nil." + (let ((exps (remq nil (mapcan #'macroexp-unprogn exps)))) + (cond ((null exps) nil) + ((null (cdr exps)) (car exps)) + (t `(progn ,@exps))))) (defun macroexp-unprogn (exp) "Turn EXP into a list of expressions to execute in sequence. Never returns an empty list." - (if (eq (car-safe exp) 'progn) (or (cdr exp) '(nil)) (list exp))) - -(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)))) + (if (eq (car-safe exp) 'progn) + (or (remq nil (mapcan #'macroexp-unprogn (cdr exp))) + (list nil)) + (list exp))) + +(defun macroexp-let* (bindings &rest exps) + "Return an expression equivalent to \\=`(let* ,BINDINGS ,@EXPS)." + (let ((exp (macroexp-progn exps))) + (cond + ((null bindings) exp) + ((eq 'let* (car-safe exp)) `(let* (,@bindings ,@(cadr exp)) ,@(cddr exp))) + (t `(let* ,bindings ,@exps))))) -(defun macroexp-if (test then else) +(defun macroexp-if (test then &rest else) "Return an expression equivalent to \\=`(if ,TEST ,THEN ,ELSE)." - (cond - ((eq (car-safe else) 'if) + (let ((else (macroexp-progn else))) (cond - ;; Drop this optimization: It's unsafe (it assumes that `test' is - ;; pure, or at least idempotent), and it's not used even a single - ;; time while compiling Emacs's sources. - ;;((equal test (nth 1 else)) - ;; ;; Doing a test a second time: get rid of the redundancy. - ;; (message "macroexp-if: sharing 'test' %S" test) - ;; `(if ,test ,then ,@(nthcdr 3 else))) - ((equal then (nth 2 else)) - ;; (message "macroexp-if: sharing 'then' %S" then) - `(if (or ,test ,(nth 1 else)) ,then ,@(nthcdr 3 else))) - ((equal (macroexp-unprogn then) (nthcdr 3 else)) - ;; (message "macroexp-if: sharing 'then' with not %S" then) - `(if (or ,test (not ,(nth 1 else))) - ,then ,@(macroexp-unprogn (nth 2 else)))) - (t - `(cond (,test ,@(macroexp-unprogn then)) - (,(nth 1 else) ,@(macroexp-unprogn (nth 2 else))) - ,@(let ((def (nthcdr 3 else))) (if def `((t ,@def)))))))) - ((eq (car-safe else) 'cond) - `(cond (,test ,@(macroexp-unprogn then)) ,@(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 ,@(if else (macroexp-unprogn else)))))) + ((macroexp-null test) else) + ((macroexp-const-p test) then) + ((eq (car-safe else) 'if) + (cond + ;; Drop this optimization: It's unsafe (it assumes that `test' is + ;; pure, or at least idempotent), and it's not used even a single + ;; time while compiling Emacs's sources. + ;;((equal test (nth 1 else)) + ;; ;; Doing a test a second time: get rid of the redundancy. + ;; (message "macroexp-if: sharing 'test' %S" test) + ;; `(if ,test ,then ,@(nthcdr 3 else))) + ((equal then (nth 2 else)) + ;; (message "macroexp-if: sharing 'then' %S" then) + `(if (or ,test ,(nth 1 else)) ,then ,@(nthcdr 3 else))) + ((equal (macroexp-unprogn then) (nthcdr 3 else)) + ;; (message "macroexp-if: sharing 'then' with not %S" then) + `(if (or ,test (not ,(nth 1 else))) + ,then ,@(macroexp-unprogn (nth 2 else)))) + (t + `(cond (,test ,@(macroexp-unprogn then)) + (,(nth 1 else) ,@(macroexp-unprogn (nth 2 else))) + ,@(let ((def (nthcdr 3 else))) (if def `((t ,@def)))))))) + ((eq (car-safe else) 'cond) + `(cond (,test ,@(macroexp-unprogn then)) ,@(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 ,@(if else (macroexp-unprogn else))))))) (defmacro macroexp-let2 (test sym exp &rest body) "Evaluate BODY with SYM bound to an expression for EXP's value. @@ -677,6 +688,15 @@ macroexp--const-symbol-p (progn (set symbol (symbol-value symbol)) nil) (setting-constant t))))))) +(defun macroexp-null (exp) + "Return non-nil if EXP will always evaluate to nil." + (or (eq exp nil) + (and (consp exp) + (memq (car exp) '(function quote \`)) + (cdr exp) + (eq (cadr exp) nil) + (null (cadr exp))))) + (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) -- 2.44.2