;;; -*- Lisp -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;; Macro memoization for Spice Lisp.
;;; Written by Skef Wholey.
;;;
;;; If *Macroexpand-Hook* is set to Memoize-Macro-Call, macro calls will
;;; be memoized.
;;;
;;; We replace calls to a macro with calls to %Memoized-Macro-Call, a macro
;;; of 4 arguments.  These arguments are the name of the macro, the
;;; definition of the macro at the time of expansion, the expanded form,
;;; and a copy of the original form.  All this information lets us re-expand
;;; the form if the macro is redefined, or substitute the original form
;;; back in if the macro is redefined as a function.
;;;

(defun memoize-macro-call (expander expression)
  "Replaces the call to a macro in Expression with a call to the expanded form
  with magic stuff wrapped around it."
  (if (eq (car expression) '%memoized-macro-call)
      (if (eq expander (cadr expression))
	  (caddr expression)
	  (funcall expander expression))
      (let* ((macro (car expression))
	     (copy (cons macro (cdr expression)))
	     (expansion (funcall expander expression)))
	(rplaca expression '%memoized-macro-call)
	(rplacd expression `(,macro ,expander ,expansion ,copy))
	expansion)))

(defmacro %memoized-macro-call (macro expander expansion copy &whole stuff)
  "Evaluates an expanded call to the given Macro, fixing stuff up if its
  definition has changed."
  (let ((current (macro-function macro)))
    (cond ((eq current expander)
	   expansion)
	  (current
	   (setf (caddr stuff) current)
	   (setf (cadddr stuff) (funcall current copy))
	   (cadddr stuff))
	  (t
	   (displace stuff copy)))))

(defun displace (x y)
  "Replaces the CAR and CDR of X with the CAR and CDR of Y, returning the
  modified X."
  (rplaca x (car y))
  (rplacd x (cdr y)))