;;;;
;;;; c o m p i l e r . s t k                    -- STklos Compiler
;;;;
;;;; Copyright © 2000-2024 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 26-Feb-2000 10:47 (eg)
;;;;

(define-module STKLOS-COMPILER
  (import SCHEME)
  (export eval
          disassemble disassemble-expr

          %compiler-set-flags
          %grab-file-information
          %compiler-new-label
          %macro-expand

          ;; FIXME
          compiler-current-module
          when-compile
          when-load-and-compile
          %syntax-error
          %compile-time-define)


(define *compiler-port* #f)

;; ----------------------------------------------------------------------
;;  Define the inlining tables
;; ----------------------------------------------------------------------
(define *inline-math-commutative* '(+ * gcd lcm))
(define *inline-math-general*     '(- /
                                    fx+ fx- fx* fxquotient
                                    sin   cos   tan
                                    asin  acos  atan
                                    sinh  cosh  tanh
                                    asinh acosh atanh
                                    exp log expt
                                    sqrt square))
(define *inline-math*              (append *inline-math-commutative*
                                           *inline-math-general*))

(define *inline-general*          '(=    <    <=    >    >=
                                    fx=? fx<? fx<=? fx>? fx>=?
                                    fx=  fx<  fx<= fx> fx>= ;FIXME should be deleted
                                    cons car cdr null? list
                                    not
                                    vector-ref vector-set!
                                    string-ref string-set!
                                    eq? eqv? equal?
                                    assq assv assoc
                                    memq memv member
                                    void
                                    caar   cdar   cadr   cddr
                                    caaar  cdaar  cadar  cddar
                                    caadr  cdadr  caddr  cdddr
                                    caaaar cdaaar cadaar cddaar
                                    caadar cdadar caddar cdddar
                                    caaadr cdaadr cadadr cddadr
                                    caaddr cdaddr cadddr cddddr
                                    %cxr
                                    list-ref))
(define *inline-table*              (append *inline-math*
                                            *inline-general*))


(define *always-inlined*        '(%set-current-module
                                  %%set-current-module
                                  %%execute
                                  %%execute-handler))
;; ----------------------------------------------------------------------

