;;;                             expd.pcs                             4/9/91
;;; C. David Boyer
;;;
;;; This file implements an expander for TI-Scheme.
;;;
;;; Includes: macro, define, let, and, or, cond, case
;;;

(define dobegin
  (lambda (es)
    (if (null? (cdr es))
	(car es)
	(cons 'begin es))))

(define install-expander
  (lambda (name expander)
    (if (and (symbol? name) (proc? expander))
	(putprop name expander '*scheme*macro*)
	(error 'install-expander 
	       "Invalid Name or Function: ~s ~s" name expander))))

(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)
	 (not (null? (getprop x '*scheme*macro*))))))

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

(define expand
  (lambda (e)
    (if (atom? e) 
	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))))))

(define expand-file
  (lambda (f-in f-out)
    (let ((inp (open-input-file f-in))
	  (outp (open-output-file f-out)))
      (let loop ((x (read inp)))
	(if (eof-object? x)
	    (begin
	      (close-input-port inp)
	      (close-output-port outp))
	    (begin
	      (pp (expand x) outp)
	      (newline outp)
	      (loop (read inp))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The following are inserted from macros.s ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DEFINE
(install-expander
 'define
 (lambda (e)
   (if (syntax-check? '(define * **) e)
       (cons 'set! (cdr e))
       (if (syntax-check? '(define (* ** ...) **) e)
	   `(set! ,(caadr e)
	      (lambda ,(cdadr e) ,(caddr e)))
	   (else (error 'Syntax "Invalid syntax for Define: ~s" e))))))


;;; LET
;;; (let ((v e) ...) e1 ...)
;;; (let name ((v e) ...) e1 ...)   Named Let
(let ((expand-named-let
	(lambda (e)
	  (let ((name (cadr e)))
	    `(((lambda (,name)
		 (set! ,name (lambda ,(map car (caddr e)) ,@(cdddr e)))
		 ,name)
	       (void))
	      ,@(map cadr (caddr e))))))
      (expand-let
	(lambda (e)
	  `((lambda ,(map car (cadr e)) ,@(cddr e))
	    ,@(map cadr (cadr e))))))
  (install-expander          
    'let                      
    (lambda (e)
      (if (syntax-check? '(let * ((* **) ...) ** ** ...) e)
	  (expand-named-let e)
	  (if (syntax-check? '(let ((* **) ...) ** ** ...) e)
	      (expand-let e)
	      (error 'Syntax-Check "Invalid Let: " e))))))

(install-expander
  'let*
  (lambda (e)
    (if (syntax-check? '(let* ((* **) ...) ** ** ...) e)
	(let loop ((ids (map car (cadr e)))
		   (vals (map cadr (cadr e))))
	  (if (null? ids)
	      (dobegin (cddr e))
	      `((lambda (,(car ids))
		  ,(loop (cdr ids)(cdr vals)))
		,(car vals))))
	(error 'Syntax "Invalid let* syntax: ~s" e))))

(install-expander
  'letrec
  (lambda (e)
    (if (syntax-check? '(letrec ((* **) ...) ** ** ...) e)
	(let loop ((bps (cadr e)) (inits '()) (sets '()))
	  (if (null? bps)
	      `(let ,inits ,@sets ,@(cddr e))
	      (loop (cdr bps) 
		    (cons (list (caar bps) #f) inits)
		    (cons `(set! ,(caar bps) ,(cadar bps)) sets))))
	(error 'Syntax "Invalid Letrec: " e))))

(install-expander
  'rec
  (lambda (e)
    (if (syntax-check? '(rec * **) e)
	`(let ((,(cadr e) ,(caddr e)))
	   (set! ,(cadr e) ,(caddr e))
	   ,(cadr e))
	(error 'Syntax "Invalid Syntax for REC: " e))))

(install-expander
  'and
  (lambda (e)
    (let loop ((args (cdr e)))
      (cond
	((null? args)  #t)
	((null? (cdr args))
	 (car args))
	(else `(if ,(car args) ,(loop (cdr args)) #f))))))

(install-expander
  'or
  (lambda (e)
    (let loop ((args (cdr e)))
      (cond
	((null? args) #f)
	((null? (cdr args)) (car args))
	(else (let ((val (gensym)))
		`(let ((,val ,(car args)))
		   (if ,val ,val ,(loop (cdr args))))))))))

(install-expander
  'cond
  (lambda (e)
    (if (syntax-check? '(cond (** ** ...) ...) e)
	(let loop ((args (cdr e)))
	  (if (null? args)                    ;;; (cond)
	      '|#unspecified|
	      (let ((test-exp (caar args))
		    (exps (cdar args)))
		(cond
		  ((or (eq? test-exp 'else)   ;;; (cond (else ...))
		       (eq? test-exp #t))     ;;; (cond (#t ...))
		   (if (null? exps)           ;;; (cond (else)) *See Note Top
		       #t
		       (dobegin exps)))
		  ((null? exps)               ;;; (cond (test) ...)
		   `(or ,test-exp ,(loop (cdr args))))
		  (else `(if ,test-exp        ;;; (cond (test e1 e2 ...) ...)
			     ,(dobegin exps)
			     ,(loop (cdr args))))))))
	(error 'Syntax "Invalid Cond: ~s" e))))

(letrec ((expand-case
	   (lambda (k args)
	     (if (null? args) 
		 #f
		 (let ((p (caar args))
		       (es (dobegin (cdar args))))
		   (cond
		     ((eq? p 'else) es)
		     ((pair? p)
		      (case (length p)
			(1 `(if (eqv? ,(car p) ,k)
				,es
				,(expand-case k (cdr args))))
			(2 `(if (or (eqv? ,(car p) ,k)
				    (eqv? ,(cadr p) ,k))
				,es
				,(expand-case k (cdr args))))
			(else `(if (memv k ',p) 
				   ,es
				   ,(expand-case k (cdr args))))))
		     (else `(if (eqv? ,p ,k)
				,es
				,(expand-case k (cdr args))))))))))

  (install-expander
    'case
    (lambda (e)
      (if (syntax-check? '(case (** ** ...) (** ** ** ...) ...) e)
	  (let ((v (gensym)))
	    `(let ((,v ,(cadr e)))
	       ,(expand-case v (cddr e))))
	  (if (syntax-check? '(case * (** ** ** ...) ...) e)
	      (expand-case (cadr e) (cddr e))
	      (error 'Syntax "Invalid Case Statement: " e))))))

;;; UNLESS
(install-expander
  'unless
  (lambda (e)
    (if (syntax-check? '(unless ** ** ** ...) e)
	`(if ,(cadr e) #f ,(dobegin (cddr e)))
	(error 'Syntax "Invalid Unless Statement: ~s" e))))

;;; WHEN
(install-expander
  'when
  (lambda (e)
    (if (syntax-check? '(when ** ** ** ...) e)
	`(if ,(cadr e) ,(dobegin (cddr e)) #f)
	(error 'Syntax "Invalid When Statement: ~s" e))))