;;;                             macros.s                               4/9/91
;;; C. David Boyer
;;;
;;; Compile Options:
;;;
;;; Notes: Depends on macrop.s, syntax.s
;;;
;;;        Some macros have an extend-syntax implementation but it is not
;;;        tested code, rather pseudo-code to explain the semantics 
;;;        of the expander
;;;
;;;        (cond (else)) ==> #t
;;;
;;;
;;; Includes: macro, define, let, let*, letrec, rec, and, or, cond, case, 
;;;           time, do (not implemented), define-macro (not implemented)

(letrec ([syntax-check? syntax-check?])
(define dobegin
  (lambda (es)
    (if (null? (cdr es))
	(car es)
	(cons 'begin es))))

;;; MACRO
(install-expander
 'macro
 (lambda (e)
   (let ((name (cadr e))(expander (caddr e)))
     `(begin
        (install-expander ',name ,expander)
        ',name))))

(install-expander 
 'alias 
 (lambda (e)
   `(begin
      (install-expander ',(cadr e)
			(lambda (e2) (cons ',(caddr e) (cdr e2))))
      ',(cadr e))))
 
;;; DEFINE-MACRO!
;;; ...
 
 
;;; 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) ,@(cddr e)))
	   (else (error 'Syntax "Invalid define syntax: ~s~%~a~%~a" e
			"Usage: (define sym exp)"
			"or:    (define (sym ...) exp)"))))))
  
;;; 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 "Invalid let syntax: ~s~%~a~%~a" e
		     "Usage: (let ([sym exp] ...) exp ...)"
		     "or:    (let sym ([sym exp] ...) exp ...)"))))))

;;; LET*
(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~%~a" e
	       "Usage: (let* ([sym exp] ...) exp ...)"))))