(define *code-instr*            #f)
(define *code-constants*        '())
(define *code-labels*           0)
(define *compiling-file*        #f)  ;; is #t when we are compiling a file

(define *scmmod*                (find-module 'SCHEME))


(include "peephole.stk")
(include "assembler.stk")
(include "computils.stk")
(include "compfile.stk")
(include "comprewrite.stk")
(include "compflags.stk")

;; ----------------------------------------------------------------------
;; Debbugging support
;; ----------------------------------------------------------------------
;;= (export %compiler-debug)
;;=
;;= (define %compiler-debug (make-parameter #f))
;;=
;;= (define (dprintf . args)
;;=   (when  (%compiler-debug) (apply eprintf args)))
;;=

; ======================================================================
;
;                               SCOPE
;
; ======================================================================
(define-struct scope
  locals                        ; local symbols
  mlocals                       ; #t if symbols are macros
  parent)                       ; parent scope

;; find-symbol-in-env will return:
;;    - a symbol, if it is a local variable
;;    - a syntax object, if the symbol is bound to syntax
;;    - #f otherwise
(define (find-symbol-in-env symb env)
  (let Loop ((env env))
    (cond
     ((or (not env) (module? env))    #f)
     ((memq symb (scope-locals  env)) symb)
     ((assq symb (scope-mlocals env)) => cdr)
     (else                            (Loop (scope-parent env))))))

;;// FIXME:
;;//;; Temporary function for bootstraping the environment representation
;;//(define (%list->scope lst)
;;//  (if (null? lst)
;;//      #f
;;//      (make-scope (car lst) '() (%list->scope (cdr lst)))))
;;//
;;//;; Temporary function for bootstraping the environment representation
;;//(define (%scope->list sc)
;;//  (if (not sc)
;;//      '()
;;//      (cons (scope-locals sc)
;;//            (%scope->list (scope-parent sc)))))
;;//


(define (%debug-scope env)     ;; FIXME:
  (%debug "***SCOPE*** ~S\n" env)
  (let L ((env env))
    (when env
      (%debug "   ==> locals= ~S mlocals= ~S parent =~S"
              (scope-locals env) (scope-mlocals env) (scope-parent env))
      (L (scope-parent env)))))


; ======================================================================
;
;                               SYNTAX
;
; ======================================================================

;; find-syntax-in-env returns the syntax object to which symb is bound,
;; or #f
;; This is *not* to be used when accessing symbol values; it is to be
;; used when expanding macros -- to expand a form (S ...), we see if
;; S is syntax; if it's not, we don't bother doing anything else and
;; return the form as is.
;;
;; This is the usual way (almost all Schemes do this):
;;    (define-syntax f (syntax-rules () ((f) -1)))
;;    (let ((f (lambda () 10))) (macro-expand '(f))) => -1
;;    (let ((f (lambda () 10))) (f))                 => 10
(define (find-syntax-in-env symb env)
  (and (symbol? symb)
       (let ((val (find-symbol-in-env symb env)))         ; local macro?
         (if (%syntax? val)
             val
             (let ((val (symbol-value* symb               ; global macro?
                                       (compiler-current-module)
                                       #f)))
               (and (%syntax? val)
                    val))))))

(define (%macro-expand form env)
  (let ((map-expander (lambda (form)
                        (map* (lambda (x) (%macro-expand x env)) form))))
    (cond
     ((not (pair? form))          form)
     ((not (symbol? (car form)))  (map-expander form))
     (else  (let* ((name (car form))
                   (val  (find-syntax-in-env name env)))
              (if (or (eq?  name 'quote) (eq? name 'quasiquote))
                  form
                  (if (and (symbol? name) (%syntax? val))
                      (apply (%syntax-expander val) (cdr form))
                      (map-expander form))))))))

;; ======================================================================

(define-parameter compiler-current-module (current-module)
  (lambda (new)
    (unless (module? new)
      (error 'compiler-current-module "bad module parameter ~s" new))
    (add-file-module-list! new)
    new))




;; ----------------------------------------------------------------------

;; A label is just a number. Each instruction in the list *code-instr*
;; is either:
;;   - a list (instruction + arguments), or
;;   - a label (an integer number)
(define (new-label)
  (let ((lab *code-labels*))
    (set! *code-labels* (+ *code-labels* 1))
    lab))

(define %compiler-new-label new-label)  ;; public name of new-label

(define (emit . args)
  (set! *code-instr* (cons args *code-instr*)))


;; emit-label will emit the label 'lab' (an integer)
(define (emit-label lab)
  (set! *code-instr* (cons lab *code-instr*)))


; ======================================================================
;
;                               CONSTANTS
;
; ======================================================================

;; The global variable *code-constants* contains a list of constants for the
;; code being compiled.
;; Why is its index not also kept in the list? Because the index is the position
;; of the element in the list, and it's calculated when the compiler calls this
;; function (fetch-constant).
;;
;; (define *code-constants* (list-copy '(a b c d e)))
;; (fetch-constant 'c)  => 2
;; (fetch-constant 'a)  => 0
;; (fetch-constant 'x)  => 5   (and x is appended to the end of *code-constants*)
;;
(define (fetch-constant c)
  (let ((x (memq c *code-constants*)))
    (unless x
      ;; This constant was not in the table; add it.
      (set! x (list c))
      (set! *code-constants* (append! *code-constants* x)))
    (- (length *code-constants*) (length x))))

;; small-integer-constant? checks wether anobject is an exact integer in
;; a specific range (hardcoded to [ -2^15, 2^15 - 1 ] here). This is because
;; the STklos VM opcodes are 16-bit wide, so this is the range that fits an
;; opcode argument.
(define small-integer-constant?
  (let ((min-int (- (expt 2 15)))
        (max-int (- (expt 2 15) 1)))
    (lambda (v)
      (and (integer? v)
           (exact? v)
           (<= min-int v max-int)))))

;; Generates code for small constants.
;; v is the constant to be produced; env and tail? are ignored.
(define (compile-constant v env tail?)
  (cond
    ((eq? v #t)                        (emit 'IM-TRUE))
    ((eq? v #f)                        (emit 'IM-FALSE))
    ((eq? v '())                       (emit 'IM-NIL))
    ((eq? v -1)                        (emit 'IM-MINUS1))
    ((eq? v 0)                         (emit 'IM-ZERO))
    ((eq? v 1)                         (emit 'IM-ONE))
    ((eq? v (void))                    (emit 'IM-VOID))
    ((small-integer-constant? v)       (emit 'SMALL-INT v))
    (else                              (emit 'CONSTANT (fetch-constant v)))))


#|
<doc syntax quote
 * (quote <datum>)
 * '<datum>
 *
 * The quoting mechanism is identical to R5RS, except that keywords
 * constants  evaluate "to themselves" as numerical constants, string
 * constants, character constants, and boolean constants
 * @lisp
 * '"abc"     =>  "abc"
 * "abc"      =>  "abc"
 * '145932    =>  145932
 * 145932     =>  145932
 * '#t        =>  #t
 * #t         =>  #t
 * :foo       =>  :foo
 * ':foo      =>  :foo
 * @end lisp
 * NOTE: R5RS requires to quote constant lists and
 * constant vectors. This is not necessary with STklos.
doc>
|#
(define (compile-quote expr env tail?)
  (if (= (length expr) 2)
      (compile-constant (cadr expr) env tail?)
      (compiler-error 'quote expr "bad usage in ~S" expr)))

; ======================================================================
;
;                               DEFINE
;
; ======================================================================
(define *forward-globals* '())

(define (known-var? symbol)
  (or (symbol-bound? symbol)
      (memq symbol (compiler-known-globals))))

(define (compiler-warn-undef symbol epair)
  (compiler-warning (void) epair "reference to undefined symbol ~S" symbol))

(define (verify-global symbol epair)
  (unless (known-var? symbol)
    (cond
      ((compiler:warn-use-undefined-postpone)
       (set! *forward-globals* (cons (cons symbol epair) *forward-globals*)))
      ((compiler:warn-use-undefined)
       (compiler-warn-undef symbol epair)
       (register-new-global! symbol)))))        ; to avoid multiple warnings


(define (compiler-show-undefined-symbols)
  (for-each (lambda (x)
              (let ((symbol (car x))
                    (where  (cdr x)))
                (unless (known-var? symbol)
                  (compiler-warn-undef symbol where)
                  (register-new-global! symbol)))) ;; to avoid multiple warnings
            (reverse *forward-globals*))
  (set! *forward-globals* '()))



(define (define->lambda l)
  (if (> (length l) 2)
      (let ((bind (cadr l))
            (body (cddr l)))
        (if (pair? bind)
            (define->lambda `(define ,(car bind) (lambda ,(cdr bind) ,@body)))
            l))
      (begin
        (compiler-error 'define l "ill formed definition ~S" l)
        l)))

(define (compile-define args env tail?)
  (let* ((l   (define->lambda args))
         (who (cadr l)))
    (if (not (= (length l) 3))
        (compiler-error 'define args "bad definition")
        (if (not env)
            (if (symbol? who)
                (begin
                  (register-new-global! who)
                  (compile (caddr l) #f args #f)
                  (emit 'DEFINE-SYMBOL (fetch-constant who)))
                (compiler-error 'define args "bad variable name ~S" who))
            (compiler-error 'define args "internal define forbidden here ~S" args)))))


;;;;
;;;; REFERENCES & ASSIGNMENT
;;;;

;; compile-access will generate code for references and assignments.
;; The argments:
;;    - name: a symbol, the variable name.
;;    - env: the environment to be used.
;;    - epair: the extended pair (source s-expression) that originated a
;;      call to compile-acces.
;;    - ref: if #t, then it's a reference; if #f, it's an assignment.
(define (compile-access name env epair ref)

  ;; STklos organizes local environments as this: each level has a
  ;; maximum of 256 variables. However, the "(+ (* v1 256) v2)"
  ;; formula here does *not* mean that the variables are stored
  ;; linearly in frames that are 256 bytes apart.
  ;; The "256v1+v2" is actually an encoding in two bytes: 2*256 + 03 =
  ;; 0x0203. The first byte, 0x02, identifies the level, and the second
  ;; byte, 0x03, identifies the variable.
  ;; Later, the VM will, for example, do the following to access
  ;; a local variable in previous levels:
  ;;
  ;;    for (level = FIRST_BYTE(info); level; level--)
  ;;      e = (SCM) FRAME_NEXT(e);
  ;;    vm->val = FRAME_LOCAL(e, SECOND_BYTE(info));
  ;;
  ;; FIRST_BYTE gets the level; SECOND_BYTE gets the var address.
  ;;
  ;; make-word builds a 16-bit word that encodes level v1 and
  ;; variable at offset v2.
  (define (make-word v1 v2)               ;; FIXME: Add control
    (+ (* v1 256) v2))


  ;; The argument 'ref' determines if this is a set or a reference
  ;; (#f = set, #t = ref). So 'em' is used to simplify emmitting the
  ;; code: i1 is the instruction for ref, i2 is the instruction for
  ;; set.
  (define (em i1 i2 . args)
    (apply emit (if ref i1 i2) args))

  (let loop ((lev 0) (env env))
    ;; lev denotes the number of frames between the searched variable location
    ;; and the current frame. Note that the extra levels introduced by %let-syntax
    ;; don't result in a frame in the stack.
    (if (not env)
        ;; name is a global variable
        (begin
          (verify-global name epair)
          (em 'GLOBAL-REF 'GLOBAL-SET (fetch-constant name)))
        ;; name is a local variable
        (let loop2 ((idx 0) (l (scope-locals env)))
          (cond
            ((null? l)
             (if (null? (scope-mlocals env))
                 ;; we have only locals variables, increment lev by 1
                 (loop (+ lev 1) (scope-parent env))
                 ;; we have only macros at this level. Keep lev as is
                 (loop lev (scope-parent env))))
            ((eq? (car l) name)
             (if (zero? lev)
                 ;; variable in  innermost block
                 (case idx
                   ((0)  (em 'LOCAL-REF0 'LOCAL-SET0))
                   ((1)  (em 'LOCAL-REF1 'LOCAL-SET1))
                   ((2)  (em 'LOCAL-REF2 'LOCAL-SET2))
                   ((3)  (em 'LOCAL-REF3 'LOCAL-SET3))
                   ((4)  (em 'LOCAL-REF4 'LOCAL-SET4))
                   (else (em 'LOCAL-REF  'LOCAL-SET  idx)))
                 ;; local variable in a "between" block
                 (let ((arg (make-word lev idx)))
                   (if (small-integer-constant? arg)
                     (em 'DEEP-LOCAL-REF  'DEEP-LOCAL-SET (make-word lev idx))
                     (em 'DEEP-LOC-REF-FAR 'DEEP-LOC-SET-FAR ;; Use a FAR variants
                         (fetch-constant (cons lev idx)))))))
            (else   (loop2 (+ idx 1) (cdr l))))))))


(define (compile-reference name env epair tail?)
  (compile-access name env epair #t))

;; compile-set! will just call compile-access, and when doing so, will
;; set the 'ref' argument to #f. The 'ref' argument to compile-access
;; means "this is just a reference, not an assignment".
;; Before calling compile-access, compile-set! will check the syntax
;; for set! and also extract the variable name.
;;
;;     (compile-set! '(set! a (+ 2 b)))
;;      will make these two calls:
;;        (compile '(+ 2 b) env '(set! a + 2 b) #f)
;;        (compile-access 'a env '(set! a + 2 b) #f)
;;
;; The extended set! is treated separately.
(define (compile-set! args env tail?)
  (let ((len (length (cdr args))))
    (if (= len 2)
        (let ((var (cadr args))
              (val (caddr args)))
          (if (list? var)
              ;; This is a extended set! usage as in "(set! (f x y z) value)"
              (compile `((setter ,(car var)) ,@(cdr var) ,val) env args tail?)
              ;; R5RS usage
              (if (symbol? var)
                  (begin
                    (compile val env args #f)
                    (compile-access var env args #f))
                  (compiler-error 'set! args "~S is a bad symbol" var))))
        (compiler-error 'set! (cdr args) "bad assignment syntax in ~S" args))))

;;;;
;;;; IF
;;;;
;;
;; (if cond expr1 expr2) =>
;;    [ cond ]       * tail? = #f
;;    JUMP-FALSE L1
;;    [ expr1 ]
;;    GOTO L2
;;    L1:
;;    [ expr2 ] -or- IM-VOID
;;    L2:
(define (compile-if args env tail?)
  (let ((len (length (cdr args)))
        (l1  (new-label))
        (l2  (new-label)))
    (if (<= 2 len 3)
        (begin
          (compile (cadr args) env args #f)
          (emit 'JUMP-FALSE l1)
          (compile (caddr args) env args tail?)
          (emit 'GOTO l2)
          (emit-label l1)
          (if (= len 3)
              (compile (cadddr args) env args tail?)
              (emit 'IM-VOID))
          (emit-label l2))
        (compiler-error 'if args "bad syntax in ~S" args))))

;;
;; DEFINE-MACRO
;;
(define (compile-define-macro e env tail?)
  (if (not env)
      ;; We have a global macro
      (let ((l (define->lambda e)))
        (when (= (length l) 3)
          (let* ((l        (extended-lambda->lambda l))
                 (name     (cadr l))
                 (proc     (caddr l))
                 (mod      (compiler-current-module)))
            (if (symbol? name)
                (let ((obj `( (%%in-scheme '%make-syntax) ',name
                                                          ',proc
                                                          ,proc
                                                          ',(module-name mod))))
                  ;; produce code for defining the macro
                  (register-new-global! name)
                  (compile obj #f env #f)
                  (emit 'DEFINE-SYMBOL (fetch-constant name))
                  ;; register the macro, so that the compiler expand macro calls
                  (%symbol-define name (eval obj mod) mod))
                (compiler-error 'define-macro e "bad variable name ~S" name)))))
      (compiler-error 'define-macro e "internal define-macro forbidden here ~S" e)))


#|

                                A N D

<doc syntax and
 * (and <test~1~> ...)
 *
 * The |<test~i~>| expressions are evaluated from left to right, and the
 * value of the first expression that evaluates to a false value is
 * returned.  Any remaining expressions are not evaluated.  If all the
 * expressions evaluate to true values, the value of the last expression
 * is returned.  If there are no expressions then `#t` is returned.
 *
 * @lisp
 *   (and (= 2 2) (> 2 1))           =>  #t
 *   (and (= 2 2) (< 2 1))           =>  #f
 *   (and 1 2 'c '(f g))             =>  (f g)
 *   (and)                           =>  #t
 * @end lisp
doc>
|#
(define (compile-and args env tail?)
  (if (null? (cdr args))
      ;; Case (and) ==> #t
      (emit 'IM-TRUE)
      ;; General case
      ;; code for (and x1 x2 .. xn) is
      ;;      x1; jump-false l1; x2; jump-false l1; ... goto l2; l1: im-false; L2:
      (let ((lab1 (new-label))
            (lab2 (new-label)))
        (let Loop ((l (cdr args)))
          (cond ((null? l)           #f)
                ((null? (cdr l))     (compile (car l) env args tail?))
                (else                (compile (car l) env args #f)
                                     (emit 'JUMP-FALSE lab1)
                                     (Loop (cdr l)))))
        (emit 'GOTO lab2)
        (emit-label lab1)
        (emit 'IM-FALSE)
        (emit-label lab2))))

#|

                                O R
 *
<doc syntax or
 * (or <test~1~> ...)
 *
 * The |<test~i~>| expressions are evaluated from left to right, and the
 * value of the first expression that evaluates to a true value is
 * returned.  Any remaining expressions are not evaluated.  If all
 * expressions evaluate to false values, the value of the last expression
 * is returned.  If there are no expressions then `#f` is returned.
 *
 * @lisp
 *   (or (= 2 2) (> 2 1))            =>  #t
 *   (or (= 2 2) (< 2 1))            =>  #t
 *   (or #f #f #f)                   =>  #f
 *   (or (memq 'b '(a b c))
 *       (/ 3 0))                    =>  (b c)
 * @end lisp
doc>
|#
(define (compile-or args env tail?)
  ;; General case
  ;; code for (or x1 x2 .. xn) is
  ;;      x1; jump-true l1; x2; jump-true l1; ... ; im-false; L1:
  (let ((lab (new-label)))
    (let Loop ((l (cdr args)))
      (unless (null? l)
        (compile (car l) env args (and tail? (null? (cdr l))))
        (emit 'JUMP-TRUE lab)
        (Loop (cdr l))))
    (emit 'IM-FALSE)
    (emit-label lab)))


;;;;
;;;; BEGIN
;;;;
(define (compile-begin args env tail?)
  (let ((len (length (cdr args))))
    (case len
      ((0) ;; Body without form
           (emit 'IM-VOID))
      ((1) ;; A begin with only one sexpr in it
           (compile (cadr args) env args tail?))
      (else ;; General case
           (let Loop ((body (cdr args)))
             (if (null? (cdr body))
                 ;; last expression of the begin
                 (compile (car body) env args tail?)
                 ;; expression in the middle
                 (begin
                   (compile (car body) env args #f)
                   (Loop (cdr body)))))))))

;;;;
;;;; LAMBDA
;;;;
(define (compute-arity l)
  (let loop ((l l) (n 0))
    (cond
       ((null? l) n)
       ((pair? l) (loop (cdr l) (+ n 1)))
       (else      (- (- n) 1)))))

(define (extend-env env formals)
  ;; (extend-env env '(a b . c))  =>  scope (c b a) '() env)
  ;; (extend-env env 'x)          =>  scope (x)     '() env)
  (letrec ((aux (lambda (l res)
                  (cond
                     ((null? l) res)
                     ((pair? l) (aux (cdr l) (cons (car l) res)))
                     (else      (cons l res))))))
    (make-scope (aux formals '()) ; locals
                '()               ; mlocals
                env)))            ; parent

(define (extract-doc-and-name doc name body)
  ;; extract the doc string and and name of the prcedure if present in body
  ;; doc is a string and name is a keyword. They muts be at the start of body
  ;; retuns a list of the form (doc name body). doc and name are #f is absent
  (if (> (length body) 1)
      (let ((head (car body))
            (rest (cdr body)))
        (if (and (not doc) (string? head))
            (extract-doc-and-name head name rest)
            (if (and (not name) (keyword? head))
                (extract-doc-and-name doc head rest)
                (list doc name body))))
      (list doc name body)))

;;//(define (extend-current-env env symbol)
;;//  ;; Add just symbol to the current environment (used by let*)
;;//  (cons (append (car env) (list symbol))
;;//        (cdr env)))

;;  (define (valid-lambda? expr)
;;    (define (param-ok? l seen)
;;      (cond
;;       ((null? l)   #t)
;;       ((symbol? l) (if (memq l seen)
;;                    (compile-error "duplicate parameter ~S" l)
;;                    #t))
;;       ((pair? l)   (and (symbol? (car l))
;;                     (param-ok? (car l) seen)
;;                     (param-ok? (cdr l) (cons (car l) seen))))
;;       (else        (compile-error "bad procedure parameter ~S" l))))
;;
;;    ;; code of valid-lambda? starts here
;;
;;    (and (> (length expr) 2)
;;         (param-ok? (cadr expr) '())))
;;

(define (compile-body body env epair tail?)

  (define internal-macros '())

  (define (rewrite-body body)
    (let Loop ((l body) (defs '()))
      (let ((cur (cond
                   ((null? l)
                    (error "body is empty"))
                   ((and (pair? l)
                         (pair? (car l))
                         (find-syntax-in-env (caar l) env))
                    (%macro-expand (car l) env))
                   (else
                      (car l)))))
        (cond
          ((and (pair? cur) (eq? (car cur) 'begin))
            ;; Delete useless begin
            (Loop (append (cdr cur) (cdr l))
                  defs))
        ((and (pair? cur) (eq? (car cur) 'define))
           ;; This is an internal define
           (Loop (cdr l) (cons (cdr (define->lambda cur)) defs)))
        (else
           ;; We have parsed all the (starting) definitions
           (if (null? defs)
               `(begin ,@l)
               (let ((defs (reverse! defs)))
                 ;; Generate "similar" to a letrec*
                 `(let ,(map (lambda (x) (list (car x) #f)) defs)
                    ,@(map (lambda (x) `(set! ,@x)) defs)
                    ,@l))))))))

  ;; rewrite the body to transform internal define to letrec
  (compile (rewrite-body body) env epair tail?))

(define (compile-user-lambda formals body arity env src)  ; i.e R5RS ones
  (let* ((env  (extend-env env formals))
         (lab  (new-label))
         (info (extract-doc-and-name #f #f body))
         (doc  (car info))
         (name (cadr info))
         (body (caddr info)))

    (emit 'CREATE-CLOSURE lab arity)
    (compile-body body env body #t)
    (emit 'RETURN)
    (emit-label lab)

    (when doc ;; emit the docstring
      (emit 'DOCSTRG (fetch-constant doc)))

    (when name ;; emit the procedure name
      (emit 'PROCNAME
            (fetch-constant (string->symbol (keyword->string name)))))

    (if (compiler:keep-source)
        ;; emit the code source (in fact signature + body)
        (begin
          (emit 'FORMALS (fetch-constant (cadr src)))
          (emit 'SOURCE  (fetch-constant  (cddr src))))
        (when (compiler:keep-formals)
          ;; emit signature
          (emit 'FORMALS (fetch-constant (cadr src)))))))


;;; EXTENDED LAMBDAS
;;;
;;; This code is an adaptation of the contribution of Ian Wild <imw@acm.org>
;;; which provided Common Lisp style lambda lists for the original STk.
(define ext-lambda-key-get key-get)

(define (build-let* opt key rest-name user-visible-rest body)
  ;; Create a (LET*...) to do the actual bindings

  (define (pop x)
    (let ((pop-local-variable (gensym)))
      `(let ((,pop-local-variable (car ,x)))
         (set! ,x (cdr ,x))
         ,pop-local-variable)))


  (define (build-optional-let-header vars rest-name)
    (apply append
           (map (lambda (x)
                  (let ((var  (car x))
                        (init (cadr x))
                        (var? (caddr x)))
                    ;; if we have keywords, the end of optional
                    ;; happens when we encounter the end of the
                    ;; parameter list or the first keyword
                    (if key
                        ;; function accepts keywords
                        (cond
                          (var? `((,var? (and (pair? ,rest-name)
                                              (not (keyword? (car ,rest-name)))))
                                  (,var ,(if init
                                             `(if ,var? ,(pop rest-name) ,init)
                                             `(and ,var? ,(pop rest-name))))))
                          (init `((,var (if (or (null? ,rest-name)
                                                (keyword? (car ,rest-name)))
                                            ,init
                                            ,(pop rest-name)))))
                          (else `((,var (and (pair? ,rest-name)
                                             (not (keyword? (car ,rest-name)))
                                             ,(pop rest-name))))))
                        ;; function has optionals but no keywords
                        (cond
                          (var? `((,var? (pair? ,rest-name))
                                  (,var ,(if init
                                             `(if ,var? ,(pop rest-name) ,init)
                                             `(and ,var? ,(pop rest-name))))))
                          (init `((,var (if (null? ,rest-name)
                                            ,init
                                            ,(pop rest-name)))))
                          (else `((,var (and (pair? ,rest-name)
                                             ,(pop rest-name)))))))))
                  vars)))

   (define (constant? e)
     (cond
        ((symbol? e) #f)
        ((pair? e)   (memq (car e) '(quote lambda)))
        (else        #t)))

   (define (build-keyword-let-header vars rest-name)
     (apply append
            (map (lambda (x)
                   (let* ((var  (car x))
                          (init (cadr x))
                          (var? (caddr x))
                          (key  (make-keyword var)))
                     (cond
                        (var? (let ((g (gensym)))
                                `((,g (key-get ,rest-name ,key ',g))
                                  (,var? (not (eq? ,g ',g)))
                                  (,var ,(if init
                                             `(if ,var? ,g ,init)
                                             `(and ,var? ,g))))))
                        ((constant? init)
                            ;; if evaluating the initform is harmless, just
                            ;; call key-get with it as default
                            `((,var (key-get ,rest-name ,key ,init))))
                        (else
                             ;; only evaluate initform if get-keyword returns
                             ;; our newly gensym'ed symbol
                             (let ((g (gensym)))
                               `((,g (key-get ,rest-name ,key ',g))
                                 (,var (if (eq? ,g ',g) ,init ,g))))))))
                 vars)))


  (let ((error-check (if (or user-visible-rest key)
                         '()
                         `((if (pair? ,rest-name)
                               (error "too many optional parameters: ~a"
                                      ,rest-name)))))
        (vars (append (if opt (build-optional-let-header opt rest-name) '())
                      (if key (build-keyword-let-header key rest-name) '()))))
    `(let* (,@(if opt (build-optional-let-header opt rest-name) '())
            ,@(if key (build-keyword-let-header key rest-name) '()))
       ,@error-check
       (let () ,@body))))

(define (parse-parameter-list method? x)
  ;; Read the incoming lambda (or method) list, return a list of four lists,
  ;; the required, optional, keyword, and rest, in that order.
  ;; The last three elements can be #f if not present.
  ;; (Don't look too closely, this function isn't very nice.)
  (define required '())
  (define optional '())
  (define keywords '())
  (define rest     '())
  (define epair    x)


  (define (normalise-parameter-list x optional?)
    ;; Convert optional or keyword parameters to three-element lists:
    ;; (variable initform supplied-p), providing an  explicit #f
    ;; initform  if needed, and maybe another #f as supplied-p.
    (and (pair? x)
         (map (lambda (e)
                (cond
                  ((symbol? e)                  (list e #f #f))
                  ((and (pair? e)
                        (= (length e) 2)
                        (symbol? (car e)))      (append e (list #f)))
                  ((and (pair? e)
                        (= (length e) 3)
                        (symbol? (car e))
                        (symbol? (caddr e)))    e)
                  (else (compiler-error 'lambda epair "illegal ~a parameter: ~a"
                                        (if optional? "optional" "keyword") e)
                        (list (gensym) #f #f))))
              x)))

  (define (collect-sequence)
    (let loop ((seq '()) (still-left x))
      (if (or (null? still-left) (memq (car still-left) '(:optional :key :rest)))
          (begin
            (set! x still-left)
            (reverse seq))
          (loop (cons (car still-left) seq) (cdr still-left)))))

  (define (collect-titled-sequence title)
    (if (and (not (null? x)) (eq? (car x) title))
        (begin
          (set! x (cdr x))
          (collect-sequence))
        #f))

  (define (check-formals l seen)
    (unless (null? l)
      (let ((param (car l)))
        (cond
           ((symbol? param)
                    (if (memq param seen)
                        (compiler-error (void) epair "duplicate parameter ~S" param)
                        (check-formals (cdr l) (cons param seen))))
           ((and method? (list? param) (= (length param) 2))
                    (if (symbol? (cadr param))
                        (and (check-formals (list (car param)) seen)
                             (check-formals (cdr l) (cons (car param) seen)))
                        (compiler-error (void) epair "bad class name ~S" param)))
           (else    (compiler-error (void) epair
                                     "bad procedure parameter ~S" param))))))


  ;; If the original lambda list is *not* a proper list, i.e. a symbol
  ;; or a dotted list, add in the implied :rest
  (unless (list? x)
    (set! x (if (pair? x)
                (let* ((new-x (list-copy x))
                       (last  (last-pair new-x)))
                  (set-cdr! last (list :rest (cdr last)))
                  new-x)
                (list :rest x))))

  (set! required (collect-sequence))
  (set! optional (normalise-parameter-list (collect-titled-sequence :optional) #t))
  (set! rest     (collect-titled-sequence :rest))
  (set! keywords (normalise-parameter-list (collect-titled-sequence :key) #f))

  ;; Do some checks on the arguments
  ;; 1. no un-analyzed parameter
  (unless (null? x)
    (compiler-error 'lambda epair "illegal lambda list ending with ~a" x))

  ;; 2. Rest is a symbol (collect returns a list)
  (when rest
    (unless (and (= (length rest) 1) (symbol? (car rest)))
      (compiler-error 'lambda epair "rest parameter must be a single symbol"))
    (set! rest (car rest)))

  ;; 3. Every formal is a symbol and there is no duplicate
  (check-formals (append (if optional (map car optional) '())
                         (if keywords (map car keywords) '())
                         (if rest     (list rest)        '())
                         required)
                 '())
  ;; OK, let's go
  (list required optional keywords rest))


(define (rewrite-params-and-body method? formals body)
  ;; Rewrite the extended form as an ordinary (though headless) lambda form.
  ;; In a spurious attempt at efficiency, no LET* is generated
  ;; unless at least one of :optional and :key is used.
  (let* ((params (parse-parameter-list method? formals))
         (req    (car params))
         (opt    (cadr params))
         (key    (caddr params))
         (rest   (cadddr params)))
    (if (or opt key)
        ;; We have a :optional or a :key keyword
        (let ((rest-name (or rest (gensym))))
          (if (null? req)                                       ; FIXME: simpl
              (set! req rest-name)
              (set-cdr! (last-pair req) rest-name))
          `(,req  ,(build-let* opt key rest-name rest body)))
        ;; "Normal" lambda
        (begin (if rest
                   (if (null? req)
                       (set! req rest)
                       (set-cdr! (last-pair req) rest)))
               `(,req  ,@body)))))

(define (extended-lambda->lambda el)    ;; STklos lambda => R5RS lambda
  (if (> (length el) 2)
      (let* ((method? (eq? (car el) 'method))
             (formals (cadr el))
             (info    (extract-doc-and-name #f #f (cddr el)))
             (doc     (car info))
             (name    (cadr info))
             (body    (caddr info))
             (new     (rewrite-params-and-body method? formals body)))
        ;; new is a list with the arguments followed by the function body
        (let ((new-args (car new))
              (new-body (cdr new)))
          (when doc  (set! new-body (cons doc new-body)))  ;; add documentation
          (when name (set! new-body (cons name new-body))) ;; add proc-name
          ;; Build the final lambda
          `(lambda ,new-args ,@new-body)))
      (compiler-error 'lambda el "bad definition ~S" el)))


(define (compile-lambda args env tail?)
  (let* ((r5rs-lambda (extended-lambda->lambda args))
         (formals     (cadr r5rs-lambda))
         (body        (cddr r5rs-lambda))
         (arity       (compute-arity formals)))
    (compile-user-lambda formals body arity env args)))

;;;;
;;;; APPLICATION
;;;;

(define (compile-args actuals env)
  (unless (null? actuals)
    (compile (car actuals) env actuals #f)
    (emit 'PUSH)
    (compile-args (cdr actuals) env)))


(define (compile-var-args actuals number-of-fix env)
  ;; for a (a b . c), replace (1 2 3 4 5) by (1 2 (list 3 4 5))
  (let loop ((n number-of-fix) (f '()) (rest actuals))
    (if (zero? n)
        (compile-args `(,@(reverse f) (list ,@rest)) env)
        (loop (- n 1) (cons (car rest) f) (cdr rest)))))


(define %maybe-generate-line-information
  ;; keep the last generated file name to avoid to produce a new file
  ;; name (which is probably long) at each line information generation.
  (let ((%last-generated-file-name #f))
    (lambda (epair)
      (when (and (compiler:gen-line-number) (%epair? epair))
        ;; Generate a line number for the call
        (let ((file (%epair-file epair))
              (line (%epair-line epair)))
          (unless (equal? file %last-generated-file-name)
            (set! %last-generated-file-name file))
          ;; the parameter constant of instruction should be short
          (when (small-integer-constant? line)
            (compile-constant %last-generated-file-name '() #f)
            (emit 'PUSH)
            (emit 'CALL-LOCATION line)))))))


(define (generate-PREPARE-CALL epair)
  (emit 'PREPARE-CALL)
  (%maybe-generate-line-information epair))


(define (compile-normal-call fct actuals len env epair tail?)
  (generate-PREPARE-CALL epair)
  (compile-args actuals env)
  (compile fct env actuals #f)
  (emit (if tail? 'TAIL-INVOKE 'INVOKE)
        (length actuals)))

(define can-be-inlined?
  (let ((STklos (find-module 'STklos)))
    (lambda (fct env . alist)
      (let* ((table (if (null? alist) *inline-table* (car alist)))
             (found (memq fct table)))
        (if (and found
                 (not (find-symbol-in-env fct env)))
            (let ((f (symbol-value fct *scmmod*)))
              (and f (eq? f (symbol-value* fct STklos))))
            (and (null? alist)                     ; if alist was passed, it was
                 (memq fct *always-inlined*))))))) ; a request for THAT alist only

;; maybe-fold-constant takes the current environment, a list of
;; arguments and tries to math-fold them into constants.
;;
;; Example:
;;
;; (maybe-fold-constant #f '( 2.0 (log (sin 2)) (f 5) ))
;; => ( 2.0  -0.0950830360951606  (f 5) )
;;
;; * The number 2.0 remains unchanged;
;; * The expression (log (sin 2)) is evaluated;
;; * The expression (f 5) remains unchanged.
;;
;; (maybe-fold-constant #f '(expt 2 (expt 2 3))) => 256
;; (maybe-fold-constant #f '(expt x (expt 2 3))) => (expt x 8)
;; (maybe-fold-constant #f '(expt 2 (expt 2 x))) => (expt 2 (expt 2 x))
(define (maybe-fold-constant env args)
  (if (and (pair? args)
           (can-be-inlined? (car args) env *inline-math*))
      (let ((new-args (map (lambda (f) (maybe-fold-constant env f)) (cdr args))))
        (if (every number? new-args)
            (with-handler (lambda (_) args)
             (apply (symbol-value (car args) *scmmod*)
                    (map (lambda (f) (maybe-fold-constant env f)) new-args)))
            (cons (car args) new-args)))
      args))

;; fold-commutative-args will do constant folding in the arguments
;; as much as possible, and return a new argumetn list. This of
;; course should be used only for commutative operations.
;;
;; (fold-commutative-args + '(a 2 3 b -1)) => (4 a b)
;; (fold-commutative-args * '(a 2 3 b -1)) => (-6 a b)
(define (fold-commutative-args fct args)
  (let ((nums     (filter number? args))
        (non-nums (filter (lambda (x) (not (number? x))) args)))
    (if (null? nums)
        args
        (let ((num
               (let loop ((n (car nums)) (nums (cdr nums)))
                 (if (not (null? nums))
                     (loop (fct n (car nums)) (cdr nums))
                     n))))
          (cons num non-nums)))))



;; Before calling %compile-primitive-call, the function
;; compile-primitive-call will first try to do as much constant folding
;; as possible, for all math expressions.
;;
;; (exp (sqrt 5)) will end up generating:
;;
;; 000:  CONSTANT             0
;;
;; Constants:
;; 0: 9.35646901660115
;;
;; Also:
;; (disassemble-expr '(cos (+ 3 (tan 2))) #t)
;; 000:  CONSTANT             0
;;
;; Constants:
;; 0: 0.685897402427631
(define (compile-primitive-call fct actuals len env epair tail?)
  ;; First we call maybe-fold-constant, which will recursively do
  ;; constant folding on all arguments:
  (let ((actuals (map (lambda (arg) (maybe-fold-constant env arg)) actuals)))
    (if (can-be-inlined? fct env *inline-math-commutative*)
        ;; if the function is commutative:
        ;; fold-commutative and call %compile-primitive-call
        (let* ((f-val   (symbol-value fct *scmmod*))
               (actuals (fold-commutative-args f-val actuals))
               (len (length actuals)))
          (%compile-primitive-call fct actuals len env epair tail?))
        ;; otherwise (non-commutative), do not fold-commutative
        (%compile-primitive-call fct actuals len env epair tail?))))


;; %compile-primitive-call takes arguments already folded
(define (%compile-primitive-call fct actuals len env epair tail?)
  (let ((comp  (lambda (mnemo expr)
                 (compile expr env epair #f)
                 (emit mnemo)))
        (comp1 (lambda mnemo
                 (if (= len 1)
                     (begin
                       (compile (car actuals) env epair #f)
                       (apply emit mnemo))
                     (compiler-error fct epair "1 argument required (~A provided)"
                                     len))))
        (comp2 (lambda mnemo
                 (if (= len 2)
                     (begin
                       (compile (car actuals) env epair #f)
                       (emit 'PUSH)
                       (compile (cadr actuals) env epair #f)
                       (apply emit mnemo))
                     (compiler-error fct epair "2 arguments required (~A provided)"
                                     len))))
        (oper1 (lambda (mnemo a)
                 (compile a env epair #f)
                 (emit mnemo)))
        (oper2 (lambda (mnemo a b)
                 (compile a env epair #f)
                 (emit mnemo b)))
        (komp2 (lambda (mnemo a b)
                 (compile a env epair #f)
                 (emit 'PUSH)
                 (compile b env epair #f)
                 (emit mnemo)))
        (comp3 (lambda mnemo
                 (if (= len 3)
                     (begin
                       (compile (car actuals) env epair #f)
                       (emit 'PUSH)
                       (compile (cadr actuals) env epair #f)
                       (emit 'PUSH)
                       (compile (caddr actuals) env epair #f)
                       (apply emit mnemo))
                     (compiler-error fct epair "3 arguments required (~A provided)"
                                     len)))))
    (case fct
      ;; Always inlined functions
      ((%%set-current-module)
       (if (= len 1)
           (comp1 'SET-CUR-MOD)
           (compiler-error '%%set-current-module epair
                           "1 arg. only (~S)" len)))
      ((%%execute-handler)
       (comp3 'EXEC-HANDLER))

      ;; User functions
      ((+)  (case len
              ((0)  (emit 'IM-ZERO))
              ((1)  (if (number? (car actuals))
                        (compile (car actuals) env epair tail?)
                        (compile-normal-call fct actuals len env epair #f)))
              ((2)  (let ((a (car actuals))
                          (b (cadr actuals)))
                      (if (small-integer-constant? a)
                          (if (= a 1)
                              (oper1 'IN-INCR b)
                              (oper2 'IN-SINT-ADD2 b a))
                          (comp2 'IN-ADD2))))
              (else (compile-normal-call fct actuals len env epair #f))))
      ((-)  (case len
              ((0)  (compiler-error '- epair "needs at least one argument"))
              ((1)  (if (number? (car actuals))
                        (compile-constant (- (car actuals)) env #f)
                        (compile-normal-call fct actuals len env epair #f)))
              ((2)  (let ((a (car actuals))
                          (b (cadr actuals)))
                      (cond
                       ((and (number? a) (number? b))
                        (compile-constant (- a b) env tail?))
                       ((small-integer-constant? a)
                        (oper2 'IN-SINT-SUB2 b a))
                       ((eq? b 1)
                        (oper1 'IN-DECR a))
                       ((and (number? b)
                             (small-integer-constant? (- b)))
                        (oper2 'IN-SINT-ADD2 a (- b)))
                       (else
                        (comp2 'IN-SUB2)))))
              (else (compile-normal-call fct actuals len env epair #f))))
      ((*)  (case len
              ((0)  (emit 'IM-ONE))
              ((1)  (if (number? (car actuals))
                        (compile (car actuals) env epair tail?)
                        (compile-normal-call fct actuals len env epair #f)))
              ((2)  (let ((a (car actuals))
                          (b (cadr actuals)))
                      (if (small-integer-constant? a)
                          (oper2 'IN-SINT-MUL2 b a))
                      (comp2 'IN-MUL2)))
              (else (compile-normal-call fct actuals len env epair #f))))
      ((/)    (case len
                ((0)   (compiler-error '/ epair "needs at least one argument"))
                ((1)   (if (number? (car actuals))
                           (compile-constant (/ 1 (car actuals)) env #f)
                           (compile-normal-call fct actuals len env epair #f)))
                ((2)  (let ((a (car actuals))
                            (b (cadr actuals)))
                        (cond
                         ((and (number? a) (number? b))
                          (if (eq? b 0)
                              (compiler-error '/ epair "division by zero")
                              (compile-constant (/ a b) env tail?)))
                         ((small-integer-constant? b)
                          (oper2 'IN-SINT-DIV2 a b))
                         (else
                          (comp2 'IN-DIV2)))))
                (else  (compile-normal-call fct actuals len env epair #f))))
      ((fx+ fx- fx* fxquotient)
       (case len
         ((2) (let ((a (car actuals))
                    (b (cadr actuals)))
                (cond
                 ((and (eq? fct 'fxquotient) (eq? b 0))
                  (compiler-error 'fxquotient epair "division by 0"))
                 ((and (fixnum? a) (fixnum? b))
                  (compile-constant (case fct
                                      ((fx+) (fx+ a b))
                                      ((fx-) (fx- a b))
                                      ((fx*) (fx* a b))
                                      (else
                                       (fxquotient a b)))
                                    env
                                    tail?))
                 ((and (small-integer-constant? a)
                       (memq fct '(fx+ fx*))) ; commutative only
                  (oper2 (if (eq? fct 'fx+)
                             'IN-SINT-FXADD2
                             'IN-SINT-FXMUL2)
                         b a))
                 ((small-integer-constant? b)
                  (oper2 (case fct
                           ((fx+) 'IN-SINT-FXADD2)
                           ((fx-) 'IN-SINT-FXSUB2)
                           ((fx*) 'IN-SINT-FXMUL2)
                           (else  'IN-SINT-FXDIV2))
                         a b))
                 (else
                  (comp2 (case fct
                           ((fx+) 'IN-FXADD2)
                           ((fx-) 'IN-FXSUB2)
                           ((fx*) 'IN-FXMUL2)
                           (else  'IN-FXDIV2)))))))
         (else
          (compile-normal-call fct actuals len env epair #f))))

      ((= < > <= >=)
       (case len
         ((O)   (compiler-error fct epair
                                "needs at least one argument" fct))
         ((2)   (comp2 (case fct
                         ((=)  'IN-NUMEQ)
                         ((<)  'IN-NUMLT)
                         ((>)  'IN-NUMGT)
                         ((<=) 'IN-NUMLE)
                         ((>=) 'IN-NUMGE))))
         (else  (compile-normal-call fct actuals len env epair #f))))

      ((fx=? fx<? fx>? fx<=? fx>=?
        fx=  fx<  fx>  fx<=  fx>= )
       (case len
         ((O)   (compiler-error fct epair
                                "needs at least one argument" fct))
         ((2)   (comp2 (case fct
                         ((fx=?  fx=)  'IN-FXEQ)
                         ((fx<?  fx<)  'IN-FXLT)
                         ((fx>?  fx>)  'IN-FXGT)
                         ((fx<=? fx<=) 'IN-FXLE)
                         ((fx>=? fx>=) 'IN-FXGE))))
         (else  (compile-normal-call fct actuals len env epair #f))))

      ;; This entry is here just because we declared these functions in the
      ;; inline table.  We don't need to inline them, because they were dealt
      ;; with in a previous step by fold-commutative-args and
      ;; maybe-fold-constant.
      ((sin cos tan asin acos exp log sinh cosh tanh asinh acosh atanh sqrt
        square expt atan gcd lcm)
       (compile-normal-call fct actuals len env epair #f))

      ((cons)   (comp2 'IN-CONS))
      ((car)    (comp1 'IN-CAR))
      ((cdr)    (comp1 'IN-CDR))
      ((null?)  (comp1 'IN-NULLP))
      ((not)    (comp1 'IN-NOT))
      ((list)   (compile-args actuals env)
       (emit 'IN-LIST len))
      ((vector-ref)     (comp2 'IN-VREF))
      ((vector-set!)    (comp3 'IN-VSET))
      ((string-ref)     (comp2 'IN-SREF))
      ((string-set!)    (comp3 'IN-SSET))
      ((eq?)            (comp2 'IN-EQ))
      ((eqv?)           (comp2 'IN-EQV))
      ((equal?)         (comp2 'IN-EQUAL))

      ((assq)           (comp2 'IN-ASSOC 1))
      ((assv)           (comp2 'IN-ASSOC 2))
      ((assoc)          (case len
                          ((2) (comp2 'IN-ASSOC 3))
                          ((3) (comp3 'IN-ASSOC 4))
                          (else (compile-normal-call fct actuals len env epair #f))))

      ((memq)           (comp2 'IN-MEMBER 1))
      ((memv)           (comp2 'IN-MEMBER 2))
      ((member)          (case len
                          ((2) (comp2 'IN-MEMBER 3))
                          ((3) (comp3 'IN-MEMBER 4))
                          (else (compile-normal-call fct actuals len env epair #f))))


      ((void)           (if (zero? len)
                            (emit 'IM-VOID)
                            (compile (append (cons 'begin actuals) (list (void)))
                                     env epair #f)))

      ;; The cxr closures are very commonly used, call the specialized IN-CXR instr.
      ((caar cdar cadr cddr
        caaar cdaar cadar cddar caadr cdadr caddr cdddr
        caaaar cdaaar cadaar cddaar caadar cdadar caddar cdddar
        caaadr cdaadr cadadr cddadr caaddr cdaddr cadddr cddddr)
                       (if (= len 1)
                           (let ((conv
                                  (lambda (name)
                                    (let ((s (string->list (symbol->string name))))
                                      (string->keyword
                                            (list->string (cdr (reverse (cdr s)))))))))
                             (oper2 'IN-CXR
                                    (car actuals)
                                    (fetch-constant (conv fct))))
                           (compile-normal-call fct actuals len env epair #f)))

      ;; (%cxr lst #:ada) ==> inline call
      ((%cxr)           (if (and (= len 2) (keyword? (cadr actuals)))
                            (oper2 'IN-CXR (car actuals) (fetch-constant (cadr actuals)))
                            (compile-normal-call fct actuals len env epair #f)))
      ((list-ref)       (if (= len 2)
                            (case (cadr actuals)
                              ((0) (compile `(car ,(car actuals)) env epair #f))
                              ((1) (compile `(cadr ,(car actuals)) env epair #f))
                              ((2) (compile `(caddr ,(car actuals)) env epair #f))
                              ((3) (compile `(cadddr ,(car actuals)) env epair #f))
                              (else  (compile-normal-call fct actuals len env epair #f)))
                            (compile-normal-call fct actuals len env epair #f)))

      (else             (panic "unimplemented inline primitive ~S" fct)))))



(define (compile-lambda-call fct actuals len env epair tail?)
  ;; Compilation of ( [LAMBDA(.)...] ..... )
  (let* ((fct     (extended-lambda->lambda fct))
         (formals (cadr fct))
         (body    (cddr fct))
         (arity   (compute-arity formals)))
    (if (or (= arity len)
            (and (negative? arity) (>= len (- (- arity) 1))))
        (if (zero? len)
            ;; ([lambda () ...]) or (let() ...)
            ;; ==> (begin ...)
            ;; NOTE: compile-body takes care of internal defines
            (compile-body body env epair tail?)
            ;; len > 0 ==> produce an ENTER-LET
            (let ((kind    (if tail? 'ENTER-TAIL-LET 'ENTER-LET))
                  (new-env (extend-env env formals)))
              (generate-PREPARE-CALL epair)
              (if (negative? arity)
                  (begin
                    (compile-var-args actuals (- (- arity) 1) env)
                    (emit kind (- arity)))
                  (begin
                    (compile-args actuals env)
                    (emit kind len)))
              (compile-body body new-env epair tail?)
              (emit (if tail? 'RETURN 'LEAVE-LET))))
        (compiler-error 'lambda epair "bad number of parameters ~S" actuals))))


(define (compile-call args env tail?)
  (let* ((fct     (car args))
         (actuals (cdr args))
         (len     (length actuals)))
    (if (and (pair? fct) (or (eq? (car fct) 'lambda)
                          (eq? (car fct) '|λ|)))
        ;; fct is (lambda (...) ...)
        ;;    if fct is not an epair, it is probably because it has been
        ;;    built programmatically. Anyway its body is probably an epair
        (let ((ep (cond
                    ((%epair? fct) fct)
                    ((>= (length fct) 3) (cddr fct))
                    (else fct))))
          (compile-lambda-call fct actuals len env ep tail?))
        (begin
          (let ((expr (maybe-fold-constant env (cons fct actuals))))
            (if (not (pair? expr))
                (compile-constant expr env tail?)
                (if (can-be-inlined? fct env)
                    (compile-primitive-call fct actuals len env args tail?)
                    (compile-normal-call    fct actuals len env args tail?))))))))

;;;;
;;;; LET / LET* / LETREC
;;;;

;; check-let-bindings returns #t if:
;;
;; - its first argument must be a valid LET binding
;; - when the second argument is #t, there may not be duplicate bindings
;;
;; When these conditions are not satisfied, the procedure signals an error.
;;
;; (check-let-bindings 1 #t) => error (syntax error)
;; (check-let-bindings '() #t) => #t
;; (check-let-bindings '((a 2) (a 3)) #t) => error (duplicate binding)
;; (check-let-bindings '((a 2) (a 3)) #f) => #t
(define (check-let-bindings who bindings unique?)
  (letrec
      ((err (lambda (b) (compiler-error who bindings "malformed binding ~S" b)))
       (aux (lambda (l seen)
              (cond
               ((null? l) #t)
               ((pair? l) (let ((b (car l)))
                            (if (and (list? b)
                                     (= (length b) 2)
                                     (symbol? (car b)))
                                (if (and unique? (memq (car b) seen))
                                    (compiler-error who bindings
                                                     "duplicate binding ~S" (car b))
                                    (aux (cdr l) (cons (car b) seen)))
                                (err b))))
               (else (err l))))))
    (aux bindings '())))

;;
;; LETREC
;;

(define (compile-letrec args env tail?)
  (let ((len (length args)))
    (if (< len 3)
        (compiler-error 'letrec args "ill formed letrec ~S" args)
        (let ((bindings (cadr args))
              (body     (cddr args)))
          (if (null? bindings)
              (compile-body body env body tail?)
              (when (check-let-bindings 'letrec bindings #t)
                (let ((tmps (map (lambda (_) (gensym)) bindings)))
                  (compile `(let ,(map (lambda (x) (list (car x) #f)) bindings)
                              (let ,(map (lambda (x y) (list x (cadr y)))
                                         tmps bindings)
                                ,@(map (lambda (x y) `(set! ,(car y) ,x))
                                       tmps bindings))
                              (let () ,@body))
                           env args tail?))))))))

;;
;; LET (& named let)
;;

(define (compile-named-let name bindings body len args env tail?)
  (if (< len 4)
      (compiler-error 'let args "ill formed named let ~S" args)
      (when (check-let-bindings 'let bindings #t)
        (compile `((letrec ((,name (lambda ,(map car bindings) ,@body)))
                       ,name)
                   ,@(map cadr bindings))
                 env
                 args
                 tail?))))


(define (compile-let args env tail?)
  (let ((len (length args)))
    (if (< len 3)
        (compiler-error 'let args "ill formed let ~S" args)
        (let ((bindings (cadr args))
              (body     (cddr args)))
          (if (symbol? bindings)
              ;; Transform named let in letrec
              (compile-named-let bindings (car body) (cdr body) len args env tail?)
              (when (check-let-bindings 'let bindings #t)
                (compile `((lambda ,(map car bindings) ,@body)
                           ,@(map cadr bindings))
                         env args tail?)))))))

;;
;; LET*
;;

;; Here is a simple version (inefficient) of compile-let*
;;
;;    (define (compile-let* args env tail?)
;;      (let ((len (length args)))
;;        (if (< len 3)
;;      (compiler-error 'let* args "ill formed let* ~S" args)
;;      (let ((bindings (cadr args))
;;            (body     (cddr args)))
;;        (when (check-let-bindings 'let* bindings #f)
;;          (compile (if (<= (length bindings) 1)
;;                       `(let ,bindings ,@body)
;;                       `(let (,(car bindings))
;;                          (let* ,(cdr bindings)
;;                            ,@body)))
;;                   env args tail?))))))
;;

(define (compile-let* args env tail?)
  ;; This is a little bit tricky
  ;; We have something like
  ;; (let ((a E1) (b E2)) ...) =>
  ;;              (let ((a #f) (b #f))          [1]
  ;;                (set! a E1) (set! b E2)     [2]
  ;;                 ...)                       [3]
  ;;
  ;; For [1], we have 2 special instructions which reserve space on the stack
  ;; For [2], this is a little bit more complicate since E1 must be evaluated
  ;; in an environment without a, E2 must be evaluated in an environment with
  ;; a and without b
  ;; [3] must be evaluated in an environment where a and b are defined;
  ;;
  ;; If there are multiple definition of the same variable, it is multi-allocated
  ;; but only one slot will be used. Not a big deal, in general
  (let ((len (length args)))
    (if (< len 3)
        (compiler-error 'let* args "ill formed let* ~S" args)
        (let ((bindings (cadr args))
              (body     (cddr args)))
          (when (check-let-bindings 'let* bindings #f)
            (if (<= (length bindings) 1)
                (compile-let `(let ,bindings ,@body) env tail?)
                (begin
                  (emit (if tail? 'ENTER-TAIL-LET-STAR 'ENTER-LET-STAR)
                        (length bindings))
                  (let Loop ((l bindings)
                             (locals '()))
                    (if (null? l)
                        ;; Compile body
                        (let ((new-env (extend-env env locals)))
                          (compile-body body new-env body tail?)
                          (emit (if tail? 'RETURN 'LEAVE-LET)))
                        ;; Compile an assignment
                        (let* ((var (caar l))
                               (val (cadar l))
                               (loc (cons var locals)))
                          (compile val (extend-env env locals) args #f)
                          (compile-access var (extend-env env loc) args #f)
                          (Loop (cdr l)
                                loc)))))))))))

;;
;; COND
;;
(define (rewrite-cond-clauses c)
  (cond
   ((null? c)                 (void))
   ((not (pair? (car c)))     (compiler-error 'cond c "invalid clause ~S" (car c)))
   ((eq? (caar c) 'else)      (if (null? (cdr c))
                                  `(begin ,@(cdar c))
                                  (compiler-error 'cond
                                                   c
                                                   "else not in last clause ~S"
                                                   c)))
   ((and (pair? (cdar c)) (eq? (cadar c) '=>))
                              (if (and (list? (car c)) (= (length (car c)) 3))
                                  (let ((test-var (gensym)))
                                    `(let ((,test-var ,(caar c)))
                                       (if ,test-var
                                           (,(caddar c) ,test-var)
                                           ,(rewrite-cond-clauses (cdr c)))))
                                  (compiler-error 'cond
                                                   c
                                                   "bad '=>' clause syntax ~S"
                                                   (car c))))
   ((null? (cdar c))          (let ((test-var (gensym)))
                                `(let ((,test-var ,(caar c)))
                                   (or ,test-var
                                       ,(rewrite-cond-clauses (cdr c))))))
   (else                      `(if ,(caar c)
                                   (begin ,@(cdar c))
                                   ,(rewrite-cond-clauses (cdr c))))))

(define (compile-cond e env tail?)
  (let ((new-form (rewrite-cond-clauses (cdr e))))
    (compile new-form env e tail?)))

;;
;; CASE
;;

(define (rewrite-case-clauses key clauses)
  ;; Some controls on the case form
  (let ((all-values '()))
    (for-each (lambda (clause)
                (if (pair? clause)
                    (cond
                      ((eq? (car clause) 'else)
                           'ok)
                      ((pair? (car clause))
                           ;; OK but verify that there are no duplicates
                           (for-each (lambda (x)
                                       (if (memv x all-values)
                                           (compiler-error
                                               'case clause
                                               "duplicate case value ~S in ~S"
                                               x clause)))
                                     (car clause))
                           (set! all-values (append (car clause) all-values)))
                      (else
                           (compiler-error 'case clause
                                           "ill formed case clause ~S" clause)))
                    (compiler-error 'case clauses
                                    "invalid clause syntax in ~S" clause)))
              clauses))

  ;; Generate equivalent cond form
  `(cond ,@(map (lambda (clause)
                  ;; We are not sure it is a well formed clause since
                  ;; previous checks may not call error (file compilation)
                  (if (pair? clause)
                      (let* ((case   (car clause))
                             (imply? (and (pair? (cdr clause))
                                          (eqv? (cadr clause) '=>)))
                             (exprs  (if imply? (cddr clause) (cdr clause)))
                             (len    (length exprs)))
                        (if (eq? case 'else)
                            ;; else clause
                            (cond
                              ((and imply? (= len 1))     ;; (else => f)
                               `(else (,(car exprs) ,key)))
                              (imply?                     ;; (else => f ...)
                               (compiler-error 'case
                                               '=>
                                               "ill formed else clause ~S"
                                               `(else => ,@exprs)))
                               (else
                                `(else ,@exprs)))
                            ;; normal clause
                            (cond
                              ((and imply? (= len 1))     ;; ((x y) => f)
                               (if (= (length case) 1)
                                    `((eqv? ,key ',(car case)) (,(car exprs) ,key))
                                    `((memv ,key ',case)       (,(car exprs) ,key))))
                              (imply?                     ;; (else => ....)
                               (compiler-error 'case
                                               '=>
                                               "ill formed clause ~S"
                                               `(=> ,@exprs)))
                              (else
                               (if (= (length case) 1)
                                   `((eqv? ,key ',(car case)) ,@exprs)
                                   `((memv ,key ',case) ,@exprs))))))))
                clauses)))

(define (compile-case e env tail?)
  (if (> (length e) 2)
      (let* ((key     (cadr e))
             (clauses (cddr e))
             (new-form (if (pair? key)
                           (let ((newkey (gensym)))
                             `(let ((,newkey ,key))
                                ,(rewrite-case-clauses newkey clauses)))
                           (rewrite-case-clauses key clauses))))
        (compile new-form env e tail?))
      (compiler-error 'case e "no key given")))

;;
;; DO
;;
;; (do ((a a0 a+)
;;      (b b0 b+)
;;      ...)
;;     (test fin)
;;   <body>) =>
;;
;;      (letrec ((NAME (lambda (a b ...)
;;                       (if test
;;                         (begin fin)
;;                         (begin <body>
;;                               (name a+ b+ ...))))))
;;         (NAME a0 b0 ...))
(define (rewrite-do inits test body)
  (let ((loop-name (gensym)))
    `(letrec ((,loop-name
       (lambda ,(map car inits)
         (if ,(car test)
             (begin ,@(if (null? (cdr test))
                          (list (void))
                          (cdr test)))
             (begin ,@body
                    (,loop-name ,@(map (lambda (init)
                                         (if (< (length init) 2)
                                             (compiler-error 'do
                                                              init
                                                              "bad binding ~S"
                                                              init)
                                             (if (null? (cddr init))
                                                 (car init)
                                                 (caddr init))))
                                       inits)))))))
       (,loop-name ,@(map cadr inits)))))


(define (compile-do e env tail?)
  (if (>= (length e) 3)
      (compile (rewrite-do (cadr e) (caddr e) (cdddr e))
               env
               e
               #f)
      (compiler-error 'do e "bad syntax")))

;;
;; QUASIQUOTE
;;

(define (backquotify e level)
  (cond
    ((pair? e)
       (cond
         ((eq? (car e) 'quasiquote)
               (list 'list ''quasiquote
                     (backquotify (cadr e) (+ level 1))))
         ((eq? (car e) 'unquote)
               (if (<= level 0)
                   (cadr e)
                   (list 'list ''unquote
                         (backquotify (cadr e) (- level 1)))))
         ((eq? (car e) 'unquote-splicing)
              (if (<= level 0)
                  (list 'cons
                        (backquotify (car e) level)
                        (backquotify (cdr e) level))
                  (list 'list ''unquote-splicing
                        (backquotify (cadr e) (- level 1)))))
         ((and (<= level 0) (pair? (car e)) (eq? (caar e) 'unquote-splicing))
              (if (null? (cdr e))
                  (cadar e)
                  (list 'append (cadar e)
                        (backquotify (cdr e) level))))
         (else
              (list 'cons
                    (backquotify (car e) level)
                    (backquotify (cdr e) level)))))
    ((vector? e)
       (list 'list->vector (backquotify (vector->list e) level)))
    ((symbol? e)
       (list 'quote e))
    (else
       e)))

(define (compile-quasiquote e env tail?)
  (if (= (length e) 2)
      (compile (backquotify (cadr e) 0) env e tail?)
      (compiler-error 'quasiquote e "bad syntax")))


;;
;; WITH-HANDLER
;;
(define (compile-with-handler e env tail?)
  (if (> (length e) 2)
      (let ((handler (cadr e))
            (body    (cddr e))
            (lab     (new-label)))
        (compile handler env e #f)
        (emit 'PUSH-HANDLER lab)
        (compile `(begin ,@body) env body #f)
        (emit 'POP-HANDLER)
        (emit-label lab))
      (compiler-error 'with-handler e "bad syntax")))


;;
;; INCLUDE
;;
(define (%include-file name  case-sensitive?)
  (let ((port (open-input-file name))
        (old  *compiler-port*))
    (with-handler (lambda (c) (set! *compiler-port* old) (raise c))
                  (set! *compiler-port* port)
                  (unless case-sensitive?
                    (%port-case-sensitive-set! port #f))
                  (do ((expr (%read port) (%read port)))
                      ((eof-object? expr))
                    (compile expr #f expr #f))

                  (set! *compiler-port* old))
    (close-port port)))


(define (compile-include e env tail)
  (unless (every string? (cdr e))
    (compiler-error 'include e "bad include directive ~S" e))
  (for-each (lambda (f) (%include-file f #t))
            (cdr e)))

(define (compile-include-ci e env tail)
  (unless (every string? (cdr e))
    (compiler-error 'include-ci e "bad include directive ~S" e))
  (for-each (lambda (f) (%include-file f #f))
            (cdr e)))


;; ======================================================================

;; Compiles access to a symbol in the SCHEME module, using a special
;; VM instruction INSCHEME:
;;
;; (%%in-scheme x) =>
;;    GLOBAL-REF           0
;;    INSCHEME
;;
;; Constants:
;; 0: x
(define (compile-in-scheme e env tail)
  (if (= (length e) 2)
      (begin
        (compile (cadr e) env (cadr e) tail)
        (emit 'INSCHEME))
      (compiler-error '%%in-scheme e "expected one argument")))

;;;;======================================================================
;;;;
;;;;            LET-SYNTAX
;;;;
;;;;======================================================================
#|
This implementation is incorrect.
For instance,
(let ((x 'outer))
  (let-syntax ((m (syntax-rules () ((m a) (list x a)))))
    (let ((x 'inner))
      (cons x (m 17)))))    => (inner inner 17)

It should probably produce (outer inner 17) if we want to be coherent with
the R7RS form
(let ((x 'outer))
  (let-syntax ((m (syntax-rules () ((m a) (list x a)))))
    (let ((x 'inner))
      (cons x (m 17)))))

NOTE: Hopefully our implementation produce the SAME (incorrect) result for
both forms.
|#
(define (compile-%let-syntax e env tail?)
  (let ((len (length e)))
    (if (< len  3)
        (compiler-error '%let-syntax e "ill formed %let-syntax ~S" e)
        (let ((bindings (cadr e))
              (body     (cddr e)))
          (if (null? bindings)
              (compile-body body env body tail?)
              (let Loop ((bindings bindings)
                         (new-env  '()))
                (if (null? bindings)
                    ;; compile body in a new environement
                    (compile-body body
                                  (make-scope '() new-env env)
                                  body
                                  tail?)
                    ;; build a new macro environment for evaluating body
                    (let ((new (car bindings)))
                      (unless (and (list? new) (= (length new) 2))
                        (compiler-error '%let-syntax new
                                        "ill formed binding ~S" new))
                      (let* ((name      (car new))
                             (expander  (cadr new))
                             (new-macro ( (%%in-scheme '%make-syntax)
                                          name
                                          expander
                                          (eval expander)
                                          #f))) ; #f =>  non global macro
                        (Loop (cdr bindings)
                              (cons (cons name new-macro)
                                    new-env)))))))))))

;;;;======================================================================
;;;;
;;;;            Special Calls
;;;;
;;;;======================================================================

;;;;
;;;; Utilities for REQUIRE / REQUIRE-FOR-SYNTAX
;;;;
(define (find-file-information file lib-only? eventually-compile?)

  (define (compile-and-find-infos path)
    (let ((tmp (create-temp-file)))
      (compile-file path tmp)
      (let ((infos (%file-information tmp)))
        (remove-file tmp)
        (set! infos (key-set! infos :nature 'source))
        infos)))

  (let ((path (find-path file
                         (if lib-only?
                             (list (%library-prefix 'data))
                             (load-path)))))
    (if path
        (let ((infos (%file-information path)))
          (if (and eventually-compile?
                   (eq? (key-get infos :nature 'unknown) 'source))
              ;; We have a source file (i.e. no info, compile it to have them)
              (parameterize ((compiler:time-display #f))
                 (compile-and-find-infos path))
              infos))
        '())))


(define (import-file-information infos)
  (when (pair? infos)
    ;; Register all the global symbols of the file
    (for-each register-new-global! (key-get infos :globals '()))

    ;; Rebuild the expanders exported by the imported file.
    (for-each (lambda (x)
                (let* ((names   (car x))
                       (modname (cadr x))
                       (proc    (caddr x))
                       (name    (cdr names))
                       (module  (or (find-module modname #f)
                                    (%create-module modname)))
                       (expander (eval proc module))
                       (obj      (%make-syntax name
                                               proc
                                               expander
                                               modname)))
                  ;; Define the expander in the imported module
                  (%symbol-define name obj module)

                  ;; Add the current expander in the exported list of imported
                  ;; module
                  ;; NOTE: Since the expander is in the file information, it
                  ;; is exported. We need to add it to the export list, so
                  ;; that an import clause can retrieve it at compile time
                  ;; when we produce a .ostk file. This is not necessary for
                  ;; import of source file, but mandatory for file compilation.
                  (let ((exports (%module-exports module)))
                    (unless (member names exports)
                      (%module-exports-set! module (cons names exports))))))
              (key-get infos :macros '()))))


(define (%grab-file-information str)
  (let ((info (find-file-information str #f #f)))
    (import-file-information info)))

;;;;
;;;; REQUIRE
;;;;
(define (compile-require e env tail)
  ;; Require is not really special (it is in fact compiled as a normal call)
  ;; We just try to add the globals of the file to the list of known
  ;; globals. This is very empiric, but it avoids to add too much false
  ;; warning when compiling a file using another one.
  (when (and (= (length e) 3)
             (string? (cadr e))
             (boolean? (caddr e)))
    (let ((infos (find-file-information (cadr e) (caddr e) #f)))
      (import-file-information infos)))

  (compile-normal-call (car e) (cdr e) (length e) env e tail))


;;;;
;;;; WHEN-COMPILE
;;;;
(define (compile-when-compile e env tail)
  (with-handler (lambda (c)
                  (eprintf "*** Exception on when-compile form of ~S\n" e)
                  (raise c))
     (eval `(begin ,@(cdr e) (void)))))

(define-macro (when-compile . body)
  `(begin
     (%%when-compile ,@body)
     (void)))

(define-macro (when-load-and-compile . body)
  `(begin
     (%%when-compile ,@body)
     ,@body
     (void)))

;; The expression, 'e', is of the form '(%%label nnnn)',
;; where nnnn is an integer that describes this label.
(define (compile-%%label e env tail)
  (if (= (length e) 2)
      (emit-label (cadr e))
      (compiler-error '%%label e "bad usage ~S" e)))

;; The expression, 'e', is something like '(%%goto nnnn)',
;; where nnnn is a label.
(define (compile-%%goto e env tail)
  (if (= (length e) 2)
      (emit 'GOTO (cadr e))
      (compiler-error '%%goto e "bad usage ~S" e)))


(define (compile-%%source-pos e env tail)
  (compile (if (%epair? e)
               `(cons ,(%epair-file e) ,(%epair-line e))
               #f)
           '()
           e
           #f))

;;;;======================================================================
;;;;
;;;;            The bytecode compiler
;;;;
;;;;======================================================================
(define (compile expr env epair tail?)
  (let ((e (if (compiler:source-rewrite) (rewrite-expression expr env) expr)))
    (cond
     ;; ---- We have a pair
     ((pair? e)
      (let ((first (car e)))
         (cond
         ((find-syntax-in-env first env)
          ;; ---- Macro call
          (compile (%macro-expand e env) env epair tail?))

         ((find-symbol-in-env first env)
          ;; --- Symbol is in environment => function call
          (compile-call e env tail?))

         (else
          ;; ---- special-form OR (not in env) function call?
          (case first
            ((if)                 (compile-if             e env tail?))
            ((define)             (compile-define         e env tail?))
            ((begin)              (compile-begin          e env tail?))
            ((lambda λ)                (compile-lambda         e env tail?))
            ((let %let)           (compile-let            e env tail?))
            ((let*)               (compile-let*           e env tail?))
            ((letrec)             (compile-letrec         e env tail?))
            ((and)                (compile-and            e env tail?))
            ((or)                 (compile-or             e env tail?))
            ((cond)               (compile-cond           e env tail?))
            ((case)               (compile-case           e env tail?))
            ((do)                 (compile-do             e env tail?))
            ((quote)              (compile-quote          e env tail?))
            ((quasiquote)         (compile-quasiquote     e env tail?))
            ((with-handler)       (compile-with-handler   e env tail?))
            ((define-macro)       (compile-define-macro   e env tail?))

            ((%%set!)             (compile-set!           e env tail?))

            ((%let-syntax)        (compile-%let-syntax     e env tail?))

            ;; Special calls
            ((%%require)          (compile-require        e env tail?))
            ((%%when-compile)     (compile-when-compile   e env tail?))
            ((%%include)          (compile-include        e env tail?))
            ((%%include-ci)       (compile-include-ci     e env tail?))
            ((%%in-scheme)        (compile-in-scheme      e env tail?))
            ((%%source-pos)       (compile-%%source-pos   e env tail?))
            ((%%label)            (compile-%%label        e env tail?))
            ((%%goto)             (compile-%%goto         e env tail?))

            ;; Standard call (first is not in lexical env)
            (else                 (compile-call           e env tail?)))))))

     ;; ---- We have a symbol
     ((symbol? e)
      (compile-reference e env epair tail?))

     ;; Self evaluating object
     (else
      (compile-constant  e env tail?)))))


;=============================================================================
;
; Eval
;
;=============================================================================

(define (eval e :optional env)

  (define (parse-expression e)
    (compile e #f e #f)
    (emit 'END-OF-CODE)
    (assemble (reverse! *code-instr*)))

  (fluid-let ((*code-instr*     '())
              (*code-constants* '()))
    (let ((code (parse-expression e)))
      ;;(disassemble-code code (current-error-port))
      (%execute code (list->vector *code-constants*) (or env (current-module))))))

(define-macro (%compile-time-define . symbs)
  ;; This macro permits to add the given symbols in the list of defined symbols
  ;; to avoid the "undefined symbol" warning messages
  `(when-compile
     ,@(map (lambda(x) `(define ,x #void)) symbs)))

)
;; ======================================================================
(select-module STklos)
(import STKLOS-COMPILER)
(define eval (in-module STKLOS-COMPILER eval))


;;)
; LocalWords:  initform autoload Autoloads
