(in-package :weblocks)

(defgeneric special-variables (capturing-object)
  (:documentation "Answer the list of special variables to capture."))

(defgeneric direct-special-variables (capture-class)
  (:documentation "Answer the list of specials to be captured by
  instances of CAPTURE-CLASS.")
  (:method ((c class)) '()))

(defgeneric special-values (capturing-object)
  (:documentation "Answer the list of special values captured."))

(defgeneric (setf special-values) (capturing-object values)
  (:documentation "Set the list of captured values of
  `special-variables' to VALUES, and answer VALUES."))

(defgeneric pushnew-special (capture-class special)
  (:documentation "Add SPECIAL to the list of specials captured by
  instances of CAPTURE-CLASS."))

(defclass special-capturing-class (standard-class)
  ((direct-special-variables
    :type list :initform '() :initarg :specials
    :reader direct-special-variables
    :documentation "List of symbols to capture.")
   (effective-special-variables
    :type list :documentation "Including those from superclasses."))
  (:documentation "I capture the value of special variables registered
  with me in each of my instances.

Define the list of specials, which will inherit from superclasses that
are also myself, with the `:specials' class initialization parameter.
Then, initialize the capture with `capture-specials', and load/save
captures with my primary entry point `call-with-captured-specials'."))

(defmethod validate-superclass ((class special-capturing-class) super)
  "Allow special-capturing-classes to subclass strictly
standard-classes."
  (or (eql (class-of super) (find-class 'standard-class))
      (typep super 'special-capturing-class)))

(defmethod initialize-instance :around
    ((class special-capturing-class) &rest kwargs &key direct-slots
     &allow-other-keys)
  "Add the `special-values' slot to hold values."
  (apply #'call-next-method class
	 :direct-slots (cons (canonical-special-value-slot) direct-slots)
	 kwargs))

(defmethod reinitialize-instance :around
    ((class special-capturing-class) &rest kwargs &key direct-slots
     &allow-other-keys)
  "Add the `special-values' slot to hold values."
  (apply #'call-next-method class
	 :direct-slots (cons (canonical-special-value-slot) direct-slots)
	 kwargs))

(defun canonical-special-value-slot ()
  '(:name special-values :type list
    :readers (special-values) :writers ((setf special-values))))

(defmethod finalize-inheritance :after ((class special-capturing-class))
  (setf (slot-value class 'effective-special-variables)
	  (remove-duplicates
	   (loop for super in (class-precedence-list class)
	      append (direct-special-variables super))
	   :test #'eq)))

(defmethod pushnew-special ((c special-capturing-class) special)
  (with-slots (direct-special-variables) c
    (pushnew special direct-special-variables)
    (when (and (class-finalized-p c)
	       (eq special (car direct-special-variables)))
      (finalize-inheritance c)
      (make-instances-obsolete c))))

(defmethod special-variables ((self standard-object))
  "Answer the list of all special variables computed by my class."
  (slot-value (class-of self) 'effective-special-variables))

(defun capture-specials (capturer)
  "Save all requested dynamic variable values in CAPTURER."
  (setf (special-values capturer)
	  (loop for sym in (special-variables capturer)
	     collect (symbol-value sym))))

(defun restore-specials (capturer)
  "Assign all CAPTURER's dynamic variables their captured values."
  (loop for sym in (special-variables capturer)
        for val in (special-values capturer)
        do (setf (symbol-value sym) val)))

(defun special-value (capturer symbol)
  (nth (position symbol (special-variables capturer) :test #'eq)
       (special-values capturer)))

(define-setf-expander special-value (capturer symbol)
  (with-unique-names (capturer-var value-cons store)
    (values `(,capturer-var ,value-cons)
	    `(,capturer
	      (nthcdr (position ,symbol (special-variables ,capturer-var)
				:test #'eq)
		      (special-values ,capturer-var)))
	    (list store)
	    `(setf (car ,value-cons) ,store)
	    `(car ,value-cons))))

(declaim (inline call/captured-specials)
	 (ftype (function (t (function () *)) *)
		call/captured-specials))
(defun call/captured-specials (capturer proc)
  "Answer PROC's value, called with CAPTURER's special variables
bound, and saved to their new values after PROC finishes or escapes."
  (progv (special-variables capturer) (special-values capturer)
    (unwind-protect (funcall proc)
      (capture-specials capturer))))