; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.

; Once we know that we want something to be inlined, the following things
; actually make use of the fact.  For procedures for which all
; arguments can be substituted unconditionally, we make a transform
; (a macro, really) that performs the substitution.

(define (make-inline-transform node type package name)
  (let* ((free (find-node-usages node))
	 (env (package->environment package))
	 (qualified-free (map (lambda (name)
				(cons name
				      (name->qualified name)))
			      free)))
    (let ((form (clean-node node '())))
      (make-transform/inline (inline-transform form)
			     package
			     type
			     (remove-bindings form qualified-free)
			     name))))

; This routine is obligated to return an S-expression.
; It's better not to rely on the constancy of node id's, so 
; the output language is a sort of quasi-Scheme.  Any form that's a list
; has an operator name in its car.
;
; ENV is an a-list mapping names to qualified (for package variables) or
; non-clashing (for lexical variables) new names.
;
; What about SET! ?

(define (clean-node node env)
  (cond ((name-node? node)
	 (clean-lookup env node))
	((quote-node? node)
	 `(quote ,(cadr (node-form node))))
	((lambda-node? node)
	 (clean-lambda node env))
	((call-node? node)
	 (cons 'call
	       (map (lambda (node) (clean-node node env))
		    (node-form node))))
	((loophole-node? node)
	 (let ((args (cdr (node-form node))))
	   `(loophole ,(type->sexp (car args) #t)
		      ,(clean-node (cadr args) env))))
	;; LETREC had better not occur, since we are not prepared for it
	((pair? (node-form node))
	 (cons (operator-name (node-operator node))
	       (map (lambda (subnode)
		      (clean-node subnode env))
		    (cdr (node-form node)))))
	(else (node-form node))))	;literal

(define (clean-lambda node env)
  (let* ((exp (node-form node))
	 (formals (cadr exp))
	 (env (fold (lambda (name-node env)
		      `((,name-node . , (make-sym (node-form name-node)))
			. ,env))
		    (normalize-formals formals)
		    env)))
    `(lambda ,(let recur ((foo formals))
		(cond ((node? foo) (clean-lookup env foo))
		      ((pair? foo)
		       (cons (recur (car foo))
			     (recur (cdr foo))))
		      (else foo)))	; when does this happen?
       ,(clean-node (caddr exp) env))))

; Package names get looked up by name, lexical names get looked up by the
; node itself.

(define (clean-lookup env node)
  (let ((binding (node-ref node 'binding))) 
    (if (binding? binding)
	`(package-name ,(node-form node) ,binding)
	(cdr (assq node env)))))
  
; We need to remove the binding records from the form that will be used for
; reification.  A better alternative might be for packages to provide dumpable
; names as stand-ins for bound generated names.  The problem is that packages
; use EQ? tables for names and the linker does not preserve EQ-ness for
; generated names.  Instead, we remember the path and do the lookup that way.
; This doesn't work if the generated name is itself bound.
;  If the environment in the generated name were the package itself, instead
; of its environment wrapper, the linker could probably do the right thing
; with all package-level generated names.

(define (remove-bindings form free)
  (let label ((form form))
    (if (pair? form)
	(case (car form)
	  ((package-name)
	   (cdr (assq (cadr form) free))) ; just the name
	  ((quote) form)
	  ((lambda)
	   `(lambda ,(cadr form)
	      ,(label (caddr form))))
	  (else
	   (map label form)))
	form)))

;----------------
; ST stands for substitution template (cf. MAKE-SUBSTITUTION-TEMPLATE)

(define (inline-transform st)
  (if (and (pair? st)
	   (eq? (car st) 'lambda))
      (let ((formals (cadr st))
	    (body (caddr st)))
	(lambda (exp package rename)
	  (let ((args (cdr exp)))
	    (if (= (length formals) (length args))
		(reconstitute body
			      package
			      (make-substitution rename formals args))
		;; No need to generate warning since the type checker will
		;; produce one.  Besides, we don't want to produce a warning
		;; for things like (> x y z).
		exp))))
      (lambda (exp package rename)
	(cons (reconstitute st package rename)
	      (cdr exp)))))

(define (make-substitution rename formals args)
  (let ((subs (map cons formals args)))
    (lambda (name)
      (cond ((assq name subs) => cdr)
	    (else (rename name))))))

; undo reification
(define (reflect-inline-transform st env type-sexp name)
  (make-transform/inline (inline-transform (restore-bindings st env))
			 env
			 (sexp->type type-sexp #t)
			 st
			 name))

(define (copy-inline-transform tr env)
  (let ((src (inline-transform-source tr)))
    (make-transform/inline (inline-transform (restore-bindings src env))
			   (inline-transform-env tr)
			   (inline-transform-type tr)
			   src
			   (inline-transform-id tr))))

(define (restore-bindings st env)
  (let label ((st st))
    (cond ((symbol? st) st)
	  ((qualified? st)
	   (let ((name (qualified->name st env)))
	     (cond
	      ((generic-lookup env name)
	       => (lambda (binding)
		    `(package-name ,name ,binding)))
	      (else
	       (assertion-violation 'restore-bindings "couldn't compute binding" st name env)))))
	  ((pair? st)
	   (case (car st)
	     ((quote) st)
	     ((package-name) st)
	     ((call)
	      (cons 'call (map label (cdr st))))
	     ((loophole)
	      (list 'loophole
		    (cadr st)
		    (label (caddr st))))
	     ((lambda)
	      (list 'lambda
		    (cadr st)
		    (label (caddr st))))
	     (else
	      (cons (car st) (map label (cdr st))))))
	  (else st))))

; Turn an s-expression back into a node.
; ST is an S-expression as returned by MAKE-SUBSTITUTION-TEMPLATE.

(define (reconstitute st package rename)
  (let label ((st st))
    (cond ((symbol? st)
	   (let ((foo (rename st)))
	     (if (name? foo)
		 (reconstitute-name foo package)
		 foo)))
	  ((pair? st)
	   (case (car st)
	     ((quote)
	      (make-node (get-operator 'quote) st))
	     ((package-name)
	      (let ((node (make-node operator/name (rename (cadr st)))))
		(node-set! node 'binding (caddr st))
		node))
	     ((call)
	      (make-node (get-operator 'call)
			 (map label (cdr st))))
	     ((loophole)
	      (make-node (get-operator 'loophole)
			 (list 'loophole
			       (sexp->type (cadr st) #t)
			       (label (caddr st)))))
	     ((lambda)
	      (assertion-violation 'reconstitute-name "lambda substitution NYI" st))
	     (else
	      (let ((keyword (car st)))
		(make-node (get-operator keyword)
			   (cons keyword
				 (map label (cdr st))))))))
	  (else
	   (make-node operator/literal st)))))

(define (reconstitute-name name package)
  (let ((binding (package-lookup package name))
	(node (make-node operator/name name)))
    (if (binding? binding)
	(node-set! node 'binding binding))
    node))


