;; Copyright (C) 1999 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE library with other files
;; to produce an executable, this does not by itself cause the
;; resulting executable to be covered by the GNU General Public License.
;; Your use of that executable is in no way restricted on account of
;; linking the GUILE library code into it.
;;
;; This exception does not however invalidate any other reasons why
;; the executable file might be covered by the GNU General Public License.
;;
;; This exception applies only to the code released by the
;; Free Software Foundation under the name GUILE.  If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, as the General Public License permits, the exception does
;; not apply to the code that you add in this way.  To avoid misleading
;; anyone as to the status of such modified files, you must delete
;; this exception notice from them.
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.

;;;; "Macroexpand.scm", macro expansion, respecting hygiene.
;;; Author: Radey Shouman

;; It is possible to break MACRO:EXPAND by redefining primitive
;; syntax, eg LAMBDA, LET, QUOTE to different primitive syntax,
;; or by defining any of  @LAMBDA, @LET, @LET*, @LETREC, @DO,
;; or @EXPAND as primitive syntax.

;; We still need LET-SYNTAX and LETREC-SYNTAX.

(define macro:expand
  (let (($lambda (renamed-identifier 'lambda '()))
	($let (renamed-identifier 'let '()))
	($let* (renamed-identifier 'let* '()))
	($letrec (renamed-identifier 'letrec '()))
	($do (renamed-identifier 'do '()))
	($define (renamed-identifier 'define '()))
	($quote (renamed-identifier 'quote '()))
	($quasiquote (renamed-identifier 'quasiquote '()))
	($unquote (renamed-identifier 'unquote '()))
	($unquote-splicing (renamed-identifier 'unquote-splicing '()))
	($case (renamed-identifier 'case '()))
	($cond (renamed-identifier 'cond '()))
	($begin (renamed-identifier 'begin '()))
	($if (renamed-identifier 'if '()))
	($and (renamed-identifier 'and '()))
	($or (renamed-identifier 'or '()))
	($set! (renamed-identifier 'set! '()))
	($delay (renamed-identifier 'delay '()))
	($syntax-quote (renamed-identifier 'syntax-quote '()))
	($@apply (renamed-identifier '@apply '()))
	($else (renamed-identifier 'else '()))
	(@lambda (renamed-identifier '@lambda '()))
	(@let (renamed-identifier '@let '()))
	(@let* (renamed-identifier '@let* '()))
	(@letrec (renamed-identifier '@letrec '()))
	(@do (renamed-identifier '@do '()))
	(@expand (renamed-identifier '@expand '())))

    (define expander
      (macro:compile-syntax-rules
       '(syntax-rules (lambda let letrec let* do @let*)
	  ((_ (lambda ?formals ?body ...))
	   (@lambda ?formals ?body ...))

	  ((_ (let ((?name ?val) ...) ?body ...))
	   (@let ((?name ...) ?val ...) ?body ...))
	  ((_ (let ?proc ((?name ?val) ...) ?body ...))
	   (@expand
	    (letrec ((?proc (lambda (?name ...) ?body ...)))
	      (?proc ?val ...))))

	  ((_ (letrec ((?name ?val) ...) ?body ...))
	   (@letrec ((?name ...) ?val ...) ?body ...))

	  ((_ (let* () ?body ...))
	   (@let (()) ?body ...))
	  ((_ (let* ((?name1 ?val1) (?name ?val) ...) ?body ...))
	   (@expand
	    (@let* (?name1 ?val1) (let* ((?name ?val) ...) ?body ...))))
	  ((_ (@let* (?name ?val ...) (let* () ?body ...)))
	   (@let* (?name ?val ...) ?body ...))
	  ((_ (@let* (?name ?val ...)
		(let* ((?name2 ?val2) (?name3 ?val3) ...) ?body ...)))
	   (@expand
	    (@let* (?name ?val ... ?name2 ?val2)
	      (let* ((?name3 ?val3) ...) ?body ...))))
	  ((_ (@let* (?name ?val ...) ?body ...))
	   (@let* (?name ?val ...) ?body ...))

	  ((_ (do ((?var ?init ?step) ...)
		  (?test ?clause ...)
		?body ...))
	   (@do (?var ...) (?init ...)
	     (?test ?clause ...)
	     (?body ...)
	     (?step ...)))

	  ((_ ?form)
	   ?form))
       '()))

    (define (simplify-identifiers expr env)
      (let simplify ((expr expr))
	(cond ((identifier? expr)
	       (let ((sym (identifier->symbol expr)))
		 (if (identifier-equal? sym expr env) sym expr)))
	      ((pair? expr)
	       (cons (simplify (car expr))
		     (simplify (cdr expr))))
	      (else expr))))

    (define (unpaint expr)
      (cond ((identifier? expr)
	     (identifier->symbol expr))
	    ((pair? expr)
	     (cons (unpaint (car expr)) (unpaint (cdr expr))))
	    ((vector? expr)
	     (list->vector (map unpaint (vector->list expr))))
	    (else expr)))

    (define (defines->bindings defs)
      (reverse				;purely cosmetic
       (map (lambda (b)
	      (if (pair? (cadr b))
		  (list (caadr b)
			(cons $lambda (cons (cdadr b) (cddr b))))
		  (cdr b)))
	    defs)))

    (define (expand-define expr env)
      (let ((binding (car (defines->bindings (list expr)))))
	(cons (simplify-identifiers $define env)
	      (list (simplify-identifiers (car binding) env)
		    (macro:expand (cadr binding) env)))))

    (define (expand-body expr-list env)
      (let loop ((defines '())
		 (exprs expr-list))
	(if (null? exprs) #f	; should check higher up.
	    (let ((exp1 (macro:expand (car exprs) env)))
	      (if (and (pair? exp1)
		       (identifier? (car exp1))
		       (identifier-equal? (car exp1) $define env))
		  (loop (cons exp1 defines) (cdr exprs))
		  (if (null? defines)
		      (cons exp1 (expand* (cdr exprs) env))
		      (let ((bindings (defines->bindings defines)))
			(list
			 (macro:expand
			  (cons $letrec (cons bindings exprs))
			  env)))))))))

    (define (expand* exprs env)
      (map (lambda (x)
	     (macro:expand x env))
	   exprs))

    ;;(@lambda formals body ...)
    (define (expand-lambda expr env)
      (let* ((formals (cadr expr))
	     (body (cddr expr))
	     (bound
	      (let recur ((f formals))
		(cond ((null? f) '())
		      ((pair? f) (cons 'required (recur (cdr f))))
		      ((identifier? f) (list 'rest-list))
		      (else (error 'lambda 'bad-formals expr)))))
	     (env1 (extended-environment formals bound env)))
	(cons (simplify-identifiers $lambda env)
	      (cons (simplify-identifiers formals env1)
		    (expand-body body env1)))))

    ;;(@let ((formals) bindings) body ...)
    (define (expand-let expr env)
      (let* ((formals (caadr expr))
	     (bindings (expand* (cdadr expr) env))
	     (env1 (extended-environment formals
					       (map (lambda (x) 'let) formals)
					       env)))
	(cons (simplify-identifiers $let env)
	      (cons (map list formals bindings)
		    (expand-body (cddr expr) env1)))))

    (define (expand-let* expr env)
      (let loop ((inp (cadr expr))
		 (formals '())
		 (bindings '())
		 (env1 env))
	(if (null? inp)
	    (cons (simplify-identifiers $let* env)
		  (map list (reverse formals) (reverse bindings))
		  (expand-body (cddr expr) env1))
	    (loop (cddr inp)
		  (cons (car inp) formals)
		  (cons (macro:expand (cadr inp) env1) bindings)
		  (extended-environment (car inp) 'let* env1)))))

    ;;(@letrec ((formals) bindings) body ...)
    (define (expand-letrec expr env)
      (let* ((formals (caadr expr))
	     (env1 (extended-environment
		   formals
		   (map (lambda (x) 'letrec) formals)
		   env))
	     (bindings (expand* (cdadr expr) env1)))
	(cons (simplify-identifiers $letrec env)
	      (cons (map list formals bindings)
		    (expand-body (cddr expr) env1)))))

    ;;(@do vars inits (test clause ...) (body ...) steps)
    (define (expand-do expr env)
      (let* ((vars (cadr expr))
	     (inits (expand* (caddr expr) env))
	     (env1 (extended-environment
		   vars (map (lambda (x) 'do) inits) env))
	     (steps (expand* (list-ref expr 5) env1)))
	(cons (simplify-identifiers $do env)
	      (cons
	       (map list vars inits steps)
	       (cons (expand* (cadddr expr) env1)
		     (expand* (list-ref expr 4) env1))))))

    (define (expand-quote expr env)
      (let ((obj (cadr expr)))
	(if (or (boolean? obj)
		(number? obj)
		(string? obj))
	    obj
	    (list (simplify-identifiers $quote env)
		  (unpaint obj)))))

    (define (expand-quasiquote expr env)
      (list (simplify-identifiers $quasiquote env)
	    (let qq ((expr (cadr expr))
		     (level 0))
	      (cond ((vector? expr)
		     (list->vector (qq (vector->list expr) level)))
		    ((not (pair? expr))
		     (unpaint expr))
		    ((not (identifier? (car expr)))
		     (cons (qq (car expr) level) (qq (cdr expr) level)))
		    ((identifier-equal? (car expr) $quasiquote env)
		     (list (simplify-identifiers $quasiquote env)
			   (qq (cadr expr) (+ level 1))))
		    ((or (identifier-equal? (car expr) $unquote env)
			 (identifier-equal? (car expr) $unquote-splicing env))
		     (list (simplify-identifiers (car expr) env)
			   (if (zero? level)
			       (macro:expand (cadr expr) env)
			       (qq (cadr expr) (- level 1)))))
		    (else
		     (cons (qq (car expr) level)
			   (qq (cdr expr) level)))))))

    (define (expand-case expr env)
      (cons (simplify-identifiers $case env)
	    (cons (macro:expand (cadr expr) env)
		  (map (lambda (clause)
			 (cond ((pair? (car clause))
				(cons (unpaint (car clause))
				      (expand* (cdr clause) env)))
			       ((and (identifier? (car clause))
				     (identifier-equal? $else
							(car clause) env))
				(cons (simplify-identifiers
				       (car clause) env)
				      (expand* (cdr clause) env)))
			       (else (error 'macro:expand 'case
					    "bad clause" expr))))
		       (cddr expr)))))

    (define (expand-cond expr env)
      (cons (simplify-identifiers $cond env)
	    (map (lambda (clause) (expand* clause env))
		 (cdr expr))))

    ;; for IF, BEGIN, SET!
    (define (expand-simple expr env)
      (cons (simplify-identifiers (car expr) env)
	    (expand* (cdr expr) env)))

    (define (expand-primitives expr env)
      (let loop ((expr (list '@expand expr)))
	(let* ((expanded (expander expr env))
	       (head (car expanded)))
	  (cond ((identifier-equal? @LAMBDA head env)
		 (expand-lambda expanded env))
		((identifier-equal? @LET head env)
		 (expand-let expanded env))
		((identifier-equal? @LET* head env)
		 (expand-let* expanded env))
		((identifier-equal? @LETREC head env)
		 (expand-letrec expanded env))
		((identifier-equal? @DO head env)
		 (expand-do expanded env))
		((identifier-equal? $QUOTE head env)
		 (expand-quote expanded env))
		((identifier-equal? $QUASIQUOTE head env)
		 (expand-quasiquote expanded env))
		((identifier-equal? $BEGIN head env)
		 (expand-simple expanded env))
		((identifier-equal? $IF head env)
		 (expand-simple expanded env))
		((identifier-equal? $AND head env)
		 (expand-simple expanded env))
		((identifier-equal? $OR head env)
		 (expand-simple expanded env))
		((identifier-equal? $SET! head env)
		 (expand-simple expanded env))
		((identifier-equal? $DELAY head env)
		 (expand-simple expanded env))
		((identifier-equal? $@APPLY head env)
		 (expand-simple expanded env))
		((identifier-equal? $CASE head env)
		 (expand-case expanded env))
		((identifier-equal? $COND head env)
		 (expand-cond expanded env))
		((and (identifier-equal? $DEFINE head env)
		      (null? (environment->tree env)))
		 (expand-define expanded env))
		((identifier-equal? $SYNTAX-QUOTE head env)
		 (cons (simplify-identifiers head env)
		       (cdr expanded)))
		((identifier-equal? @EXPAND head env)
		 (loop expanded))
		(else
		 (print 'macro:expand
			"Warning: unknown primitive syntax" (car expanded))
		 expanded)))))

    (lambda (expr env)
      (let loop ((expr expr))
	(let ((expanded (@macroexpand1 expr env)))
	  (cond ((not expanded)
		 (cond ((pair? expr)
			(if (list? expr)
			    (expand* expr env)
			    (print 'macro:expand "expansion not a list" expr)))
		       ((identifier? expr)
			(simplify-identifiers expr env))
		       (else expr)))
		((eq? expanded expr)
		 (expand-primitives expr env))
		(else
		 (loop expanded))))))))

;;; Local Variables:
;;; eval: (put 'identifier-case 'scheme-indent-function 1)
;;; End: