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)
  22   "Calls FUNCTION while temporarily binding all FUNCTIONS with the given
  23 names to VALUES.  See PROGF and PROGV.  If PREVIOUS is set, it has to
  24 be the list of original values for each function."
  25   (let ((previous (or previous (mapcar #'maybe-fdefinition functions))))
  26     (unwind-protect
  27          (progn
  28            (mapc #'set-fdefinition functions values)
  29            (funcall function))
  30       (mapc #'set-or-unbind-fdefinition functions previous))))
  31
  32 (defmacro progf (functions values &body body)
  33   "Like PROGV, but for FUNCTIONS."
  34   `(call-with-function-bindings ,functions ,values (lambda () ,@body)))
  35
  36 (defmacro dflet ((&rest definitions) &body body)
  37   "Like FLET, but dynamically sets the FDEFINITIONS during the duration of
  38 the BODY."
  39   `(progf
  40        ',(mapcar #'car definitions)
  41        (list
  42         ,.(mapcar (lambda (definition)
  43                     `(lambda ,(cadr definition)
  44                        ,@(cddr definition)))
  45                   definitions))
  46      ,@body))