Freeze special variable bindings with funcallable instances

icicle.lisp

;;; Just mucking about with funcallable instances. This class defines
;;; an instance that "freezes" a specified set of special variable
;;; bindings at the time of instantiation, so when the instance is
;;; called these bindings are preserved. This could be achieved with a
;;; closure, but then you couldn't read and alter the bindings so
;;; easily.

(ql:quickload :closer-mop)

(defclass icicle ()
  ((bindings
    :initform nil
    :reader bindings
    :documentation "A set of bindings to establish when this instance
    is called. Variables are stored in a list in the car, values in
    the cdr."))
  (:metaclass closer-mop:funcallable-standard-class)
  (:documentation "A funcallable instance that carries a set of
  dynamic bindings with it"))

(defmethod initialize-instance :after ((self icicle) &key bindings function specials)
  (check-type function function)
  (let (vars vals)
    (loop for (var . val) in bindings
          do (push var vars)
             (push val vals))
    (loop for var in specials
          unless (member var vars)
            do (push var vars)
               (push (symbol-value var) vals))
    (setf (slot-value self 'bindings) (cons vars vals)))
  
  (closer-mop:set-funcallable-instance-function self
                                                (lambda (&rest args)
                                                  (progv (car (bindings self)) (cdr (bindings self))
                                                    (apply function args)))))

;;; Try it out

(defparameter *freeze-me* :foo)
(defparameter *dynamic* :bar)

(defparameter *ice* (make-instance 'icicle
                                   :specials '(*freeze-me*)
                                   :function (lambda ()
                                               (format t "*freeze-me* is ~S~%*dynamic* is ~S~%"
                                                       *freeze-me* *dynamic*))))
;; *ICE*

(funcall *ice*)
;; *freeze-me* is :FOO
;; *dynamic* is :BAR

(setf *freeze-me* 23
      *dynamic* 89)
;; 89

(funcall *ice*)
;; *freeze-me* is :FOO
;; *dynamic* is 89