; forms+files is a list of pairs; the car is a filename or #f, the cdr a list of forms
; returns:
; - a list each element of which is a node or a promise of a node
; - a list each element of which is a pair consisting of the name of a
;   syntax definition, and the compiled template of the right-hand side
(define (expand-forms env forms+files) ; "env" -> "pkg"?
  (let ((scanned+envs
	 (map (lambda (forms+file)
		(let ((filename (car forms+file))
		      (forms (cdr forms+file)))
		  (let ((env (bind-source-file-name filename env)))
		    (receive (expanded expanded-for-syntax) (really-scan-forms forms env)
		      (list env
			    expanded
			    expanded-for-syntax)))))
	      forms+files)))
     (receive (expanded expanded-for-syntax)
	 (fold->2 (lambda (scanned+env expanded expanded-for-syntax)
		    (apply (lambda (env scanned more-expanded-for-syntax)
			     (values
			      (fold (lambda (form expanded)
				      ;; #### zap this
				      ;; (write (parse (expand form env) (env-phase env)))
				      ;; (newline)
				      ;; this avoids keeping the entire expanded source code around: 
				      ;; top-level forms are expanded as they are compiled
				      (cons (delay (parse->node (expand form env) env))
					    expanded))
				    scanned
				    expanded)
			      (append more-expanded-for-syntax expanded-for-syntax)))
			   scanned+env))
		  scanned+envs
		  '() '())
       (values (reverse expanded)
	       (reverse expanded-for-syntax)))))


;----------------
; Scanning for definitions.
;
; Returns a list of forms expanded to the point needed to distinguish
; definitions from other forms.  Definitions and syntax definitions are
; added to ENV.

(define (scan-forms forms env)
  (receive (expanded expanded-for-syntax)
      (really-scan-forms forms env)
    expanded))

; returns list of run forms, and reversed list of (pair template-or-node)
(define (really-scan-forms forms env)
  (let loop ((forms forms) (expanded '()) (expanded-for-syntax '()))
    (if (null? forms)
	(values (reverse expanded) expanded-for-syntax)
	(receive (rator stx)
	    (expand-head (car forms) env)
	  (let ((more-forms (cdr forms)))
	    (cond
	     ((not rator)
	      (loop more-forms (cons stx expanded) expanded-for-syntax))
	     ((eq? rator operator/define)
	      (comp-env-define! env (define-name stx) usual-variable-type)
	      (loop more-forms
		    (cons stx expanded)
		    expanded-for-syntax))
	     ((eq? rator operator/define-syntax)
	      (loop more-forms
		    expanded
		    (cons (scan-define-syntax stx env) expanded-for-syntax)))
	     ((eq? rator operator/begin)
	      (loop (append (cdr (syntax-e stx)) more-forms)
		    expanded expanded-for-syntax))
	     (else
	      (loop more-forms (cons stx expanded) expanded-for-syntax))))))))

; this is before expansion and thus define-normalization, so kludge
(define (define-name stx)
  (let ((d (syntax-e (cadr (syntax-e stx)))))
    (if (stx-pair? d)
	(stx-car d)
	d)))

