; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-

;;;; Alpha-conversion

; Front and back ends for block compiler.
; Can be used distinct from it.

; Requires the DERIVE module, for expanding macros.
; Someday merge these two.

; ALPHA-FILE returns a list of macroexpanded top-level forms
; (intermixed definitions and mungibles).

(define (alpha-file i-name)
  (let ((forms '()))
    (for-each (lambda (form)
		(parse-top-level-form form
		  (lambda (exp)
		    (set! forms (cons (alpha-top exp "top level")
				      forms)))
		  (lambda (var exp)
		    (set! forms (cons `(define ,var ,(alpha-top exp var))
				      forms)))))
	      (read-file i-name))
    (reverse forms)))

(define @where (make-fluid '<top>))

(define (alpha-top form where)
  (let-fluid @where where
    (lambda () (alpha form '()))))

(define alphatizers (make-table))

; In the output expression, all variable names are distinct.

(define (alpha form env)
  (cond ((symbol? form)
	 (let ((probe (binding form env)))
	   (if probe probe form)))
	((constant? form)
	 form)
	((not (pair? form)) (note "Strange expression" form) 'unspecified)
	((eq? (car form) system-ref-marker)
	 `(system-ref ,(cadr form)))
	((symbol? (car form))
	 (let ((probe (table-ref alphatizers (car form))))
	   (if probe
	       (probe form env)
	       (let ((probe (get-macro-expander (car form))))
		 (if probe
		     (alpha (probe form) env)
		     (alpha-combination form env))))))
	(else
	 (alpha-combination form env))))

(define (alpha-combination form env)
  (map (lambda (subform) (alpha subform env)) form))

(define (define-alpha name proc)
  (table-set! alphatizers name proc))

; The primitive special forms.

(define-alpha '@
  (lambda (form env)
    (if (variable-substitution form)
	(note "this shouldn't happen" form))
    (or (binding form env)
	form)))

(define-alpha 'lambda
  (lambda (form env)
    (let ((env (bind (cadr form) env)))
      `(lambda ,(new-names (cadr form) env)
	 ,(alpha (beginify (cddr form)) env)))))

(define-alpha 'letrec
  (lambda (form env)
    (let* ((specs (cadr form))
	   (vars (map car specs))
	   (env (bind vars env))
	   (new-vars (new-names vars env)))
      `(letrec ,(map (lambda (var spec)
		       `(,var ,(alpha (cadr spec) env)))
		     new-vars 
		     specs)
	       ,(alpha (beginify (cddr form)) env)))))

(define-alpha 'if
  (lambda (form env)
    (let ((test (alpha (cadr form) env))
	  (con  (alpha (caddr form) env))
	  (alt  (alpha (cadddr form) env)))
      `(if ,test ,con ,alt))))

(define-alpha 'set!
  (lambda (form env)
    `(set! ,(alpha (cadr form) env)
	   ,(alpha (caddr form) env))))

(define-alpha 'begin
  (lambda (form env)
    `(begin ,@(map (lambda (subform) (alpha subform env))
		   (cdr form)))))

; Simplified depilatory macros for AND and OR.

(define-alpha 'and
  (lambda (form env)
    (alpha (cond ((null? (cdr form)) `#t)
		 ((null? (cddr form)) (cadr form))
		 (else `(if ,(cadr form)
			    (and ,@(cddr form))
			    #f)))
	   env)))

(define-alpha 'or
  (lambda (form env)
    (alpha (cond ((null? (cdr form)) `#f)
		 ((null? (cddr form)) (cadr form))
		 (else `(if ,(cadr form)
			    #t
			    (or ,@(cddr form)))))
	   env)))

; SCHEMIFY is an inverse to alpha-conversion.
;  This generally keeps the user's original variable names whenever
;  there is no conflict.  That's the only thing the env argument is
;  used for.

(define (schemify-top form)
  (schemify form '()))

(define schemifiers (make-table))

(define (schemify form env)
  (cond ((not (pair? form)) form)  ;be forgiving
	((symbol? (car form))
	 (let ((probe (table-ref schemifiers (car form))))
	   (if probe
	       (probe form env)
	       (schemify-combination form env))))
	((lambda-form? (car form))
	 (let ((proc (schemify (car form) env)))
	   `(let ,(map (lambda (var arg) `(,var ,(schemify arg env)))
		       (cadr proc)
		       (cdr form))
	      ,@(cddr proc))))
	(else (schemify-combination form env))))

(define (schemify-combination form env)
  (map (lambda (subform) (schemify subform env))
       form))

(define (define-schemifier sym proc)
  (table-set! schemifiers sym proc))

(define (externalize-variable var env)
  (let ((uname (variable-user-name var)))
    (if (rassq uname env)
	(string->symbol
	 (string-append (symbol->string uname)
			"~"
			(number->string (variable-unique-id var)
					'(heur))))
	uname)))

(define (rassq obj lst)
  (cond ((null? lst) #f)
	((eq? obj (cdar lst)) (car lst))
	(else (rassq obj (cdr lst)))))

(define-schemifier 'quote
  (lambda (form env) env form))

(define-schemifier '@
  (lambda (var env)
    (let ((probe (assq var env)))
      (if probe
	  (cdr probe)
	  (begin (if (not (eq? (fluid @where) '<note>))
		     (note "Unbound variable in object code" var))
		 (externalize-variable var env))))))

(define-schemifier 'system-ref
  (lambda (form env)
    env
    ;; ??!!??
    (cadr form)))

(define-schemifier 'lambda
  (lambda (form env)
    (let* ((vars (cadr form))
	   (new-vars (map (lambda (var) (externalize-variable var env))
			  vars)))
      `(lambda ,new-vars
	 ,@(schemify-body (caddr form)
			  (append (map cons vars new-vars) env))))))

(define-schemifier 'letrec
  (lambda (form env)
    (let* ((vars (map car (cadr form)))
	   (new-vars (map (lambda (var) (externalize-variable var env))
			  vars))
	   (env (append (map cons vars new-vars) env)))
      `(letrec ,(map (lambda (var spec)
		       `(,var ,(schemify (cadr spec) env)))
		     new-vars
		     (cadr form))
	 ,@(schemify-body (caddr form) env)))))

(define (schemify-body form env)
  (unbeginify (schemify form env)))

(define-schemifier 'if
  (lambda (form env)
    (let ((test (schemify (cadr form) env))
	  (con  (schemify (caddr form) env))
	  (alt  (schemify (cadddr form) env))
	  (flatten (lambda (form kw)
		     (if (car-is? form kw) (cdr form) (list form)))))
      ;; Reconstruct AND's and OR's.
      (cond ((eq? con `#t)
	     `(or ,@(flatten test 'or)
		  ,@(flatten alt 'or)))
	    ((eq? alt `#f)
	     `(and ,@(flatten test 'and)
		   ,@(flatten con 'and)))
	    (else `(if ,test ,con ,alt))))))

; Expression utilities

(define (beginify forms)
  (if (null? (cdr forms)) (car forms) `(begin ,@forms)))

(define (unbeginify form)
  (if (car-is? form 'begin) (cdr form) (list form)))

(define global-variable? symbol?)

(define (local-variable? form) (car-is? form '@))

(define (variable? form)
  (or (global-variable? form) (local-variable? form)))

(define (variable-user-name var)
  (if (global-variable? var) var (cadr var)))

(define variable-unique-id caddr)

(define (variable-substitution var)
  (if (null? (cdddr var))  ;For readability, avoid extra field.
      #f
      (cadddr var)))

(define (set-variable-substitution! var sub)
  (set-cdr! (cddr var) (list sub)))

(define *counter* 0)

(define (make-new-variable var)
  (set! *counter* (+ *counter* 1))
  `(@ ,(variable-user-name var) ,*counter*))

(define (reset-new-variable-counter)
  (set! *counter* 0))

; Environments

(define (bind vars env)
  (append (map (lambda (var)
		 (cons var (make-new-variable var)))
	       vars)
	  env))

(define (binding var env)
  (let ((probe (assq var env)))
    (if probe (cdr probe) #f)))

(define (new-names vars env)
  (map (lambda (var)
	 (let ((probe (binding var env)))
	   (if probe probe (error "losing"))))
       vars))

(define (car-is? form x)
  (and (pair? form)
       (eq? (car form) x)))

(define (constant? form)
  (or (car-is? form 'quote)
      (number? form)
      (boolean? form)
      (char? form)
      (string? form)))

(define (lambda-form? form) (car-is? form 'lambda))

(define (definition? form)
  (or (car-is? form 'define)
      (car-is? form 'define[subst])))

(define (definition-lhs form)
  (let ((pat (cadr form)))
    (if (pair? pat) (car pat) pat)))

(define (definition-rhs form)
  (let ((pat (cadr form)))
    (if (pair? pat)
	`(lambda ,(cdr pat) ,@(cddr form))
	(caddr form))))

; Utilities

(define (read-file filename)
  (call-with-input-file filename
    (lambda (i-port)
      (let loop ((l '()))
	(let ((form (read i-port)))
	  (cond ((eof-object? form) (reverse l))
		(else
		 (loop (cons form l)))))))))

(define (note msg form)
  (newline)
  (display "** ")
  (display msg)
  (display ": ")
  (write (let-fluid @where '<note>
	   (lambda ()
	     (schemify-top form))))
  (newline)
  (display "   Location: ")
  (write (fluid @where))
  (newline))

; Set utilities

(define (right-reduce proc lst identity)
  (cond ((null? lst) identity)
	(else (right-reduce proc (cdr lst) (proc (car lst) identity)))))

(define reduce right-reduce)

(define (setdiffq l1 l2)
  (cond ((null? l2) l1)
	((null? l1) l1)
	((memq (car l1) l2)
	 (setdiffq (cdr l1) l2))
	(else (cons (car l1)
		    (setdiffq (cdr l1) l2)))))

(define (unionq l1 l2)
  (cond ((null? l1) l2)
	((null? l2) l1)
	((memq (car l1) l2) (unionq (cdr l1) l2))
	(else (cons (car l1) (unionq (cdr l1) l2)))))

(define (intersectq l1 l2)
  (cond ((null? l1) l1)
	((null? l2) l2)
	((memq (car l1) l2)
	 (cons (car l1) (intersectq (cdr l1) l2)))
	(else (intersectq (cdr l1) l2))))

(define (intersectq? l1 l2)
  (and (not (null? l1))
       (not (null? l2))
       (or (memq (car l1) l2)
	   (intersectq? (cdr l1) l2))))