(declare (usual-integrations))

(define (compile exp)
  (compile-expr exp #F))

(define (compile-expr exp s-env)
  (let ((exp (macro-expand exp)))
    (cond ((symbol? exp)
	   (compile-lookup exp s-env))
	  ((not (pair? exp))
	   (compile-constant exp s-env))
	  ((eq? (car exp) 'QUOTE)
	   (compile-constant (second exp) s-env))
	  ((eq? (car exp) 'SET!)
	   (compile-set! (second exp) (third exp) s-env))
	  ((eq? (car exp) 'BEGIN)
	   (compile-sequence (cdr exp) s-env))
	  ((eq? (car exp) 'LAMBDA)
	   (compile-lambda (second exp) (cddr exp) s-env))
	  ((eq? (car exp) 'IF)
	   (compile-if exp s-env))
	  (else
	   (compile-combination exp s-env)))))

(define (macro-expand exp)
  (cond ((not (pair? exp))
	 exp)
	((eq? (car exp) 'LET)
	 `((LAMBDA ,(map first (second exp)) ,@(cddr exp))
	   ,@(map second (second exp))))
	((eq? (car exp) 'LETREC)
	 (let ((names  (map car (second exp)))
	       (values (map cadr (second exp)))
	       (body   (cddr exp)))
	   `((LAMBDA ,names
	       ,@(map (lambda (n v) `(SET! ,n ,v)) names values)
	       ,@body)
	     ,@(make-list (length names) '(quote undefined)))))
	(else exp)))

(define (compile-constant cst s-env)
  s-env
  (let ((place? (assoc cst *common-constants*)))
    (if place?
	(cdr place?)
	(lambda (d-env) cst))))

(define *common-constants*
  (list (cons '0  (lambda (d) 0))
	(cons '1  (lambda (d) 1))
	(cons '2  (lambda (d) 2))
	(cons '() (lambda (d) '()))
	(cons #T  (lambda (d) #T))
	(cons #F  (lambda (d) #F))))
	
(define *global-env*
  (list 'global-environment
	(cons '+ +)
	(cons '- -)
	(cons '* *)
	(cons '< <)
	(cons 'list list)
	(cons 'cons  (lambda (u v) (cons u v)))
	(cons 'car   (lambda (p) (car p)))
	(cons 'cdr   (lambda (p) (cdr p)))
	(cons 'null? (lambda (x) (null? x)))
	(cons 'display display)))

(define (var->path var s-env)
  ;; returns an access path, either pair from the global env or a
  ;; (spine-index.frame-index) pair
  (let frame-loop ((frame s-env) (spine-index 0))
    (cond ((not frame)
	   (or (assq var (cdr *global-env*))
	       (let ((pair (cons var 'uninitialized)))
		 (set-cdr! *global-env* (cons pair (cdr *global-env*)))
		 pair)))
	  ((let loop ((bindings  (cdr frame)) (index 1))
	     (cond ((pair? bindings)
		    (if (eq? (car bindings) var)
			(cons spine-index index)
			(loop (cdr bindings) (+ index 1))))
		   ((null? bindings)
		    #F)
		   (else ;; rest arg
		    (if (eq? bindings var)
			(cons spine-index index)
			#F)))))
	  (else
	   (frame-loop (car frame) (+ spine-index 1))))))

(define (compile-lookup var s-env)
  (let ((path  (var->path var s-env)))
    (if (symbol? (car path))
	(lambda (d-env) d-env (cdr path))
	(let loop ((ups  (car path)))
	  (if (zero? ups)
	      (compile-frame-ref (cdr path))
	      (let ((ups*  (loop (- ups 1))))
		(lambda (d-env) (ups* (vector-ref d-env 0)))))))))

(define (compile-set! var exp s-env)
  (let* ((path (var->path var s-env))
	 (frame (car path))
	 (index (cdr path)))
    (let ((exp* (compile-expr exp s-env)))
      (if (symbol? frame)
	  (lambda (d-env) (set-cdr! path (exp* d-env)) unspecific)
	  (let loop ((ups  frame))
	    (if (zero? ups)
		(lambda (d-env) (vector-set! d-env index (exp* d-env)))
		(let ((ups*  (loop (- ups 1))))
		  (lambda (d-env) (ups* (vector-ref d-env 0))))))))))

(define (compile-global-access place)
  (lambda (d-env) d-env (cdr place)))
	
(define (compile-frame-ref index)
  (case index
    ((0)  (lambda (d-env) (vector-ref d-env 0)))
    ((1)  (lambda (d-env) (vector-ref d-env 1)))
    ((2)  (lambda (d-env) (vector-ref d-env 2)))
    ((3)  (lambda (d-env) (vector-ref d-env 3)))
    ((4)  (lambda (d-env) (vector-ref d-env 4)))
    (else (lambda (d-env) (vector-red d-env index)))))

(define (compile-lambda args sequence s-env)
  (let ((body (compile-sequence sequence (cons s-env args))))
    (cond ((null? args)
	   (lambda (d-env)
	     (lambda () (body (vector d-env)))))
	  ((symbol? args)
	   (lambda (d-env)
	     (lambda args (body (vector d-env args)))))
	  ((null? (cdr args))
	   (lambda (d-env)
	     (lambda (arg1) (body (vector d-env arg1)))))
	  ((symbol? (cdr args))
	   (lambda (d-env)
	     (lambda (arg1 . rest) (body (vector d-env arg1 rest)))))
	  ((null? (cddr args))
	   (lambda (d-env)
	     (lambda (arg1 arg2) (body (vector d-env arg1 arg2)))))
	  ((symbol? (cddr args))
	   (lambda (d-env)
	     (lambda (arg1 arg2 . rest) (body (vector d-env arg1 arg2 rest)))))
	  ((null? (cdr (last-pair args)))
	   (lambda (d-env)
	     (lambda args (body (list->vector (cons d-env args))))))
	  (else (error "Illegal or unimplemented lambda list" args)))))

(define (compile-sequence seq s-env)
  (cond ((null? seq) (error "Null sequence"))
	((null? (cdr seq))
	 (compile-expr (car seq) s-env))
	(else
	 (let ((this  (compile-expr (car seq) s-env))
	       (rest  (compile-sequence (cdr seq) s-env)))
	   (lambda (d-env)
	     (this d-env)
	     (rest d-env))))))

(define (compile-if exp s-env)
  (let ((pred (compile-expr (second exp) s-env))
	(conseq (compile-expr (third exp) s-env)))
    (if (null? (cdddr exp))
	(lambda (d-env)
	  (if (pred d-env) (conseq d-env) unspecific))
	(let ((alt  (compile-expr (fourth exp) s-env)))
	  (lambda (d-env)
	    (if (pred d-env) (conseq d-env) (alt d-env)))))))

(define (compile-combination exps s-env)
  (let ((rator  (compile-expr (car exps) s-env))
	(rands  (map (lambda (e) (compile-expr e s-env)) (cdr exps))))
    (case (length rands)
      ((0)  (lambda (d-env) ((rator d-env))))
      ((1)  (let ((rand1 (first rands)))
	      (lambda (d-env) ((rator d-env) (rand1 d-env)))))
      ((2)  (let ((rand1 (first rands))
		  (rand2 (second rands)))
	      (lambda (d-env) ((rator d-env) (rand1 d-env) (rand2 d-env)))))
      ((3)  (let ((rand1 (first rands))
		  (rand2 (second rands))
		  (rand3 (third rands)))
	      (lambda (d-env)
		((rator d-env) (rand1 d-env) (rand2 d-env)  (rand3 d-env)))))
      ((4)  (let ((rand1 (first rands))
		  (rand2 (second rands))
		  (rand3 (third rands))
		  (rand4 (fourth rands)))
	      (lambda (d-env)
		((rator d-env)
		 (rand1 d-env) (rand2 d-env) (rand3 d-env) (rand4 d-env)))))
      (else
       (lambda (d-env)
	 (apply (rator d-env) (map (lambda (f) (f d-env)) rands)))))))

(define bench1
  `(begin
     (set! fib
	   (lambda (n)
	     (if (< n 2)
		 n
		 (+ (fib (- n 1)) (fib (- n 2))))))
     (fib 20)))

(define (go)
  ((compile bench1) #F)
  ((compile bench1) #F)
  ((compile bench1) #F)
  ((compile bench1) #F)
  ((compile bench1) #F))


(lambda () (go))

