src/functions.lisp

   1 ;;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-mock; -*-
   2
   3 (in-package #:cl-mock)
   4 \f
   5 ;;; dynamic rebinding of functions
   6
   7 (defun maybe-fdefinition (name)
   8   "If NAME is FBOUNDP, return its FDEFINITION, else NIL."
   9   (and (fboundp name) (fdefinition name)))
  10
  11 (defun set-fdefinition (name value)
  12   "FUNCALLABLE expansion of (SETF (FDEFINITION NAME) VALUE)."
  13   (setf (fdefinition name) value))
  14
  15 (defun set-or-unbind-fdefinition (name value)
  16   "If VALUE is true, set the FDEFINITION of NAME to it, else FMAKUNBOUND
  17 it completely."
  18   (if value (set-fdefinition name value) (fmakunbound name)))
  19
  20 (defun call-with-function-bindings (functions values function
  21                                     &optional (previous (mapcar #'maybe-fdefinition functions)))
  22   "Calls FUNCTION while temporarily binding all FUNCTIONS to VALUES.
  23 See PROGF and PROGV."
  24   (unwind-protect
  25        (progn
  26          (mapc #'set-fdefinition functions values)
  27          (funcall function))
  28     (mapc #'set-or-unbind-fdefinition functions previous)))
  29
  30 (defmacro progf (functions values &body body)
  31   "Like PROGV, but for FUNCTIONS."
  32   `(call-with-function-bindings ,functions ,values (lambda () ,@body)))
  33
  34 (defmacro dflet ((&rest definitions) &body body)
  35   "Like FLET, but dynamically sets the FDEFINITIONS during the duration of
  36 the BODY."
  37   `(progf
  38        ',(mapcar #'car definitions)
  39        (list
  40         ,.(mapcar (lambda (definition)
  41                     `(lambda ,(cadr definition)
  42                        ,@(cddr definition)))
  43                   definitions))
  44      ,@body))