(* Filed on: {phylum}<desrivieres>nlisp>compile3.2lisp   *)

(* Mode: N-lisp *)

(* A simple compiler for 1.9-lisp.  


(define compile
  (lambda (& exp env code)
     (if (or (numeral? exp) (boolean? exp))
         (compile-constant exp env code)
         (if (atom? exp) 
             (compile-variable exp env code)
             (if (pair? exp)
                 (compile-pair exp env code)
                 (if (rail? exp)
                     (compile-rail exp env code)
                     (error-in-compile-bad-expression)))))))

(define numeral? number?)
(define boolean? truth-value?)
(define atom? named-object?)

(define rail?
  (lambda (& x)
     (if (sequence? x)
         (= (first x) @@scons)
         $f)))

(define pair?
  (lambda (& x)
     (if (sequence? x)
         (not (= (first x) @@scons))
         $f)))

(define terminate
  (lambda (& code)
     (if (empty? code) 
         (& (& @return)) 
         code)))

(define compile-constant
  (lambda (& exp env code)
     (append
        (& (& @const exp)) (terminate code))))

(define compile-variable
  (lambda (& exp env code)
     (append 
        (& (& @var exp)) (terminate code))))


(set global-contour (&))


(define compile-pair
  (lambda (& exp env code)
      (if (lambda-expr? exp env)
          (compile-lambda exp env code)
          (if (if-expr? exp env)
              (compile-if exp env code)
              (compile-application exp env code) ))))

(define lambda-expr?
  (lambda (& exp env)
     (let (& (& x (first exp)))
        (if (named-object? x)
            (let (& (& y (expected-binding x env)))
               (= y @the-lambda-closure))
            $f))))

(define if-expr?
  (lambda (& exp env)
     (let (& (& x (first exp)))
        (if (named-object? x)
            (let (& (& y (expected-binding x env)))
               (= y @the-if-closure))
            $f))))

(define expected-binding 
  (lambda (& var env)
     (if (empty? env)
         (if (= var @lambda)
             @the-lambda-closure
             (if (= var @if)
                 @the-if-closure
                 @some-global-variable))
         (if (member var (first env))
             @some-local-variable
             (expected-binding var (rest env))))))

(define compile-lambda
  (lambda (& exp env code)
    (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 
                      (prep variable-list env) 
                      (&) )))  
            (append (& (& @lambda
                          (& pattern-type pattern)
                          compiled-body))
                    (terminate code)))))))

(define compile-if
  (lambda (& exp env code)
    (let (& (& premise (second exp))
            (& consequent (third exp))
            (& alternate (fourth exp)))
       (compile premise env  
          (& (& @if
                (compile consequent env code)
                (compile alternate env code)))))))

(define compile-application
  (lambda (& exp env code)
    (let (& (& proc (first exp))
            (& mark (second exp))
            (& args (rest exp)))
       (compile proc env
          (append  
               (& (& @pcheck))
               (if (= mark @.)
                   (compile (second args) env
                      (if (not (empty? code)) 
                          (append 
                             (& (& @call-objectified)) 
                             code) 
                          (& (& @tail-call-objectified))))
                   (compile-tail args env
                      (if (not (empty? code)) 
                          (append 
                              (& (& @call (length args))) 
                              code) 
                          (& (& @tail-call (length args)))))
               ))))))

(define compile-tail
  (lambda (& exp env code)
     (if (empty? exp)
         code
         (compile (first exp) env
            (compile-tail (rest exp) env code)))))

(define compile-rail
  (lambda (& exp env code)
     (compile-tail (rest exp) env 
         (append
            (& (& @rcons (length (rest exp))))   
            (terminate code)))))


@eof