Function: cl--sm-macroexpand

cl--sm-macroexpand is a byte-compiled function defined in cl-macs.el.gz.

Signature

(cl--sm-macroexpand ORIG-FUN EXP &optional ENV)

Documentation

Special macro expander advice used inside cl-symbol-macrolet.

This function extends macroexpand during macro expansion of cl-symbol-macrolet to additionally expand symbol macros.

Source Code

;; Defined in /usr/src/emacs/lisp/emacs-lisp/cl-macs.el.gz
(defun cl--sm-macroexpand (orig-fun exp &optional env)
  "Special macro expander advice used inside `cl-symbol-macrolet'.
This function extends `macroexpand' during macro expansion
of `cl-symbol-macrolet' to additionally expand symbol macros."
  (let ((macroexpand-all-environment env)
        (venv (alist-get :cl-symbol-macros env)))
    (while
        (progn
          (setq exp (funcall orig-fun exp env))
          (pcase exp
            ((pred symbolp)
             ;; Perform symbol-macro expansion.
             (let ((symval (assq exp venv)))
               (when symval
                 (setq exp (cadr symval)))))
            (`(setq . ,args)
             ;; Convert setq to setf if required by symbol-macro expansion.
             (let ((convert nil)
                   (rargs nil))
               (while args
                 (let ((place (pop args)))
                   ;; Here, we know `place' should be a symbol.
                   (while
                       (let ((symval (assq place venv)))
                         (when symval
                           (setq place (cadr symval))
                           (if (symbolp place)
                               t        ;Repeat.
                             (setq convert t)
                             nil))))
                   (push place rargs)
                   (push (pop args) rargs)))
               (setq exp (cons (if convert 'setf 'setq)
                               (nreverse rargs)))
               convert))
            ;; CL's symbol-macrolet used to treat re-bindings as candidates for
            ;; expansion (turning the let into a letf if needed), contrary to
            ;; Common-Lisp where such re-bindings hide the symbol-macro.
            ;; Not sure if there actually is code out there which depends
            ;; on this behavior (haven't found any yet).
            ;; Such code should explicitly use `cl-letf' instead, I think.
            ;;
            ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) pcase--dontcare))
            ;;  (let ((letf nil) (found nil) (nbs ()))
            ;;    (dolist (binding bindings)
            ;;      (let* ((var (if (symbolp binding) binding (car binding)))
            ;;             (sm (assq var venv)))
            ;;        (push (if (not (cdr sm))
            ;;                  binding
            ;;                (let ((nexp (cadr sm)))
            ;;                  (setq found t)
            ;;                  (unless (symbolp nexp) (setq letf t))
            ;;                  (cons nexp (cdr-safe binding))))
            ;;              nbs)))
            ;;    (when found
            ;;      (setq exp `(,(if letf
            ;;                       (if (eq (car exp) 'let) 'cl-letf 'cl-letf*)
            ;;                     (car exp))
            ;;                  ,(nreverse nbs)
            ;;                  ,@body)))))
            ;;
            ;; We implement the Common-Lisp behavior, instead (see bug#26073):
            ;; The behavior of CL made sense in a dynamically scoped
            ;; language, but nowadays, lexical scoping semantics is more often
            ;; expected.
            (`(,(or 'let 'let*) . ,(or `(,bindings . ,body) pcase--dontcare))
             (let ((nbs ()) (found nil))
               (dolist (binding bindings)
                 (let* ((var (if (symbolp binding) binding (car binding)))
                        (val (and found (consp binding) (eq 'let* (car exp))
                                  (list (macroexpand-all (cadr binding)
                                                         env)))))
                   (push (if (assq var venv)
                             ;; This binding should hide "its" surrounding
                             ;; symbol-macro, but given the way macroexpand-all
                             ;; works (i.e. the `env' we receive as input will
                             ;; be (re)applied to the code we return), we can't
                             ;; prevent application of `env' to the
                             ;; sub-expressions, so we need to α-rename this
                             ;; variable instead.
                             (let ((nvar (make-symbol (symbol-name var))))
                               (setq found t)
                               (push (list var nvar) venv)
                               (push (cons :cl-symbol-macros venv) env)
                               (cons nvar (or val (cdr-safe binding))))
                           (if val (cons var val) binding))
                         nbs)))
               (when found
                 (setq exp `(,(car exp)
                             ,(nreverse nbs)
                             ,@(macroexp-unprogn
                                (macroexpand-all (macroexp-progn body)
                                                 env)))))
               nil))
            ;; Do the same as for `let' but for variables introduced
            ;; via other means, such as `lambda' and `condition-case'.
            (`(function (lambda ,args . ,body))
             (let ((nargs ()) (found nil))
               (dolist (var args)
                 (push (cond
                        ((memq var '(&optional &rest)) var)
                        ((assq var venv)
                         (let ((nvar (make-symbol (symbol-name var))))
                           (setq found t)
                           (push (list var nvar) venv)
                           (push (cons :cl-symbol-macros venv) env)
                           nvar))
                        (t var))
                       nargs))
               (when found
                 (setq exp `(function
                             (lambda ,(nreverse nargs)
                               . ,(mapcar (lambda (exp)
                                            (macroexpand-all exp env))
                                          body)))))
               nil))
            ((and `(condition-case ,var ,exp . ,clauses)
                  (guard (assq var venv)))
             (let ((nvar (make-symbol (symbol-name var))))
               (push (list var nvar) venv)
               (push (cons :cl-symbol-macros venv) env)
               (setq exp
                     `(condition-case ,nvar ,(macroexpand-all exp env)
                        . ,(mapcar
                            (lambda (clause)
                              `(,(car clause)
                                . ,(mapcar (lambda (exp)
                                             (macroexpand-all exp env))
                                           (cdr clause))))
                            clauses)))
               nil))
            )))
    exp))