;;;                          Macro Primitives                           4/9/91
;;;
;;; C. David Boyer
;;; Compiler Options: Inline
;;;
;;; Notes:
;;; The expand-top function only looks in the first position. It does not 
;;; recursively descend the expression. It is intended to be used by the 
;;; compiler when the compiler detects an application.
;;;

;;; (install-expander name function) ==> #unspecified
(define install-expander
  (lambda (name expander)
    (if (and (or (symbol? name)
		 (andmap symbol? name))
	     (procedure? expander))
	(if (symbol? name)
	    (putprop name '*scheme*macro* expander)
	    (map (lambda (name) (putprop name '*scheme*macro* expander)) name))
	(error 'install-expander 
	       "Invalid Name: ~s OR Function: ~s" name expander))))

(define remove-expander
  (lambda (name)
    (remprop name '*scheme*macro*)))

(define expand-top
  (lambda (e)
    (if (and (pair? e) (symbol? (car e)))
	(let ((macro-expander (getprop (car e) '*scheme*macro*)))
	  (if macro-expander
	      (macro-expander e)
	      e))
	e)))

(define expander?
  (lambda (x)
    (and (symbol? x)
	 (getprop x '*scheme*macro*))))

(define get-expander
  (lambda (e)
    (getprop e '*scheme*macro*)))


(define expand
  (lambda (e)
    (if (pair? e) 
	(cond
	  ((eq? (car e) 'quote) e)
	  ((eq? (car e) 'lambda)
	   `(lambda ,(cadr e) ,@(map expand (cddr e))))
	  ((expander? (car e))
	   (expand ((get-expander (car e)) e)))
	  (else (map expand e)))
	e)))

"macrop.ss"