;*=====================================================================*/
;*    serrano/prgm/project/bigloo/runtime/Eval/evmeaning.scm           */
;*    -------------------------------------------------------------    */
;*    Author      :  Manuel Serrano                                    */
;*    Creation    :  Wed Aug  4 10:48:41 1993                          */
;*    Last change :  Fri Dec 13 11:18:14 2002 (serrano)                */
;*    -------------------------------------------------------------    */
;*    L'interprete de bigloo (la version `lambda')                     */
;*=====================================================================*/
       
;*---------------------------------------------------------------------*/
;*    Le module                                                        */
;*---------------------------------------------------------------------*/
(module __evmeaning
   
   (include "Eval/byte-code.sch")
   
   (import  __type
	    __error
	    __bigloo
	    __tvector
	    __structure
	    __tvector
	    __bexit
	    __os
	    
	    __r4_numbers_6_5
	    __r4_numbers_6_5_fixnum
	    __r4_numbers_6_5_flonum
	    __r4_characters_6_6
	    __r4_equivalence_6_2
	    __r4_booleans_6_1
	    __r4_symbols_6_4
	    __r4_strings_6_7
	    __r4_pairs_and_lists_6_3
	    __r4_input_6_10_2
	    __r4_control_features_6_9
	    __r4_vectors_6_8
	    __r4_ports_6_10_1
	    __r4_output_6_10_3
	    
	    __progn
	    __evenv
	    __evcompile)
   
   (static  (update-eval-global! variable value))
   
   (export  (evmeaning exp env)
	    (evmeaning-reset-error!)
	    (evmeaning-notify-error proc mes obj)
	    (evmeaning-location))
   
   (extern  (%funcall-0::obj  (::procedure)
			      "eval_funcall_0")
	    (%funcall-1::obj  (::procedure ::obj)
			      "eval_funcall_1")
	    (%funcall-2::obj  (::procedure ::obj ::obj)
			      "eval_funcall_2")
	    (%funcall-3::obj  (::procedure ::obj ::obj ::obj)
			      "eval_funcall_3")
	    (%funcall-4::obj  (::procedure ::obj ::obj ::obj ::obj)
			      "eval_funcall_4")
	    (%eval-apply::obj (::procedure ::obj)
			      "eval_apply"))
   
   (java    (class foreign
	       (method static %funcall-0::obj (::procedure)
		       "eval_funcall_0")
	       (method static %funcall-1::obj (::procedure ::obj)
		       "eval_funcall_1")
	       (method static %funcall-2::obj (::procedure ::obj ::obj)
		       "eval_funcall_2")
	       (method static %funcall-3::obj (::procedure ::obj ::obj ::obj)
		       "eval_funcall_3")
	       (method static %funcall-4::obj (::procedure ::obj ::obj ::obj ::obj)
		       "eval_funcall_4")
	       (method static %eval-apply::obj (::procedure ::obj)
		       "eval_apply"))))