(define (scan-define-syntax stx env)
  (let ((e (syntax-e stx)))
    (let ((id (cadr e))
	  (source (caddr e)))
      (let ((loc
	     (comp-env-define! env id syntax-type 'syntax)))
	(receive (transform template-or-node) 
	    (process-syntax source
			    env
			    id
			    (comp-env-package env))
	  (set-contents! loc transform)
	  (cons (parse->node id env) template-or-node))))))

; returns optional operator + resultant syntax
(define (expand-head stx env)
  (let ((e (syntax-e stx))
	(ctx (syntax-object-context stx)))
    (cond
     ((not (pair? e))			; #### identifier-syntax
      stx)
     ((identifier? (car e))
      (receive (lbl rator)
	  (resolve+lookup (car e) env)
	;; lbl may be an operator
	;; or binding may have an operator in its static field
	(cond
	 ((operator? rator)
	  (values rator stx))
	 ((eq? rator 'stop) 
	  (values #f stx))
	 ((binding? rator)
	  (let ((s (binding-static rator)))
	    (cond
	     ((eq? s 'syntax)
	      ;; #### code duplication with `expand'
	      (let ((transform (contents (binding-place rator))))
		(let ((mrk (make-mark (car e) (comp-env-phase env) (macro-transform-env transform)))
		      (env-cell (make-cell env)))
		  (let ((expanded 
			 (let-fluids $expand-time-environment env-cell
				     $mark mrk
				     (lambda () 
				       (apply-transformer (macro-transform-procedure transform)
							  (add-mark stx mrk))))))
		    (expand-head (add-mark expanded mrk) env)))))
	     (else (values #f stx)))))
	 (else (values #f stx)))))
     (else
      (values #f stx)))))

(define (apply-transformer transformer stx)
  (cond
   ((procedure? transformer)
    (transformer stx))
   ((transformer/free-identifier=?? transformer)
    ((transformer/free-identifier=?-proc transformer)
     stx
     free-identifier=?))
   (else
    (assertion-violation 'apply-transformer "invalid transformer" transformer stx))))

; This is used by the ,expand command.

(define (expand-form form env)
  (parse->node (expand form env) env))

;; #### "env" -> "cenv"?

(define (expand stx env)
  (let ((e (syntax-e stx))
	(ctx (syntax-object-context stx)))

    (define (expand->plain-call)
      (expand (make-syntax-object (cons syntax/call e) ctx 0)
	      env))

    (cond
     ((not (pair? e))
      (if (identifier? e)
	  (call-with-values
	      (lambda () (resolve+lookup e env))
	    (lambda (lbl l)
	      stx))			; #### identifier-syntax
	  stx))			    ; self-quoting or unbound variable
     ((identifier? (car e))
      (call-with-values
	  (lambda () (resolve+lookup (car e) env))
	(lambda (lbl rator)
	  (cond
	   ((operator? rator)
	    (expand-operator-form rator stx e env))
	   ((eq? rator 'stop) stx)
	   ((binding? rator)
	    (let ((s (binding-static rator)))
	      (cond
	       ((eq? 'syntax s)
		(let ((transform (contents (binding-place rator))))
		  (let ((mrk (make-mark (car e) (comp-env-phase env) (macro-transform-env transform)))
			(env-cell (make-cell env)))
		    (let ((expanded 
			   (let-fluids $expand-time-environment env-cell
				       $mark mrk
				       (lambda ()
					 (apply-transformer (macro-transform-procedure transform)
							    (add-mark stx mrk))))))
		      (expand (add-mark expanded mrk) (cell-ref env-cell))))))
	       (else
		;; operator is top-level value binding
		(expand->plain-call)))))
	   ((and (node? rator) (name-node? rator)) ; #### ???
	    ;; operator local value binding
	    (expand->plain-call))
	   (else
	    ;; operator is free variable
	    (expand->plain-call))))))
     (else
      ;; operator is compound expression
      ;; note we don't re-expand, unlike the regular Scheme 48 expander
      (expand->plain-call)))))

(define expanders
  (make-operator-table 
   (lambda (stx e env)
      ;; operator is compound expression
      (make-syntax-object (map (lambda (stx)
				 (expand stx env))
			       e)
			  (syntax-object-context stx)
			  0))))

(define (expand-operator-form op stx e env)
  ((operator-table-ref expanders (operator-uid op))
   stx e env))

(define (define-expander name proc)
  (operator-define! expanders name #f proc))

(define-expander 'define
  (lambda (stx e env)
    (make-syntax-object (list syntax/define
			      (cadr e)
			      (expand (caddr e) env))
			(syntax-object-context stx)
			0)))
			      

(define-expander 'call
  (lambda (stx e env)
    (make-syntax-object (cons syntax/call
			      (map (lambda (stx)
				     (expand stx env))
				   (cdr e)))
			(syntax-object-context stx)
			0)))

; this is the version without internal defines
(define-expander 'lambda
  (lambda (stx e env)
    (call-with-values
	(lambda () (bind-formals (cadr e) env (caddr e)))
      (lambda (new-formals env body)
	(make-syntax-object (list syntax/lambda
				  new-formals
				  (expand body env))
			    (syntax-object-context stx)
			    0)))))

(define-expander 'begin
  (lambda (stx e env)
    (make-syntax-object (cons syntax/begin
			      (map (lambda (e)
				     (expand e env))
				   (cdr e)))
			(syntax-object-context stx)
			0)))

; returns new formals + new env + new body
; #### need to check for duplicates
(define (bind-formals formals env body)
  (let ((formals-e (syntax-e formals))
	(ctx (syntax-object-context formals)))
    (if (identifier? formals)
	(bind-formal formals env body)
	(let loop ((formals-e formals-e)
		   (new-formals '())
		   (env env)
		   (body body))
	  (cond ((null? formals-e)
		 (values (make-syntax-object (reverse new-formals)
					     ctx 0)
			 env
			 body))
		((pair? formals-e)
		 (if (identifier? (car formals-e))
		     (call-with-values
			 (lambda () (bind-formal (car formals-e) env body))
		       (lambda (new-formal env body)
			 (loop (cdr formals-e)
			       (cons new-formal new-formals)
			       env
			       body)))
		     (syntax-violation 'lambda "invalid formal" formals (car formals-e))))
		((identifier? formals-e)
		 (call-with-values
		     (lambda () (bind-formal formals-e env body))
		   (lambda (new-formal env body)
		     (values (make-syntax-object (append (reverse new-formals) new-formal)
						 ctx 0)
			     env body))))
		(else
		 (syntax-violation 'lambda "invalid formals" formals formals-e)))))))

(define (bind-formal formal env body)
  (let* ((formal-e (syntax-e formal))
	 (var-new (make-sym formal-e))
	 (phase (comp-env-phase env))
	 (id-new (add-rename formal formal var-new phase)))
    (values id-new
	    (bind1 var-new (make-node operator/name id-new) env)
	    (add-rename body formal var-new phase))))

(define-expander 'quote
  (lambda (stx e env)
    (make-syntax-object (list syntax/quote
			      (cadr e))
			(syntax-object-context stx)
			0)))

(define-expander 'code-quote
  (lambda (stx e env)
    (make-syntax-object (list syntax/code-quote
			      (cadr e))
			(syntax-object-context stx)
			0)))

(define-expander 'let-syntax
  (lambda (stx e env)
    (expand-let-syntax stx env
		       (lambda (vars-new bindings env)
			 (bind vars-new 
			       (map (lambda (binding)
				      (let ((name (syntax-e (car binding))))
					(receive (transform template-or-node)
					    (process-syntax (cdr binding) env 
							    name env)
					  (make-binding syntax-type
							(make-location name transform)
							'syntax))))
				      bindings)
			       env)))))

(define-expander 'letrec-syntax
  (lambda (stx e env)
    (expand-let-syntax stx env
		       (lambda (vars-new bindings env)
			 (let* ((t-bindings
				 (map (lambda (binding)
					(make-binding syntax-type
						      (make-undefined-location (syntax-e (car binding)))
						      'syntax))
				      bindings))
				(new-env (bind vars-new t-bindings env)))
			   (for-each (lambda (binding t-binding)
				       (receive (transform template-or-node)
					   (process-syntax (cdr binding) new-env
							   (syntax-e (car binding)) new-env)
					 (set-contents! (binding-place t-binding)
							transform)))
				     bindings t-bindings)
			   new-env)))))

(define (expand-let-syntax stx env bind-env)
  (call-with-values
      (lambda () (scan-let-like stx #f #f))
    (lambda (_name bindings body)
      (let ((vars-new
	     (map (lambda (binding)
		    (make-sym (syntax-e (car binding))))
		  bindings))
	    (phase (comp-env-phase env)))
	(expand (fold-left (lambda (body binding var-new)
			     (add-rename body (car binding) var-new phase))
			   (body->expression body)
			   bindings vars-new)
		(bind-env vars-new bindings env))))))

; env-or-package is a package with `define-syntax' (compile-time
; environment otherwise), and it needs to be for reification.
; returns transform, template or node
(define (process-syntax form env name env-or-package)
  (receive (template-or-node thunk)
      (compile-time-eval form name env)
    (values (make-transform/macro (thunk)
				  env-or-package
				  syntax-type
				  name)
	    template-or-node)))

(define (compile-time-eval expr name env)
  (let* ((compile-syntax-node (package-macro-compile-syntax-node (comp-env-package env)))
	 (macro-env (comp-env-next-phase env))
	 (node (parse->node (expand-one-form macro-env expr) macro-env)))
    (receive (template thunk)
	(compile-syntax-node name node macro-env)
      (values (or template node) thunk))))

(define (expand-one-form env form)
  (expand (car (scan-forms (list form) env)) env))

(define (make-location name cont)
  (let ((loc (make-undefined-location name)))
    (set-contents! loc cont)
    loc))

(define-expander 'if
  (lambda (stx e env)
    (cond
     ((this-long? e 3)
      (make-syntax-object (list syntax/if
				(expand (cadr e) env)
				(expand (caddr e) env)
				syntax/unspecific)
			  (syntax-object-context stx)
			  0))
     ((this-long? e 4)
      (make-syntax-object (list syntax/if
				(expand (cadr e) env)
				(expand (caddr e) env)
				(expand (cadddr e) env))
			  (syntax-object-context stx)
			  0))
     (else
      (syntax-violation 'if "invalid expression" stx #f)))))

 ; #### identifier-syntax
(define-expander 'set!
  (lambda (stx e env)
    (if (and (this-long? e 3)
	     (identifier? (cadr e)))
	(make-syntax-object (list syntax/set!
				  (cadr e)
				  (expand (caddr e) env))
			    (syntax-object-context stx)
			    0)
	(syntax-violation 'set! "invalid expression" stx #f))))

; purely generated; we assume that all checking has been done by the
; macros that expand into this
(define-expander 'letrec
  (lambda (stx e env)
    (let loop ((specs (syntax-e (cadr e)))
	       (new-specs '()) ; list of syntax pairs
	       (env env)
	       (body (caddr e)))
      (if (null? specs)
	  (make-syntax-object (list syntax/letrec
				    (make-syntax-object
				     (map (lambda (spec)
					    (let ((p (syntax-e spec)))
					      (make-syntax-object (list (car p)
									(expand (cdr p) env))
								  (syntax-object-context spec)
								  0)))
					  (reverse new-specs))
				     (syntax-object-context (cadr e))
				     0)
				    (expand body env))
			      (syntax-object-context stx)
			      0)
	  (let* ((spec (car specs))
		 (binding (syntax-e spec))
		 (id (car binding))
		 (rhs (cadr binding))
		 (id-e (syntax-e id))
		 (var-new (make-sym id-e))
		 (phase (comp-env-phase env))
		 (id-new (add-rename id id var-new phase))
		 (rhs-new (add-rename rhs id var-new phase)))
	    (loop (cdr specs)
		  (cons (make-syntax-object (cons id-new rhs-new)
					    (syntax-object-context spec)
					    0)
			new-specs)
		  (bind1 var-new (make-node operator/name id-new) env)
		  (add-rename body id var-new phase)))))))

(define-expander 'primitive-procedure
  (lambda (stx e env)
    (make-syntax-object (list syntax/primitive-procedure (cadr e))
			(syntax-object-context stx)
			0)))

(define-expander '%file-name%
  (lambda (stx e env)
    (make-syntax-object (list syntax/quote (source-file-name env))
			'()
			0)))

(define (make-syntax-introducer)
  (let ((mrk (make-mark #f #f #f)))
    (lambda (stx)
      (add-mark stx mrk))))

(define (syntax-local-introduce stx)
  (add-mark stx (current-mark)))

(define (hash-combine/2 x y)
  (+ (* x 33) y))

(define make-definition-context-resolved-table
  (make-table-maker
   (lambda (p1 p2)
     (and (eq? (car p1) (car p2))	;name
	  (equal? (cdr p1) (cdr p2))))	;marks
   (lambda (p)
     (let ((name (car p))
	   (marks (cdr p)))
       (hash-combine/2 (cond
			((and (pair? marks)
			      (mark-identifier (car marks)))
			 => (lambda (id)
			      (symbol-hash (syntax-object-expr id))))
			(else 0))
		       (if (symbol? name)
			   (symbol-hash name)
			   (string-hash (sym-unique-string name))))))))

(define *next-definition-context-uid* 1)
(define (make-definition-context renames)
  (let ((uid *next-definition-context-uid*))
    (set! *next-definition-context-uid* (+ uid 1))
    (really-make-definition-context uid renames
				    (make-definition-context-resolved-table))))

(define (seal-definition-context! dctx)
  ;; #### optimization: could turn RENAMES into an immutable hash
  ;;      table here as well
  (set-definition-context-resolved-table! dctx #f))

(define (syntax-local-make-definition-context)
  (make-definition-context '()))

(define (syntax-local-bind-syntaxes ids expr dctx)
  (define (slbs-error-message error-reason)
    (case error-reason
      ((resolved)
       "cannot define identifier whose denotation was used to expand a previous internal definition in the same body")
      ((defined)
       "cannot define identifier multiple times in the same body")))
  (let ((resolved-table (definition-context-resolved-table dctx)))
    (if (not resolved-table)
	(assertion-violation 'syntax-local-bind-syntaxes
			     "cannot bind identifiers in sealed dctx"
			     dctx))
    (for-each (lambda (id)
		(let* ((name (syntax-object-expr id))
		       (marks (marks-of (syntax-object-context id)))
		       (p (cons name marks)))
		  (cond
		   ((table-ref resolved-table p)
		    =>
		    (lambda (error-reason)
		      (assertion-violation 'syntax-local-bind-syntaxes
					   (slbs-error-message error-reason)
					   id dctx)))
		   (else
		    (table-set! resolved-table p 'defined)))))
	      ids))
  (let* ((mrk (current-mark))
	 (phase (current-phase))
	 (ids-marked (map (lambda (id)
			    (add-mark id mrk))
			  ids))
	 (vars-new (map (lambda (id)
			  (make-sym (syntax-object-expr id)))
			ids)))
    (definition-context-add-bindings! dctx ids-marked vars-new phase)
    (if (not expr)
	(let ((ids-new (map (lambda (id var-new)
			      (add-rename id id var-new phase))
			    ids vars-new)))
	  (transform-current-expand-time-environment! (lambda (env)
							(bind vars-new (map (lambda (id-new)
									      (make-node operator/name id-new))
									    ids-new)
							      env))))
	(let ((newexpr (add-mark expr mrk))
	      (env (current-expand-time-environment)))
	  (receive (_ thunk)
	      (compile-time-eval newexpr #f env)
	    (call-with-values thunk
	      (lambda vals
		(if (not (= (length vals) (length ids)))
		    (assertion-violation 'syntax-local-bind-syntaxes
					 "identifier count does not match binding count" 
					 ids vals))
		(transform-current-expand-time-environment! (lambda (env)
							      (bind vars-new 
								    (map (lambda (val)
									   (make-binding syntax-type
											 (list 'syntax-local-bind-syntaxes)
											 val))
									 vals)
								    env))))))))))

(define (definition-context-add-bindings! dctx ids vals phase)
  (set-definition-context-renames!
   dctx
   (let loop ((ids ids)
	      (vals vals))
     (cond
      ((null? ids)
       (definition-context-renames dctx))
      (else
       (cons (make-rename (car ids) (car vals) phase dctx)
	     (loop (cdr ids) (cdr vals))))))))

(define (syntax-local-value id)
  ;; #### (assert (identifier? id))
  (receive (lbl val)
      (resolve+lookup (add-mark id (current-mark))
		      (current-expand-time-environment))
    (and (binding? val)
	 (eq? (binding-static val) 'syntax)
	 (macro-transform-procedure (contents (binding-place val)))))) ; #### kludge

(define (local-expand stx dctx stop-ids)
  (let ((mrk (current-mark))
	(phase (current-phase)))
    (let ((env-stops (bind-stops (nostops (current-expand-time-environment))
				 (map (lambda (id)
					(resolve+label id phase))
				      stop-ids)))
	  (stx-new (add-definition-context (add-mark stx mrk) dctx)))
      (add-definition-context (add-mark (expand stx-new env-stops)
					mrk)
			      dctx))))

(define (nostops env)
  (comp-env-filter (lambda (name val)
		     (not (eq? 'stop val)))
		   env))

(define (bind-stops env syms)
  (bind syms (map (lambda (_) 'stop) syms) env))

(define $mark (make-fluid #f))

(define (current-mark)
  (fluid $mark))

; --------------------
; Utilities

(define (this-long? l n)
  (cond ((null? l)
	 (= n 0))
	((pair? l)
	 (this-long? (cdr l) (- n 1)))
	(else
	 #f)))

(define (at-least-this-long? l n)
  (cond ((null? l)
	 (<= n 0))
	((pair? l)
	 (at-least-this-long? (cdr l) (- n 1)))
	(else
	 #f)))

; from R6RS, without error checking
(define (fold-left combine nil the-list . the-lists)
  (if (null? the-lists)
      (fold-left1 combine nil the-list)
      (let loop ((accum nil) (list the-list) (lists the-lists))
	(if (null? list)
	    accum 
	    (loop (apply combine accum (car list) (map car lists))
		  (cdr list)
		  (map cdr lists))))))

(define (fold-left1 combine nil list)
  (let loop ((accum nil) (list list))
    (if (null? list)
	accum
	(loop (combine accum (car list))
	      (cdr list)))))
