Function: ert--expand-should-1

ert--expand-should-1 is a byte-compiled function defined in ert.el.gz.

Signature

(ert--expand-should-1 WHOLE FORM INNER-EXPANDER)

Documentation

Helper function for the should macro and its variants.

Source Code

;; Defined in /usr/src/emacs/lisp/emacs-lisp/ert.el.gz
;; FIXME: Code inside of here should probably be evaluated like it is
;; outside of tests, with the sole exception of error handling
(defun ert--expand-should-1 (whole form inner-expander)
  "Helper function for the `should' macro and its variants."
  (let ((form
         ;; catch macroexpansion errors
         (condition-case err
             (macroexpand-all form macroexpand-all-environment)
           (error `(signal ',(car err) ',(cdr err))))))
    (cond
     ((or (atom form) (ert--special-operator-p (car form)))
      (let ((value (gensym "value-")))
        `(let ((,value (gensym "ert-form-evaluation-aborted-")))
           ,(funcall inner-expander
                     `(setq ,value ,form)
                     `(list ',whole :form ',form :value ,value)
                     value)
           ,value)))
     (t
      (let ((fn-name (car form))
            (arg-forms (cdr form)))
        (cl-assert (or (symbolp fn-name)
                       (and (consp fn-name)
                            (eql (car fn-name) 'lambda)
                            (listp (cdr fn-name)))))
        (let ((fn (gensym "fn-"))
              (args (gensym "args-"))
              (value (gensym "value-"))
              (default-value (gensym "ert-form-evaluation-aborted-")))
          `(let* ((,fn (function ,fn-name))
                  (,args (condition-case err
                             (let ((signal-hook-function #'ert--should-signal-hook))
                               (list ,@arg-forms))
                           (error (progn (setq ,fn #'signal)
                                         (list (car err)
                                               (cdr err)))))))
             (let ((,value ',default-value))
               ,(funcall inner-expander
                         `(setq ,value (apply ,fn ,args))
                         `(nconc (list ',whole)
                                 (list :form `(,,fn ,@,args))
                                 (unless (eql ,value ',default-value)
                                   (list :value ,value))
                                 (unless (eql ,value ',default-value)
                                   (let ((-explainer-
                                          (and (symbolp ',fn-name)
                                               (get ',fn-name 'ert-explainer))))
                                     (when -explainer-
                                       (list :explanation
                                             (apply -explainer- ,args))))))
                         value)
               ,value))))))))