;*---------------------------------------------------------------------*/
;*    evmeaning ...                                                    */
;*---------------------------------------------------------------------*/
(define (evmeaning exp stack)
   (if (byte-code? exp)
       (begin
	  (set! *current-bcode* exp)
	  (case (code-of-byte-code exp)
	     ;; les erreurs
	     ((-2)
	      (evmeaning-error exp
			       (car (value-of-byte-code exp))
			       (cadr (value-of-byte-code exp))
			       (caddr (value-of-byte-code exp))))
	     ;; La seule constante qui nessecite un codage: les `vecteurs'
	     ((-1)  
	      (value-of-byte-code exp))
	     ;; la premiere variable locale
	     ((0)   
	      (car stack))
	     ;; la deuxieme variable locale
	     ((1)   
	      (cadr stack))
	     ;; la troisieme variable locale
	     ((2)   
	      (caddr stack))
	     ;; la quatrieme variable locale
	     ((3)   
	      (cadddr stack))
	     ;; les variables locales plus profondes
	     ((4)   
	      (let ((offset (value-of-byte-code exp)))
		 (do ((i 4 (+fx i 1))
		      (env (cddddr stack) (cdr env)))
		       ((=fx i offset) (car env)))))
	     ;; la reference d'une variable globale mutable
	     ((5)
	      (__evmeaning_address-ref
	       (eval-global-value (value-of-byte-code exp))))
	     ;; la reference d'une variable globale non mutable
	     ((6)
	      (eval-global-value (value-of-byte-code exp)))
	     ;; la reference a une variable par encore definie
	     ((7)
	      (let* ((name   (value-of-byte-code exp))
		     (global (eval-lookup name)))
		 (if (eval-global? global)
		     (begin
			;; we change the value of the byte-code
			;; because, now, the variable is bound
			(byte-code-code-set!  exp 6)
			(byte-code-value-set! exp global)
			(eval-global-value global))
		     (evmeaning-error exp
				      "eval"
				      "Unbound variable"
				      name))))
	     ;; la mutation d'une variable globale
	     ((8)
	      (let ((var (car (value-of-byte-code exp)))
		    (val (evmeaning (cdr (value-of-byte-code exp)) stack)))
		 (update-eval-global! var val)
		 (unspecified)))
	     ((9)
	      (let* ((name   (car (value-of-byte-code exp)))
		     (value  (cdr (value-of-byte-code exp)))
		     (global (eval-lookup name)))
		 (if (eval-global? global)
		     (begin
			(byte-code-code-set!  exp 8)
			(byte-code-value-set! exp (cons global value))
			(evmeaning exp stack))
		     (evmeaning-error exp
				      "eval"
				      "Unbound variable"
				      name))))
	     ;; la mutation de la premiere variable locale
	     ((10)
	      (set-car! stack (evmeaning (value-of-byte-code exp) stack))
	      (unspecified))
	     ;; la mutation de la deuxieme variable locale
	     ((11)
	      (set-car! (cdr stack) (evmeaning (value-of-byte-code exp) stack))
	      (unspecified))
	     ;; la mutation de la troisieme variable locale
	     ((12)
	      (set-car! (cddr stack)
			(evmeaning (value-of-byte-code exp) stack))
	      (unspecified))
	     ;; la mutation de la quatrieme variable locale
	     ((13)
	      (set-car! (cdddr stack)
			(evmeaning (value-of-byte-code exp) stack))
	      (unspecified))
	     ;; la mutation des variables locales profondes
	     ((14)
	      (let ((offset (car (value-of-byte-code exp)))
		    (value  (evmeaning (cdr (value-of-byte-code exp)) stack)))
		 (do ((i 4 (+fx i 1))
		      (env (cddddr stack) (cdr env)))
		       ((=fx i offset) (set-car! env value)))
		 (unspecified)))
	     ;; la conditionnelle
	     ((15) 
	      (let ((value (value-of-byte-code exp)))
		 (if (evmeaning (vector-ref value 0) stack)
		     (evmeaning (vector-ref value 1) stack)
		     (evmeaning (vector-ref value 2) stack))))
	     ;; la sequence
	     ((16)
	      (let* ((exps (value-of-byte-code exp))
		     (len  (-fx (vector-length exps) 1)))
		 (if (=fx len 0)
		     #unspecified
		     (let loop ((i 0))
			(if (=fx i len)
			    (evmeaning (vector-ref exps i) stack)
			    (begin
			       (evmeaning (vector-ref exps i) stack)
			       (loop (+fx i 1))))))))
	     ;; la forme define (globale) lambda
	     ((17)
	      (let ((var (car (value-of-byte-code exp)))
		    (val (cdr (value-of-byte-code exp))))
		 (let ((cell (eval-lookup var)))
		    (if (eval-global? cell)
			(begin
			   (evmeaning-warning exp
					      "eval"
					      #\Newline
					      "redefinition of variable -- "
					      var)
			   (update-eval-global! cell
						(evmeaning (force val) '())))
			(let ((cell (vector 0 var (unspecified))))
			   (bind-eval-global! var cell)
			   ;; on le fait en deux fois pour etre
			   ;; sur que la liaison existe.
			   (let ((value (evmeaning (force val) '())))
			      (set-eval-global-value! cell value))))
		    var)))
	     ;; la forme define (globale) value
	     ((63)
	      (let* ((var   (car (value-of-byte-code exp)))
		     (val   (cdr (value-of-byte-code exp)))
		     (value (evmeaning val '())))
		 (let ((cell (eval-lookup var)))
		    (if (eval-global? cell)
			(begin
			   (evmeaning-warning exp
					      "eval"
					      #\Newline
					      "redefinition of variable -- "
					      var)
			   (update-eval-global! cell value))
			(let ((cell (vector 0 var (unspecified))))
			   (bind-eval-global! var cell)
			   ;; on le fait en deux fois pour etre
			   ;; sur que la liaison existe.
			   (set-eval-global-value! cell value)))
		    var)))
	     ;; bind-exit
	     ((18)
	      (bind-exit (__dummy__)
		 ((evmeaning (value-of-byte-code exp) stack)
		  __dummy__)))
	     ;; unwind-protect
	     ((64)
	      (let ((body    (car (value-of-byte-code exp)))
		    (protect (cdr (value-of-byte-code exp))))
		 (unwind-protect (evmeaning body stack)
				 (evmeaning protect stack))))
	     ;; l'appel de fonction d'arite 0
	     ((19)
	      (let* ((value (value-of-byte-code exp))
		     (name  (vector-ref value 0))
		     (fun   (__evmeaning_address-ref (eval-global-value
						      (vector-ref value 1)))))
		 (funcall-0 name fun)))
	     ((57)
	      (let* ((value (value-of-byte-code exp))
		     (name  (vector-ref value 0))
		     (fun   (eval-global-value (vector-ref value 1))))
		 (funcall-0 name fun)))
	     ;; l'appel de fonction d'arite 1
	     ((20)
	      (let* ((value (value-of-byte-code exp))
		     (name  (vector-ref value 0))
		     (fun   (__evmeaning_address-ref (eval-global-value
						      (vector-ref value 1))))
		     (a0    (evmeaning (vector-ref value 2) stack)))
		 (set! *current-bcode* exp)
		 (funcall-1 name fun a0)))
	     ((58)
	      (let* ((value (value-of-byte-code exp))
		     (name  (vector-ref value 0))
		     (fun   (eval-global-value (vector-ref value 1)))
		     (a0    (evmeaning (vector-ref value 2) stack)))
		 (set! *current-bcode* exp)
		 (funcall-1 name fun a0)))
	     ;; l'appel de fonction d'arite 2
	     ((21)
	      (let* ((value (value-of-byte-code exp))
		     (name  (vector-ref value 0))
		     (fun   (__evmeaning_address-ref (eval-global-value
						      (vector-ref value 1))))
		     (a0    (evmeaning (vector-ref value 2) stack))
		     (a1    (evmeaning (vector-ref value 3) stack)))
		 (set! *current-bcode* exp)
		 (funcall-2 name fun a0 a1)))
	     ((59)
	      (let* ((value (value-of-byte-code exp))
		     (name  (vector-ref value 0))
		     (fun   (eval-global-value (vector-ref value 1)))
		     (a0    (evmeaning (vector-ref value 2) stack))
		     (a1    (evmeaning (vector-ref value 3) stack)))
		 (set! *current-bcode* exp)
		 (funcall-2 name fun a0 a1)))
	     ;; l'appel de fonction d'arite 3
	     ((22)
	      (let* ((value (value-of-byte-code exp))
		     (name  (vector-ref value 0))
		     (fun   (__evmeaning_address-ref (eval-global-value
						      (vector-ref value 1))))
		     (a0    (evmeaning (vector-ref value 2) stack))
		     (a1    (evmeaning (vector-ref value 3) stack))
		     (a2    (evmeaning (vector-ref value 4) stack)))
		 (set! *current-bcode* exp)
		 (funcall-3 name fun a0 a1 a2)))
	     ((60)
	      (let* ((value (value-of-byte-code exp))
		     (name  (vector-ref value 0))
		     (fun   (eval-global-value (vector-ref value 1)))
		     (a0    (evmeaning (vector-ref value 2) stack))
		     (a1    (evmeaning (vector-ref value 3) stack))
		     (a2    (evmeaning (vector-ref value 4) stack)))
		 (set! *current-bcode* exp)
		 (funcall-3 name fun a0 a1 a2)))
	     ;; l'appel de fonction d'arite 4
	     ((23)
	      (let* ((value (value-of-byte-code exp))
		     (name  (vector-ref value 0))
		     (fun   (__evmeaning_address-ref (eval-global-value
						      (vector-ref value 1))))
		     (a0    (evmeaning (vector-ref value 2) stack))
		     (a1    (evmeaning (vector-ref value 3) stack))
		     (a2    (evmeaning (vector-ref value 4) stack))
		     (a3    (evmeaning (vector-ref value 5) stack)))
		 (set! *current-bcode* exp)
		 (funcall-4 name fun a0 a1 a2 a3)))
	     ((61)
	      (let* ((value (value-of-byte-code exp))
		     (name  (vector-ref value 0))
		     (fun   (eval-global-value (vector-ref value 1)))
		     (a0    (evmeaning (vector-ref value 2) stack))
		     (a1    (evmeaning (vector-ref value 3) stack))
		     (a2    (evmeaning (vector-ref value 4) stack))
		     (a3    (evmeaning (vector-ref value 5) stack)))
		 (set! *current-bcode* exp)
		 (funcall-4 name fun a0 a1 a2 a3)))
	     ;; l'appel de fonction de plus de quatres arguments
	     ((24)
	      (let* ((value (value-of-byte-code exp))
		     (name  (vector-ref value 0))
		     (fun   (__evmeaning_address-ref (eval-global-value
						      (vector-ref value 1))))
		     (args  (vector-ref value 2))
		     (eargs (let loop ((args args)
				       (res  '())
				       (len   0))
			       (if (null? args)
				   (cons len (reverse! res))
				   (loop (cdr args)
					 (cons (evmeaning (car args) stack)
					       res)
					 (+fx 1 len))))))
		 (set! *current-bcode* exp)
		 (eval-apply name fun eargs)))
	     ((62)
	      (let* ((value (value-of-byte-code exp))
		     (name  (vector-ref value 0))
		     (fun   (eval-global-value (vector-ref value 1)))
		     (args  (vector-ref value 2))
		     (eargs (let loop ((args args)
					(res  '())
					(len   0))
				(if (null? args)
				    (cons len (reverse! res))
				    (loop (cdr args)
					  (cons (evmeaning (car args) stack)
						res)
					  (+fx len 1))))))
		 (set! *current-bcode* exp)
		 (eval-apply name fun eargs)))
	     ;; l'appel de fonction de compilee anonyme d'arite 0
	     ((25)
	      ((value-of-byte-code exp)))
	     ;; l'appel de fonction de compilee anonyme d'arite 1
	     ((26)
	      (let* ((value (value-of-byte-code exp))
		     (fun   (vector-ref value 0)))
		 (set! *current-bcode* exp)
		 (fun (evmeaning (vector-ref value 1) stack))))
	     ;; l'appel de fonction de compilee anonyme d'arite 2
	     ((27)
	      (let* ((value (value-of-byte-code exp))
		     (fun   (vector-ref value 0))
		     (a0    (evmeaning (vector-ref value 1) stack))
		     (a1    (evmeaning (vector-ref value 2) stack)))
		 (set! *current-bcode* exp)
		 (fun a0 a1)))
	     ;; l'appel de fonction de compilee anonyme d'arite 3
	     ((28)
	      (let* ((value (value-of-byte-code exp))
		     (fun   (vector-ref value 0))
		     (a0    (evmeaning (vector-ref value 1) stack))
		     (a1    (evmeaning (vector-ref value 2) stack))
		     (a2    (evmeaning (vector-ref value 3) stack)))
		 (set! *current-bcode* exp)
		 (fun a0 a1 a2)))
	     ;; l'appel de fonction de compilee anonyme d'arite 4
	     ((29)
	      (let* ((value (value-of-byte-code exp))
		     (fun   (vector-ref value 0))
		     (a0    (evmeaning (vector-ref value 1) stack))
		     (a1    (evmeaning (vector-ref value 2) stack))
		     (a2    (evmeaning (vector-ref value 3) stack))
		     (a3    (evmeaning (vector-ref value 4) stack)))
		 (set! *current-bcode* exp)
		 (fun a0 a1 a2 a3)))
	     ;; l'appel de fonction de compilee anonyme d'arite plus que 4
	     ((30)
	      (let* ((value (value-of-byte-code exp))
		     (eargs (map (lambda (x)
				    (evmeaning x stack))
				 (cdr value))))
		 (set! *current-bcode* exp)
		 (apply (car value) eargs)))
	     ;; l'application classique d'arite 0
	     ((31)
	      (let* ((value (value-of-byte-code exp))
		     (name  (car value))
		     (fun   (evmeaning (cdr value) stack)))
		 (funcall-0 name fun)))
	     ;; l'application classique d'arite 1
	     ((32)
	      (let* ((value (value-of-byte-code exp))
		     (name  (vector-ref value 0))
		     (fun   (evmeaning (vector-ref value 1) stack))
		     (a0    (evmeaning (vector-ref value 2) stack)))
		 (set! *current-bcode* exp)
		 (funcall-1 name fun a0)))
	     ;; l'application classique d'arite 2
	     ((33)
	      (let* ((value (value-of-byte-code exp))
		     (name  (vector-ref value 0))
		     (fun   (evmeaning (vector-ref value 1) stack))
		     (a0    (evmeaning (vector-ref value 2) stack))
		     (a1    (evmeaning (vector-ref value 3) stack)))
		 (set! *current-bcode* exp)
		 (funcall-2 name fun a0 a1)))
	     ;; l'application classique d'arite 3
	     ((34)
	      (let* ((value (value-of-byte-code exp))
		     (name  (vector-ref value 0))
		     (fun   (evmeaning (vector-ref value 1) stack))
		     (a0    (evmeaning (vector-ref value 2) stack))
		     (a1    (evmeaning (vector-ref value 3) stack))
		     (a2    (evmeaning (vector-ref value 4) stack)))
		 (set! *current-bcode* exp)
		 (funcall-3 name fun a0 a1 a2)))
	     ;; l'application classique d'arite 4
	     ((35)
	      (let* ((value (value-of-byte-code exp))
		     (name  (vector-ref value 0))
		     (fun   (evmeaning (vector-ref value 1) stack))
		     (a0    (evmeaning (vector-ref value 2) stack))
		     (a1    (evmeaning (vector-ref value 3) stack))
		     (a2    (evmeaning (vector-ref value 4) stack))
		     (a3    (evmeaning (vector-ref value 5) stack)))
		 (set! *current-bcode* exp)
		 (funcall-4 name fun a0 a1 a2 a3)))
	     ;; l'application classique de plus de 4 arguments
	     ((36)
	      (let* ((value (value-of-byte-code exp))
		     (name  (vector-ref value 0))
		     (fun   (evmeaning (vector-ref value 1) stack))
		     (eargs (let loop ((args (vector-ref value 2))
				       (new '())
				       (len 0))
			       (if (null? args)
				   (cons len (reverse! new))
				   (loop (cdr args)
					 (cons (evmeaning (car args) stack)
					       new)
					 (+fx 1 len))))))
		 (set! *current-bcode* exp)
		 (eval-apply name fun eargs)))
	     ;; les lambda tracees d'arite 0
	     ((37)
	      (let* ((value (value-of-byte-code exp))
		     (where (car value))
		     (body  (cdr value)))
		 (lambda ()
		    (let ((where where))
		       (let ()
			  ;; dont try to change something to this code
			  ;; in particular don't remove the binding
			  ;; (where where) nor the side effect
			  ;; (set! where where), they are use to allow
			  ;; the compilation of this handly introduced
			  ;; push-trace form (the same hack is used everywhere
			  ;; in this module).
	 		  (c-push-trace where)
			  (set! where where)
			  (let ((res (evmeaning body stack)))
			     (c-pop-trace)
			     res))))))
	     ;; les lambda tracees d'arite 1
	     ((38)
	      (let* ((value (value-of-byte-code exp))
		     (where (car value))
		     (body  (cdr value)))
		 (lambda (x)
		    (let ((where where))
		       (let ()
			  (c-push-trace where)
			  (set! where where)
			  (let ((res (evmeaning body (cons x stack))))
			     (c-pop-trace)
			     res))))))
	     ;; les lambda tracees d'arite 2
	     ((39)
	      (let* ((value (value-of-byte-code exp))
		     (where (car value))
		     (body  (cdr value)))
		 (lambda (x y)
		    (let ((where where))
		       (let ()
			  (c-push-trace where)
			  (set! where where)
			  (let ((res (evmeaning body (cons x (cons y stack)))))
			     (c-pop-trace)
			     res))))))
	     ;; les lambda tracees d'arite 3
	     ((40)
	      (let* ((value (value-of-byte-code exp))
		     (where (car value))
		     (body  (cdr value)))
		 (lambda (x y z)
		    (let ((where where))
		       (let ()
			  (c-push-trace where)
			  (set! where where)
			  (let ((res (evmeaning body
						(cons x
						      (cons y
							    (cons z stack))))))
			     (c-pop-trace)
			     res))))))
	     ;; les lambda tracees d'arite 4
	     ((41)
	      (let* ((value (value-of-byte-code exp))
		     (where (car value))
		     (body  (cdr value)))
		 (lambda (x y z t)
		    (let ((where where))
		       (let ()
			  (c-push-trace where)
			  (set! where where)
			  (let ((res (evmeaning
				      body
				      (cons x
					    (cons y
						  (cons z
							(cons t
							      stack)))))))
			     (c-pop-trace)
			     res))))))
	     ;; les lambda non tracees d'arite 0
	     ((42)
	      (lambda ()
		 (evmeaning (value-of-byte-code exp)
			    stack)))
	     ;; les lambda non tracees d'arite 1
	     ((43)
	      (lambda (x)
		 (evmeaning (value-of-byte-code exp)
			    (cons x stack))))
	     ;; les lambda non tracees d'arite 2
	     ((44)
	      (lambda (x y)
		 (evmeaning (value-of-byte-code exp)
			    (cons x (cons y stack)))))
	     ;; les lambda non tracees d'arite 3
	     ((45)
	      (lambda (x y z)
		 (evmeaning (value-of-byte-code exp)
			    (cons x (cons y (cons z stack))))))
	     ;; les lambda non tracees d'arite 4
	     ((46)
	      (lambda (x y z t)
		 (evmeaning (value-of-byte-code exp)
			    (cons x (cons y (cons z (cons t stack)))))))
	     ;; les lambda tracees d'arite -1
	     ((47)
	      (let* ((value (value-of-byte-code exp))
		     (where (car value))
		     (body  (cdr value)))
		 (lambda x
		    (let ((where where))
		       (let ()
			  (c-push-trace where)
			  (set! where where)
			  (let ((res (evmeaning body (cons x stack))))
			     (c-pop-trace)
			     res))))))
	     ;; les lambda tracees d'arite -2
	     ((48)
	      (let* ((value (value-of-byte-code exp))
		     (where (car value))
		     (body  (cdr value)))
		 (lambda (x . y)
		    (let ((where where))
		       (let ()
			  (c-push-trace where)
			  (set! where where)
			  (let ((res (evmeaning body (cons x (cons y stack)))))
			     (c-pop-trace)
			     res))))))
	     ;; les lambda tracees d'arite -3
	     ((49)
	      (let* ((value (value-of-byte-code exp))
		     (where (car value))
		     (body  (cdr value)))
		 (lambda (x y . z)
		    (let ((where where))
		       (let ()
			  (c-push-trace where)
			  (set! where where)
			  (let ((res (evmeaning body
						(cons x
						      (cons y
							    (cons z stack))))))
			     (c-pop-trace)
			     res))))))
	     ;; les lambda tracees d'arite -4
	     ((50)
	      (let* ((value (value-of-byte-code exp))
		     (where (car value))
		     (body  (cdr value)))
		 (lambda (x y z . t)
		    (let ((where where))
		       (let ()
			  (c-push-trace where)
			  (set! where where)
			  (let ((res (evmeaning
				      body
				      (cons x
					    (cons y
						  (cons z
							(cons t
							      stack)))))))
			     (c-pop-trace)
			     res))))))
	     ;; les lambda non tracees d'arite -1
	     ((51)
	      (lambda x
		 (evmeaning (value-of-byte-code exp)
			    (cons x stack))))
	     ;; les lambda non tracees d'arite -2
	     ((52)
	      (lambda (x . y)
		 (evmeaning (value-of-byte-code exp)
			    (cons x (cons y stack)))))
	     ;; les lambda non tracees d'arite -3
	     ((53)
	      (lambda (x y . z)
		 (evmeaning (value-of-byte-code exp)
			    (cons x (cons y (cons z stack))))))
	     ;; les lambda non tracees d'arite -4
	     ((54)
	      (lambda (x y z . t)
		 (evmeaning (value-of-byte-code exp)
			    (cons x (cons y (cons z (cons t stack)))))))
	     ;; les lambdas de plus de 4 arguments tracees
	     ((55)
	      (let* ((value   (value-of-byte-code exp))
		     (where   (vector-ref value 0))
		     (body    (vector-ref value 1))
		     (formals (vector-ref value 2)))
		 (lambda x
		    (let ((where where))
		       (let ()
			  (c-push-trace where)
			  (set! where where)
			  (let ((new-env (let _loop_ ((actuals x)
						      (formals formals))
					    (cond
					       ((null? formals)
						(if (not (null? actuals))
						    (evmeaning-error
						     exp
						     "eval"
						     "Too many arguments provided"
						     actuals)
						    stack))
					       ((not (pair? formals))
						(cons actuals stack))
					       ((null? actuals)
						(evmeaning-error
						 exp
						 "eval"
						 "Too few arguments provided"
						 formals))
					       (else
						(cons (car actuals)
						      (_loop_ (cdr actuals)
							      (cdr formals))))))))
			     (let ((res (evmeaning body new-env)))
				(c-pop-trace)
				res)))))))
	     ;; les lambdas de plus de 4 arguments non tracees
	     ((56)
	      (let* ((value   (value-of-byte-code exp))
		     (body    (car value))
		     (formals (cdr value)))
		 (lambda x
		    (let ((new-env (let _loop_ ((actuals x)
						(formals formals))
				      (cond
					 ((null? formals)
					  (if (not (null? actuals))
			 		      (evmeaning-error
					       exp
					       "eval"
					       "Too many arguments provided"
					       actuals)
					      stack))
					 ((not (pair? formals))
					  (cons actuals stack))
					 ((null? actuals)
					  (evmeaning-error
					   exp
					   "eval"
					   "Too few arguments provided"
					   formals))
					 (else
					  (cons (car actuals)
						(_loop_ (cdr actuals)
							(cdr formals))))))))
		       (evmeaning body new-env)))))
	     ;; ah non, c'est une erreur
	     (else
	      (evmeaning-error exp
			       "evmeaning (internal error)"
			       "unknown byte-code"
			       exp))))
       exp))

;*---------------------------------------------------------------------*/
;*    evmeaning-error ...                                              */
;*---------------------------------------------------------------------*/
(define (evmeaning-error bcode proc mes obj)
   (if (byte-code? bcode)
       (match-case (pos-of-byte-code bcode)
	  ((at ?fname ?loc ?line)
	   (error/location proc mes obj fname loc))
	  (else
	   (error proc mes obj)))
       (error proc mes obj)))

;*---------------------------------------------------------------------*/
;*    evmeaning-warning ...                                            */
;*---------------------------------------------------------------------*/
(define (evmeaning-warning bcode . args)
   (if (byte-code? bcode)
       (match-case (pos-of-byte-code bcode)
	  ((at ?fname ?loc ?line)
	   (apply warning/location `(,fname ,loc ,@args)))
	  (else
	   (apply warning args)))
       (apply warning args)))

