Function: cl--sm-macroexpand-1

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

Signature

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

Documentation

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

This function extends macroexpand-1 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-1 (orig-fun exp &optional env)
  "Special macro expander advice used inside `cl-symbol-macrolet'.
This function extends `macroexpand-1' during macro expansion
of `cl-symbol-macrolet' to additionally expand symbol macros."
  (let ((exp (funcall orig-fun exp env))
        (venv (alist-get :cl-symbol-macros env)))
    (pcase exp
      ((pred symbolp)
       ;; Try symbol-macro expansion.
       (let ((symval (assq exp venv)))
         (if symval (cadr symval) exp)))
      (`(setq . ,args)
       ;; Convert setq to setf if required by symbol-macro expansion.
       (let ((convert nil))
         (while args
           (let* ((place (pop args))
                  ;; Here, we know `place' should be a symbol.
                  (symval (assq place venv)))
             (pop args)
             (when symval
               (setq convert t))))
         (if convert
             (cons 'setf (cdr exp))
           exp)))
      ;; 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)))
         (if found
             `(,(car exp)
               ,(nreverse nbs)
               ,@(macroexp-unprogn
                  (macroexpand-all (macroexp-progn body)
                                   env)))
           exp)))
      ;; 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))
         (if found
             `(function
               (lambda ,(nreverse nargs)
                 . ,(mapcar (lambda (exp)
                              (macroexpand-all exp env))
                            body)))
           exp)))
      ((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)
         `(condition-case ,nvar ,(macroexpand-all exp env)
            . ,(mapcar
                (lambda (clause)
                  `(,(car clause)
                    . ,(mapcar (lambda (exp)
                                 (macroexpand-all exp env))
                               (cdr clause))))
                clauses))))
      (_ exp))))