(in-package "MEVAL")

;;
;; following code adapted from usenet posting
;; author Peter S. Housel
;; 
;;


(defun expand-macro (form env)
  (if (not (consp form)) 
      form 
    (case (car form) 
      ((quote) form)
      ((lambda) `(lambda ,(cadr form) 
                   ,@(mapcar #'(lambda (z) (expand-macro z env)) (cddr form)))) 
      ((setq) `(setq ,(cadr form) 
                     ,(expand-macro (caddr form) env))) 
      ((if) `(if ,@(mapcar #'(lambda (z) (expand-macro z env)) (cdr form)))) 
      (t (if (macro-tag-p (car form))
             (let ((mt (macro-transformer (car form))))
               (expand-macro 
                (eval `(,(car mt) ',form) (cdr mt)) env)) 
           (mapcar #'(lambda (z) (expand-macro z env)) form))))))       


(defparameter *macro-transformers* '()) 

(defun macro-tag-p (tag) 
  (and (symbolp tag) 
       (assoc tag *macro-transformers*))) 

(defun macro-transformer (tag) 
  (cdr (assoc tag *macro-transformers*))) 

(defun macro-transformer-setq (tag transformer) 
  (let ((pair (assoc tag *macro-transformers*))) 
    (if pair 
        (setf (cdr pair) transformer) 
      (setf *macro-transformers* 
            (cons (cons tag transformer) 
                  *macro-transformers*)))))


;;
;; end of adapted code
;;