;*---------------------------------------------------------------------*/
;*    evmeaning-notify-error ...                                       */
;*---------------------------------------------------------------------*/
(define (evmeaning-notify-error proc mes obj)
   (define (byte-code-error)
      (if (byte-code? *current-bcode*)
	  (match-case (pos-of-byte-code *current-bcode*)
	     ((at ?fname ?loc ?line)
	      (set! *current-bcode* #f)
	      (let ((err (error/location-file fname loc)))
		 (if (procedure? err)
		     (err proc mes obj)
		     (notify-error proc mes obj))))
	     (else
	      (notify-error proc mes obj)))
	  (notify-error proc mes obj)))
   (if (epair? obj)
       (match-case (cer obj)
	  ((at ?fname ?loc ?line)
	   (set! *current-bcode* #f)
	   (let ((err (error/location-file fname loc)))
	      (if (procedure? err)
		  (err proc mes obj)
		  (notify-error proc mes obj))))
	  (else
	   (byte-code-error)))
       (byte-code-error)))

;*---------------------------------------------------------------------*/
;*    evmeaning-location ...                                           */
;*---------------------------------------------------------------------*/
(define (evmeaning-location)
   (if (byte-code? *current-bcode*)
       (let ((p (pos-of-byte-code *current-bcode*)))
	  (match-case p
	     ((at ?fname ?loc ?line)
	      p)
	     (else
	      #f)))
       #f))
   
;*---------------------------------------------------------------------*/
;*    evmeaning-reset-error! ...                                       */
;*---------------------------------------------------------------------*/
(define (evmeaning-reset-error!)
   (set! *current-bcode* #f))
   
;*---------------------------------------------------------------------*/
;*      update-eval-global! ...                                        */
;*---------------------------------------------------------------------*/
(define (update-eval-global! variable value)
   (if (eq? (eval-global-tag variable) 1)
       (__evmeaning_address-set! (eval-global-value variable) value)
       (set-eval-global-value! variable value))
   (eval-global-name variable))

;*---------------------------------------------------------------------*/
;*    *current-bcode* ...                                              */
;*---------------------------------------------------------------------*/
(define *current-bcode* #f)

;*---------------------------------------------------------------------*/
;*    funcall-0 ...                                                    */
;*---------------------------------------------------------------------*/
(define-inline (funcall-0 name fun)
   (cond
      ((not (procedure? fun))
       (error "eval" "Not a procedure" name))
      ((not (correct-arity? fun 0))
       (error "eval" "Wrong number of argument" name))
      (else
       (%funcall-0 fun))))

;*---------------------------------------------------------------------*/
;*    funcall-1 ...                                                    */
;*---------------------------------------------------------------------*/
(define-inline (funcall-1 name fun a0)
   (cond
      ((not (procedure? fun))
       (error "eval" "Not a procedure" name))
      ((not (correct-arity? fun 1))
       (error "eval" "Wrong number of argument" name))
      (else
       (%funcall-1 fun a0))))

;*---------------------------------------------------------------------*/
;*    funcall-2 ...                                                    */
;*---------------------------------------------------------------------*/
(define-inline (funcall-2 name fun a0 a1)
   (cond
      ((not (procedure? fun))
       (error "eval" "Not a procedure" name))
      ((not (correct-arity? fun 2))
       (error "eval" "Wrong number of argument" name))
      (else
       (%funcall-2 fun a0 a1))))

;*---------------------------------------------------------------------*/
;*    funcall-3 ...                                                    */
;*---------------------------------------------------------------------*/
(define-inline (funcall-3 name fun a0 a1 a2)
   (cond
      ((not (procedure? fun))
       (error "eval" "Not a procedure" name))
      ((not (correct-arity? fun 3))
       (error "eval" "Wrong number of argument" name))
      (else
       (%funcall-3 fun a0 a1 a2))))

;*---------------------------------------------------------------------*/
;*    funcall-4 ...                                                    */
;*---------------------------------------------------------------------*/
(define-inline (funcall-4 name fun a0 a1 a2 a3)
   (cond
      ((not (procedure? fun))
       (error "eval" "Not a procedure" name))
      ((not (correct-arity? fun 4))
       (error "eval" "Wrong number of argument" name))
      (else
       (%funcall-4 fun a0 a1 a2 a3))))

;*---------------------------------------------------------------------*/
;*    eval-apply ...                                                   */
;*---------------------------------------------------------------------*/
(define-inline (eval-apply name fun len.lst)
   (cond
      ((not (procedure? fun))
       (error "apply" "Not a procedure" name))
      ((not (correct-arity? fun (car len.lst)))
       (error "eval" "Wrong number of argument" name))
      (else
       (%eval-apply fun (cdr len.lst)))))
       
;*---------------------------------------------------------------------*/
;*    Les environments ...                                             */
;*---------------------------------------------------------------------*/
(init-the-global-environment!)
       

