;*=====================================================================*/
;*    serrano/prgm/project/bigloo/runtime/Eval/evcompile.scm           */
;*    -------------------------------------------------------------    */
;*    Author      :  Manuel Serrano                                    */
;*    Creation    :  Fri Mar 25 09:09:18 1994                          */
;*    Last change :  Wed Jul 23 12:12:02 2003 (serrano)                */
;*    -------------------------------------------------------------    */
;*    La pre-compilation des formes pour permettre l'interpretation    */
;*    rapide                                                           */
;*=====================================================================*/

;*---------------------------------------------------------------------*/
;*    Le module                                                        */
;*---------------------------------------------------------------------*/
(module __evcompile
   (include "Eval/byte-code.sch")
   
   (import  __type
	    __error
	    __bigloo
	    __tvector
	    __structure
	    __tvector
	    __bexit
	    __os
	    __dsssl
	    
	    __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

   	    __evenv
	    __eval
	    __expand)
   
   (export  (evcompile exp env Genv where named? loc)
	    (find-loc  exp default)))

;*---------------------------------------------------------------------*/
;*    find-loc ...                                                     */
;*---------------------------------------------------------------------*/
(define (find-loc exp default)
   (if (epair? exp)
       (cer exp)
       default))

;*---------------------------------------------------------------------*/
;*    untype-ident ...                                                 */
;*---------------------------------------------------------------------*/
(define (untype-ident id)
   (if (not (symbol? id))
       id
       (let* ((string (symbol->string id))
	      (len    (string-length string)))
	  (let loop ((walker  0))
	     (cond
		((=fx walker len)
		 id)
		((and (char=? (string-ref string walker) #\:)
		      (<fx walker (-fx len 1))
		      (char=? (string-ref string (+fx walker 1)) #\:))
		 (string->symbol (substring string 0 walker)))
		(else
		 (loop (+fx walker 1))))))))

;*---------------------------------------------------------------------*/
;*    untype-ident* ...                                                */
;*---------------------------------------------------------------------*/
(define (untype-ident* idents)
   (cond
      ((null? idents)
       '())
      ((pair? idents)
       (cons (untype-ident (car idents)) (untype-ident* (cdr idents))))
      (else
       (untype-ident idents))))

;*---------------------------------------------------------------------*/
;*    evcompile ...                                                    */
;*    -------------------------------------------------------------    */
;*    La phase d'expansion a genere une syntaxe correcte. On n'a donc  */
;*    plus du tout a la tester maintenant.                             */
;*---------------------------------------------------------------------*/
(define (evcompile exp env genv where named? loc)
   (match-case exp
      (()
       (evcompile-error loc "eval" "Illegal expression" '()))
      ((module ?- . ?decls)
       (module-declaration! decls)
       (unspecified))
      ((assert . ?-)
       (unspecified))
      ((atom ?atom)
       (cond
	  ((symbol? atom)
	   (evcompile-ref (variable loc atom env genv) loc))
	  ((or (vector? atom)
	       (struct? atom))
	   (evcompile-error loc
			    "eval"
			    "Illegal expression (should be quoted)"
			    exp))
	  (else
	   (evcompile-cnst atom loc))))
      ((quote ?cnst)
       (evcompile-cnst cnst (find-loc exp loc)))
      ((if ?si ?alors ?sinon)
       (let ((loc (find-loc exp loc)))
	  (evcompile-if (evcompile si env genv
				   where #f (find-loc si loc))
			(evcompile alors env genv
				   where named? (find-loc alors loc))
			(evcompile sinon env genv
				   where named? (find-loc sinon loc))
			loc)))
      ((begin . ?rest)
       (evcompile-begin rest env genv where named? (find-loc exp loc)))
      ((or (define ?var (and (lambda . ?-) ?val))
	   (define ?var (begin (and (lambda . ?-) ?val))))
       (if (and (eq? where 'nowhere)
		(or (eq? genv (scheme-report-environment 5))
		    (eq? genv (null-environment 5))))
	   (evcompile-error loc
			    "eval"
			    "Illegal define form (sealed environment)"
			    exp)
	   (let ((loc (find-loc exp loc)))
	      (evcompile-define-lambda (untype-ident var)
				       (delay (evcompile val '() genv var #t
							 (find-loc exp loc)))
				       loc))))
      ((define ?var ?val)
       (if (and (eq? where 'nowhere)
		(or (eq? genv (scheme-report-environment 5))
		    (eq? genv (null-environment 5))))
	   (evcompile-error loc
			    "eval"
			    "Illegal define form (sealed environment)"
			    exp)
	   (let ((loc (find-loc exp loc)))
	      (evcompile-define-value (untype-ident var)
				      (evcompile val '() genv where named?
						 (find-loc val loc))
				      loc))))
      ((set! . ?-)
       (match-case exp
	  ((?- (and (? symbol?) ?var) ?val)
	   (let ((loc (find-loc exp loc)))
	      (evcompile-set (variable loc var env genv)
			     (evcompile val env genv var #t (find-loc val loc))
			     loc)))
	  (else
	   (error "set!" "Illegal form" exp))))
      ((bind-exit ?escape ?body)
       (let ((loc (find-loc exp loc)))
	  (evcompile-bind-exit (evcompile `(lambda ,escape ,body)
					  env
					  genv
					  escape
					  #t
					  (find-loc body loc))
			       loc)))
      ((unwind-protect ?body . ?protect)
       (let ((loc (find-loc exp loc)))
	  (evcompile-unwind-protect (evcompile body env genv where named?
					       (find-loc body loc))
				    (evcompile-begin protect env genv
						     where named?
						     (find-loc protect loc))
				    loc)))
      ((lambda ?formals ?body)
       (let* ((loc         (find-loc exp loc))
	      (scm-formals (dsssl-formals->scheme-formals
			    formals
			    (lambda (proc msg obj)
			       (evcompile-error loc proc msg obj))))
	      (untyped-scm-formals (untype-ident* scm-formals)))
	  (evcompile-lambda untyped-scm-formals
			    (evcompile (expand
					(make-dsssl-function-prelude
					 exp
					 formals
					 body
					 (lambda (proc msg obj)
					    (evcompile-error loc
							     proc
							     msg
							     obj))))
				       (extend-env untyped-scm-formals env)
				       genv
				       where #f
				       (find-loc body loc))
			    where
			    named? loc)))
      (((atom ?fun) . ?args)
       (let* ((loc     (find-loc exp loc))
	      (actuals (map (lambda (a) (evcompile a env genv where #f loc))
			    args)))
	  (cond
	     ((symbol? fun)
	      (let ((proc (variable loc fun env genv)))
		 (cond
		    ((eval-global? proc)
		     (evcompile-global-application proc actuals loc))
		    (else
		     (evcompile-application fun
					    (evcompile-ref proc loc)
					    actuals
					    loc)))))
	     ((procedure? fun)
	      (evcompile-compiled-application fun actuals loc))
	     (else
	      (evcompile-error loc "eval" "Not a procedure" fun)
	      (make-byte-code -2
			      loc
			      (list "eval" "Not a procedure" fun))))))
      ((?fun . ?args)
       (let ((loc     (find-loc exp loc))
	     (actuals (map (lambda (a) (evcompile a env genv where #f loc))
			   args))
	     (proc    (evcompile fun env genv where #f loc)))
	  (evcompile-application fun proc actuals loc)))
      (else
       (evcompile-error loc "eval" "Illegal form" exp))))

;*---------------------------------------------------------------------*/
;*    evcompile-cnst ...                                               */
;*---------------------------------------------------------------------*/
(define (evcompile-cnst cnst loc)
   (cond
      ((vector? cnst)
       (make-byte-code -1 loc cnst))
      (else
       cnst)))

;*---------------------------------------------------------------------*/
;*    evcompile-ref ...                                                */
;*---------------------------------------------------------------------*/
(define (evcompile-ref variable loc)
   (cond
      ((eval-global? variable)
       (make-byte-code (if (eq? (eval-global-tag variable) 1) 5 6)
		       loc
		       variable))
      ((dynamic? variable)
       (make-byte-code 7 loc (dynamic-name variable)))
      (else
       (case variable
	  ((0 1 2 3)
	   (make-byte-code variable loc '()))
	  (else
	   (make-byte-code 4 loc variable))))))

;*---------------------------------------------------------------------*/
;*    evcompile-set ...                                                */
;*---------------------------------------------------------------------*/
(define (evcompile-set variable value loc)
   (cond
      ((eval-global? variable)
       (make-byte-code 8 loc (cons variable value)))
      ((dynamic? variable)
       (make-byte-code 9 loc (cons (dynamic-name variable) value)))
      (else
       (case variable
	  ((0 1 2 3)
	   (make-byte-code (+fx 10 variable) loc value))
	  (else
	   (make-byte-code 14 loc (cons variable value)))))))

;*---------------------------------------------------------------------*/
;*    evcompile-if ...                                                 */
;*---------------------------------------------------------------------*/
(define (evcompile-if si alors sinon loc)
   (make-byte-code 15 loc (vector si alors sinon)))

;*---------------------------------------------------------------------*/
;*    evcompile-begin ...                                              */
;*---------------------------------------------------------------------*/
(define (evcompile-begin body env genv where named? loc)
   (cond
      ((null? body)
       (evcompile #unspecified env genv where named? loc))
      ((null? (cdr body))
       (evcompile (car body) env genv where named? (find-loc (car body) loc)))
      (else
       (let ((cbody (let loop ((rest body))
		       (cond
			  ((null? rest)
			   '())
			  ((null? (cdr rest))
			   (cons (evcompile (car rest) env genv where named?
					    (find-loc (car rest) loc))
				 '()))
			  (else
			   (cons (evcompile (car rest) env genv where #f
					    (find-loc (car rest) loc))
				 (loop (cdr rest))))))))
	  (make-byte-code 16 loc (list->vector cbody))))))

;*---------------------------------------------------------------------*/
;*    evcompile-define-lambda ...                                      */
;*    -------------------------------------------------------------    */
;*    Le calcul de `val' a ete differe car on ne veut evcompiler la    */
;*    valeur liee d'un define qu'une fois que la variable a ete liee   */
;*    dans l'environment. Si on ne fait pas cela on se tape que des    */
;*    appels dynamics dans les definitions des fonctions               */
;*    auto-recursives !                                                */
;*---------------------------------------------------------------------*/
(define (evcompile-define-lambda var val loc)
   (make-byte-code 17 loc (cons var val)))

;*---------------------------------------------------------------------*/
;*    evcompile-define-value ...                                       */
;*---------------------------------------------------------------------*/
(define (evcompile-define-value var val loc)
   (make-byte-code 63 loc (cons var val)))
    
;*---------------------------------------------------------------------*/
;*    evcompile-bind-exit ...                                          */
;*---------------------------------------------------------------------*/
(define (evcompile-bind-exit body loc)
   (make-byte-code 18 loc body))

;*---------------------------------------------------------------------*/
;*    evcompile-unwind-protect ...                                     */
;*---------------------------------------------------------------------*/
(define (evcompile-unwind-protect body protect loc)
   (make-byte-code 64 loc (cons body protect)))

;*---------------------------------------------------------------------*/
;*    evcompile-lambda ...                                             */
;*---------------------------------------------------------------------*/
(define (evcompile-lambda formals body where named? loc)
   (match-case formals
      ((or () (?-) (?- ?-) (?- ?- ?-) (?- ?- ?- ?-))
       (if named?
	   (make-byte-code (+fx (length formals) 37) loc (cons where body))
	   (make-byte-code (+fx (length formals) 42) loc body)))
      ((atom ?-)
       (if named?
	   (make-byte-code 47 loc (cons where body))
	   (make-byte-code 51 loc body)))
      (((atom ?-) . (atom ?-))
       (if named?
	   (make-byte-code 48 loc (cons where body))
	   (make-byte-code 52 loc body)))
      (((atom ?-) (atom ?-) . (atom ?-))
       (if named?
	   (make-byte-code 49 loc (cons where body))
	   (make-byte-code 53 loc body)))
      (((atom ?-) (atom ?-) (atom ?-) . (atom ?-))
       (if named?
	   (make-byte-code 50 loc (cons where body))
	   (make-byte-code 54 loc body)))
      (else
       (if named?
	   (make-byte-code 55 loc (vector where body formals))
	   (make-byte-code 56 loc (cons body formals))))))

;*---------------------------------------------------------------------*/
;*    evcompile-global-application ...                                 */
;*---------------------------------------------------------------------*/
(define (evcompile-global-application proc actuals loc)
   (case (length actuals)
      ((0)
       (make-byte-code (if (eq? (eval-global-tag proc) 1) 19 57)
		       loc
		       (vector (eval-global-name proc)
			       proc)))
      ((1)
       (make-byte-code (if (eq? (eval-global-tag proc) 1) 20 58)
		       loc
		       (vector (eval-global-name proc)
			       proc
			       (car actuals))))
      ((2)
       (make-byte-code (if (eq? (eval-global-tag proc) 1) 21 59)
		       loc
		       (vector (eval-global-name proc)
			       proc
			       (car actuals)
			       (cadr actuals))))
      ((3)
       (make-byte-code (if (eq? (eval-global-tag proc) 1) 22 60)
		       loc
		       (vector (eval-global-name proc)
			       proc
			       (car actuals)
			       (cadr actuals)
			       (caddr actuals))))
      ((4)
       (make-byte-code (if (eq? (eval-global-tag proc) 1) 23 61)
		       loc
		       (vector (eval-global-name proc)
			       proc
			       (car actuals)
			       (cadr actuals)
			       (caddr actuals)
			       (cadddr actuals))))
      (else
       (make-byte-code (if (eq? (eval-global-tag proc) 1) 24 62)
		       loc
		       (vector (eval-global-name proc)
			       proc
			       actuals)))))

;*---------------------------------------------------------------------*/
;*    evcompile-compiled-application ...                               */
;*---------------------------------------------------------------------*/
(define (evcompile-compiled-application proc actuals loc)
   (case (length actuals)
      ((0)
       (make-byte-code 25 loc proc))
      ((1)
       (make-byte-code 26 loc (vector proc (car actuals))))
      ((2)
       (make-byte-code 27 loc (vector proc (car actuals)
				      (cadr actuals))))
      ((3)
       (make-byte-code 28 loc (vector proc (car actuals)
				      (cadr actuals)
				      (caddr actuals))))
      ((4)
       (make-byte-code 29 loc (vector proc (car actuals)
				      (cadr actuals)
				      (caddr actuals)
				      (cadddr actuals))))
      (else
       (make-byte-code 30 loc (cons proc actuals)))))

;*---------------------------------------------------------------------*/
;*    evcompile-application ...                                        */
;*---------------------------------------------------------------------*/
(define (evcompile-application name proc actuals loc)
   (case (length actuals)
      ((0)
       (make-byte-code 31 loc (cons name proc)))
      ((1)
       (make-byte-code 32 loc (vector name proc
				      (car actuals))))
      ((2)
       (make-byte-code 33 loc (vector name proc
				      (car actuals)
				      (cadr actuals))))
      ((3)
       (make-byte-code 34 loc (vector name proc
				      (car actuals)
				      (cadr actuals)
				      (caddr actuals))))
      ((4)
       (make-byte-code 35 loc (vector name proc
				      (car actuals)
				      (cadr actuals)
				      (caddr actuals)
				      (cadddr actuals))))
      (else
       (make-byte-code 36 loc (vector name proc
				      actuals)))))

;*---------------------------------------------------------------------*/
;*    variable ...                                                     */
;*---------------------------------------------------------------------*/
(define (variable loc symbol env genv)
   (if (not (symbol? symbol))
       (evcompile-error loc "eval" "Illegal `set!' expression" symbol)
       (let ((offset (let loop ((env   env)
				(count 0))
			(cond
			   ((null? env)
			    #f)
			   ((eq? (car env) symbol)
			    count)
			   (else
			    (loop (cdr env) (+fx count 1)))))))
	  (if offset
	      offset
	      (let ((global (if (or (eq? genv (scheme-report-environment 5))
				    (eq? genv (interaction-environment)))
				(eval-lookup symbol)
				(evcompile-error loc
						 "eval"
						 "Unbound variable"
						 symbol))))
		 (if (not global)
		     (if (eq? genv (scheme-report-environment 5))
			 (evcompile-error loc
					  "eval"
					  "Unbound variable"
					  symbol)
			 (cons 'dynamic symbol))
		     global))))))

;*---------------------------------------------------------------------*/
;*    dynamic? ...                                                     */
;*---------------------------------------------------------------------*/
(define-inline (dynamic? variable)
   (and (pair? variable)
	(eq? (car variable) 'dynamic)))

;*---------------------------------------------------------------------*/
;*    dynamic-name ...                                                 */
;*---------------------------------------------------------------------*/
(define-inline (dynamic-name dynamic)
   (cdr dynamic))

;*---------------------------------------------------------------------*/
;*    extend-env ...                                                   */
;*---------------------------------------------------------------------*/
(define (extend-env extend old-env)
   (let _loop_ ((extend extend))
      (cond
	 ((null? extend)
	  old-env)
	 ((not (pair? extend))
	  (cons extend old-env))
	 (else
	  (cons (car extend) (_loop_ (cdr extend)))))))

;*---------------------------------------------------------------------*/
;*    evcompile-error ...                                              */
;*---------------------------------------------------------------------*/
(define (evcompile-error loc proc mes obj)
   (match-case loc
      ((at ?fname ?loc)
       (error/location proc mes obj fname loc))
      (else
       (error proc mes obj))))
