(* A very simple 1.9-lisp compiler. *)

(define compile
  (lambda (& exp env embedded)
     (if (number? exp)
         (compile-constant exp env embedded)
         (if (named-object? exp) 
             (compile-variable exp env embedded)
             (if (sequence? exp)
                 (compile-form exp env embedded)
                 (error-in-compile-bad-expression))))))

(define compile-constant
  (lambda (& exp env embedded)
     (append (& (& @const exp))
        (if (not embedded) (& (& @return)) (&)))))

(define compile-variable
  (lambda (& exp env embedded)
     (append (& (& @var exp))
        (if (not embedded) (& (& @return)) (&)))))


(define smart-compile-variable
  (lambda (& exp env embedded)
     (let (& (& pos (lookup exp env 0)))
        (if (= pos @not-found)
            (& @global exp @return)
            (& @var pos exp)))))

(define lookup
   (lambda (& var env cn)
      (if (global-contour? env)
          @not-found
          (let (& (& pos (search-coutour 
                        var
                        (variable-list env) 
                        0) ))
             (if (= pos @not-found)
                 (lookup var (next-contour env) (1+ cn))
                 (& cn pos))))))

(define search-coutour
  (lambda (& var variable-list p)
    (if (empty? variable-list)
      @not-found
      (if (= var (first variable-list))
        p
        (search-coutour
            var
            (rest variable-list) 
            (1+ p))))))


               

(define add-contour 
   (lambda (& variable-list old-contour)
      (prep variable-list old-contour)))

(define next-contour
   (lambda (& contour) (rest contour)))

(define variable-list 
   (lambda (& contour) (first contour)))

(set global-contour (&))

(define global-contour?
   (lambda (& contour) (empty? contour)))



(define compile-form
  (lambda (& exp env embedded)
    (let (& (& s (first exp)))
      (if (= s @lambda)
          (compile-lambda exp env embedded)
          (if (= s @if)
              (compile-if exp env embedded)
              (if (= s @apply)
                  (compile-application exp env embedded)
                  (if (= s @scons)
                      (compile-rail (rest exp) env embedded)
                      (error-unrecognized-form))))))))

(define compile-lambda
  (lambda (& exp env embedded)
    (let (& (& pattern (second exp))
            (& body (third exp)))
      (let (& (& pattern-type
                 (if (named-object? pattern)
                     @no-spread
                     (length pattern)))
              (& variable-list
                 (if (named-object? pattern)
                     (& pattern)
                     pattern)))
         (let (& (& compiled-body 
                  (compile body 
                     (add-contour variable-list env)
                     $f)))  
            (& (& @lambda
                  (& pattern-type pattern)
                  (append compiled-body
                      (& (& @return))) ) ))))))

(define compile-if
  (lambda (& exp env embedded)
    (let (& (& premise (second exp))
            (& consequent (third exp))
            (& alternate (fourth exp)))
       (append
          (compile premise env $t) 
          (& (& @if
                (compile consequent env embedded)
                (compile alternate env embedded)))))))

(define compile-application
  (lambda (& exp env embedded)
    (let (& (& proc (second exp))
            (& mark (third exp))
            (& args (rest (rest exp))))
       (append (compile proc env $t) 
               (& (& @pcheck))
               (if (= mark @.)
                   (append
                       (compile 
                         (second args) env $t)
                       (& (& (if embedded 
                                 @tail-ocall 
                                 @ocall))))
                   (append  
                       (compile-tail args env $t)
                       (& (& (if embedded 
                                 @call  
                                 @tail-call)  
                             (length args)))))))))

(define compile-tail
  (lambda (& exp env embedded)
    (append &. 
       (map (lambda (& x)
               (compile x env $t))
            exp))))


(define compile-rail
  (lambda (& exp env embedded)
    (append
      (append &. 
        (map (lambda (& x)
                (compile x env $t))
             exp))
      (& (& @rcons (length exp)))   
      (if (not embedded) (& (& @return)) (&)) )))




(compile-lambda (& @lambda @x @x) global-contour $t)
(compile (& @lambda @x @x) global-contour $t)
(compile (& @lambda (& @x) @x) global-contour $t)
(compile (& @if 1 1 2) global-contour $t)
(compile (& @if (& @if 1 2 3) 4 5) global-contour $t)
(compile (& @apply @f @g) global-contour $t)
(compile (& @apply @f @g) global-contour $f)
(compile (& @apply @f 1 2) global-contour $t)
(compile (& @apply @f (& @apply @bar 4)) global-contour $f)
(compile (& @apply @f @. @g) global-contour $t)
(compile (& @apply (& @apply @bar 4) 1000) global-contour $t)
(compile (& @scons 1 2 3) global-contour $f)
(compile (& @scons 1 2 3) global-contour $t)
(compile (& @scons 1 (& @apply @f @g) 3) global-contour $f)
(compile (& @scons 1 (& @apply @f @g) 3) global-contour $t)


(set program-1
  (& @lambda (& @n)
    (& @if
       (& @apply @= @n 0)
       1
       (& @apply @* @n
          (& @apply @fact
             (& @apply @- @n 1))))))

(compile program-1 global-contour $t)

@eof