;;; LETREC
;;; (extend-syntax (letrec)
;;;   [(letrec ([id val] ...) e1 e2 ...)
;;;    (let ([id #f] ...)
;;;      (set! id val) ...
;;;      e1 e2 ...)])
(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) (void)) inits)
		    (cons `(set! ,(caar bps) ,(cadar bps)) sets))))
	(error 'Syntax "Invalid Letrec: ~s~%~a" e
	       "Usage: (letrec ([sym exp] ...) exp ...)"))))

;;; REC
;;; (extend-syntax (rec)
;;;   [(rec x v)
;;;    (let ([x v])
;;;      (set! x v)
;;;      x)])
(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: ~s" e))))


;;; AND
;;; (extend-syntax (and)
;;;    ((and) #t)
;;;    ((and x) x)
;;;    ((and x y ...) (if x (and y ...) #f)))
;;; > (expand '(and* x y))                             
;;;   (if x y #f)
;;;  Chez 3.9
;;; >(expand '(and x y))
;;;  ((lambda (#:g0) (if #:g0 y #:g0)) x)
;;; The following implements the extend-syntax definition above: Not Chez 3.9
(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))))))

;;; OR
;;; (extend-syntax (or)
;;;   ((or) #f)
;;;   ((or x) x)
;;;   ((or x y ...)
;;;    (with ((val (gensym)))
;;;          (let ((val x))
;;;            (if val val (or y ...))))))
(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))))))))))

;;; COND
;;;(extend-syntax (cond else)
;;;  ((cond) #unspecified)
;;;  ((cond (else e1 e2 ...)) (begin e1 e2 ...))
;;;  ((cond (#t e1 e2 ...)) (begin e1 e2 ...))           ;;; *Optimization*
;;;  ((cond (tst) rest ...) (or tst (cond rest ...)))
;;;  ((cond (tst e1 e2 ...) rest ...) 
;;;   (if tst (begin e1 e2 ...) (cond rest ...)))
;;;  ((cond (tst => recipient) ...)
;;;   (let ((gen tst))
;;;     (if gen (recipient gen) ...)))

(install-expander
  'cond
  (lambda (e)
    (if (syntax-check? '(cond (** ** ...) ...) e)
	(let loop ((args (cdr e)))
	  (if (null? args)                    ;;; (cond)
	      (begin 
		(printf "Warning in expand: No else clause specified in cond expression~%")
		(void))
	      (let ((test-exp (caar args))
		    (exps (cdar args)))
		(unless (length-check exps)
			(error 'cond "Invalid Syntax ~s" exps))
		(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))))
		  ((and (pair? exps) (eq? (car exps) '=>)(pair? (cdr exps)))
		   (let ((gen (gensym)))
		     `(let ((,gen ,test-exp))
			(if ,gen
			    (,(cadr exps) ,gen)
			    ,(loop (cdr args))))))
		  (else `(if ,test-exp        ;;; (cond (test e1 e2 ...) ...)
			     ,(dobegin exps)
			     ,(loop (cdr args))))))))
	(error 'Syntax "Invalid Cond: ~s" e))))

;;; CASE
;;; (extend-syntax (case else)
;;;   ((case k) #f)
;;;   ((case (f arg1 ...) rest ...)
;;;    (let ((k (f arg1 ...)))                ;;; K is a gensym
;;;      (case k rest ...)))
;;;   ((case k (else e1 e2 ...))
;;;    (begin e1 e2 ...))
;;;   ((case k ((p) e1 e2 ...) rest ...)
;;;    (if (eqv? (car p) k)
;;;        (begin e1 e2)
;;;        (case k rest ...)))
;;;   ((case k ((p1 p2) e1 e2 ...) rest ...)
;;;    (if (or (eqv? p1 k)(eqv? p2 k))
;;;        (begin e1 e2 ...)
;;;        (case k rest ...)))
;;;   ...)
(letrec ((expand-case
	   (lambda (k args)
	     (if (null? args)
		 (begin
		   (printf "Warning in expand: No else clause specified in case expression~%")
		   #f)
		 (let ((p (caar args))
		       (es (dobegin (cdar args))))
		   (cond
		     ((eq? p 'else) es)
		     ((pair? p)
		      (case (length p)
			(1 `(if (,(if (number? (car p)) 'eqv? 'eq?)
				 ',(car p) ,k)
				,es
				,(expand-case k (cdr args))))
			(2 `(if (or (,(if (number? (car p)) 'eqv? 'eq?)
				     ',(car p) ,k)
				    (,(if (number? (car p)) 'eqv? 'eq?)
				     ',(cadr p) ,k))
				,es
				,(expand-case k (cdr args))))
			(else `(if (,(if (ormap number? p) 'memv 'memq)
				    ,k ',p)
				   ,es
				   ,(expand-case k (cdr args))))))
		     (else `(if (,(if (number? p) 'eqv? 'eq?)
				 ',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: ~s" e))))))
	 
;;; DO
(install-expander
 'do
 (lambda (e)
   (if (syntax-check? '(do ((* ** ** ...) ...) 
			   (** ** ...)
			 ** ...)
		      e)
       (let ((loop (gensym)))
	 `(letrec ((,loop
		    (lambda ,(map car (cadr e))
		      (if ,(caaddr e)
			  (begin ,@(cdaddr e))
			  (begin ,@(cdddr e)
				 (,loop ,@(map (lambda (x)
						 (if (fx= (length-check x) 3)
						     (caddr x)
						     (car x)))
					       (cadr e))))))))
	    (,loop ,@(map cadr (cadr e)))))
       (error 'Syntax "Invalid Do Syntax: ~s" e))))


;;; UNLESS
(install-expander
  'unless
  (lambda (e)
    (if (syntax-check? '(unless ** ** ** ...) e)
	`(if ,(cadr e) (void) ,(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)) (void))
	(error 'Syntax "Invalid When Statement: ~s" e))))

;;; TIME
(install-expander
 'time
 (lambda (e)
   (if (fx= (length-check e) 2)
       `(let* ((\#start (runtime))
	       (ans ,(cadr e))
	       (\#stop (runtime)))
	  (printf "~ss ~c~sticks~%"
		  (/ (- \#stop \#start) 18) #\tab (- \#stop \#start))
	  ans)
       (error 'Syntax "Invalid Time Syntax: ~s~%~a~%~a~%~a" e
	      "Usage:   (time exp)"
	      "Returns: value of exp"
	      "Example: (time (foo a1 a2))"))))


(install-expander
 '(1+ add1 sub1 1-)
 (lambda (e)
   (let ((bco-op 
	  (cdr (assq (car e) 
		     '((1+ . +)(add1 . +)(1- . -)(sub1 . -))))))
     (if (fx= (length-check e) 2)
	 `(,bco-op ,(cadr e) 1)
	 (error 'compile "Invalid arguments to primitive ~s" e)))))

) ;;; letrec