;*=====================================================================*/
;*    serrano/prgm/project/bigloo/runtime/Llib/bigloo.scm              */
;*    -------------------------------------------------------------    */
;*    Author      :  Manuel Serrano                                    */
;*    Creation    :  Fri Jan 20 08:24:40 1995                          */
;*    Last change :  Tue Sep 30 09:43:18 2003 (serrano)                */
;*    -------------------------------------------------------------    */
;*    The bigloo runtime utility functions                             */
;*=====================================================================*/
 
;*---------------------------------------------------------------------*/
;*    The module                                                       */
;*---------------------------------------------------------------------*/
(module __bigloo

   (import  __error)
   
   (use     __type
	    __tvector
	    __bit

	    __r4_numbers_6_5_fixnum
	    __r4_numbers_6_5_flonum
	    __r4_equivalence_6_2
	    __r4_vectors_6_8
	    __r4_booleans_6_1
	    __r4_pairs_and_lists_6_3
	    __r4_control_features_6_9
	    __r4_characters_6_6
	    __r4_symbols_6_4
	    __r4_strings_6_7
	    __r5_control_features_6_4
	    __r4_output_6_10_3
	    __r4_ports_6_10_1
	    
	    __evenv)

   (extern  (macro c-procedure-light?::bool (::obj)
		   "PROCEDURE_LIGHTP")
	    (macro va-procedure?::bool (::procedure)
		   "VA_PROCEDUREP")
	    (macro procedure-entry::obj (::procedure)
		   "PROCEDURE_ENTRY")
	    (macro tprocedure-l-entry::obj (::procedure)
		   "PROCEDURE_L_ENTRY")
	    
	    (macro procedure-arity::int (::procedure)
		   "PROCEDURE_ARITY")
	    (macro correct-arity?::bool (::procedure ::int)
		   "PROCEDURE_CORRECT_ARITYP")
	    
	    (macro make-fx-procedure::procedure (::obj ::int ::int)
		   "make_fx_procedure")		 
	    (macro make-va-procedure::procedure (::obj ::int ::int)
		   "make_va_procedure")
	    
	    (macro make-el-procedure::procedure-el (::int)
		   "MAKE_EL_PROCEDURE")	 
	    (macro make-el-procedure-1::procedure-el1 (::int)
		   "MAKE_EL_PROCEDURE_1")	 
	    
	    (macro make-l-procedure::procedure (::obj ::int)
		   "MAKE_L_PROCEDURE")		 
	    					 
	    (macro procedure-set!::obj (::procedure ::int ::obj)
		   "PROCEDURE_SET")			 
	    (macro procedure-ref::obj (::procedure ::int)
		   "PROCEDURE_REF")			 

	    (macro procedure-l-set!::obj (::obj ::int ::obj)
		   "PROCEDURE_L_SET")		  
	    (macro procedure-l-ref::obj (::obj ::int)
		   "PROCEDURE_L_REF")
	    
	    (macro procedure-el-set!::obj (::procedure-el ::int ::obj)
		   "PROCEDURE_EL_SET")		 
	    (macro procedure-el-ref::obj (::procedure-el ::int)
		   "PROCEDURE_EL_REF")
	    
	    (macro procedure-1-el-set!::obj (::procedure-el1 ::int ::obj)
		   "PROCEDURE_1_EL_SET")		 
	    (macro procedure-1-el-ref::obj (::procedure-el1 ::int)
		   "PROCEDURE_1_EL_REF")
	    
	    (macro make-cell::obj (::obj)
		   "MAKE_CELL")
	    (macro cell-set!::obj (::obj ::obj)
		   "CELL_SET")
	    (macro cell-ref::obj (::obj)
		   "CELL_REF")
	    (macro cell?::bool (::obj)
		   "CELLP")
	    
	    (macro c-cnst?::bool (::obj)
		   "CNSTP")
	    (macro c-opaque?::bool (::obj)
		   "OPAQUEP")
	    
	    (macro __unspec__::obj "BUNSPEC")
	    (macro __eoa__::obj "BEOA")
	    
	    (macro declare-cnst-table::obj (::obj)
		   "DECLARE_CNST_TABLE")
	    (macro cnst-table-set!::obj (::int ::obj)
		   "CNST_TABLE_SET")
	    (macro cnst-table-ref::obj (::int)
		   "CNST_TABLE_REF")

	    (macro close-init-string::obj (::obj)
		   "close_init_string")
	    
	    (macro var->root::obj (::obj)
		   "(obj_t)&")
	    (macro GC-add-globv!::obj (::obj)
		   "GC_ADD_GLOBV")
	    (macro GC-add-roots!::obj (::obj ::obj)
		   "GC_ADD_ROOTS")
 
	    (macro GC-profile-push::long (::string ::obj)
		    "GC_profile_push")
	    (macro GC-collect-profile-push::long (::string ::obj)
		   "GC_collect_profile_push")
	    (macro GC-profile-pop::long  ()
		   "GC_profile_pop")
	    
	    (macro %exit::obj (::obj)
		   "BIGLOO_EXIT")
	    (macro bigloo-exit::obj (::obj)
		   "BIGLOO_EXIT")

	    (export bigloo-mangle "bigloo_mangle")
	    (export bigloo-module-mangle "bigloo_module_mangle")
	    (export bigloo-mangled? "bigloo_mangledp")
	    (export bigloo-class-mangled? "bigloo_class_mangledp")
	    (export bigloo-demangle "bigloo_demangle")
	    (export bigloo-class-demangle "bigloo_class_demangle")
	    (export bigloo-exit-apply "bigloo_exit_apply"))

   (java    (class foreign
	       (field static __unspec__::obj "BUNSPEC")
	       (field static __eoa__::obj "BEOA")
	       
	       (method static bigloo-exit::obj (::obj)
		       "BIGLOO_EXIT")
	       (method static c-procedure-light?::bool (::obj)
		       "PROCEDURE_LIGHTP")
	       (method static va-procedure?::bool (::procedure)
		       "VA_PROCEDUREP")
	       (method static procedure-entry::obj (::procedure)
		       "PROCEDURE_ENTRY")
	       (method static tprocedure-l-entry::obj (::procedure)
		       "PROCEDURE_L_ENTRY")
	       
	       (method static procedure-arity::int (::procedure)
		       "PROCEDURE_ARITY")
	       (method static correct-arity?::bool (::procedure ::int)
		       "PROCEDURE_CORRECT_ARITYP")
	       
	       (method static make-fx-procedure::procedure (::obj ::int ::int)
		       "make_fx_procedure")		 
	       (method static make-va-procedure::procedure (::obj ::int ::int)
		       "make_va_procedure")
	       
	       (method static make-el-procedure::procedure-el (::int)
		       "MAKE_EL_PROCEDURE")	 
	       (method static make-el-procedure-1::procedure-el1 (::int)
		       "MAKE_EL_PROCEDURE_1")	 
	       
	       (method static make-l-procedure::procedure (::obj ::int)
		       "MAKE_L_PROCEDURE")		 
	       
	       (method static procedure-set!::obj (::procedure ::int ::obj)
		       "PROCEDURE_SET")			 
	       (method static procedure-ref::obj (::procedure ::int)
		       "PROCEDURE_REF")			 
	       
	       (method static procedure-l-set!::obj (::procedure ::int ::obj)
		       "PROCEDURE_L_SET")		  
	       (method static procedure-l-ref::obj (::procedure ::int)
		       "PROCEDURE_L_REF")
	       
	       (method static procedure-el-set!::obj (::procedure-el ::int ::obj)
		       "PROCEDURE_EL_SET")		 
	       (method static procedure-el-ref::obj (::procedure-el ::int)
		       "PROCEDURE_EL_REF")
	       
	       (method static procedure-1-el-set!::obj (::procedure-el1 ::int ::obj)
		       "PROCEDURE_1_EL_SET")		 
	       (method static procedure-1-el-ref::obj (::procedure-el1 ::int)
		       "PROCEDURE_1_EL_REF")
	       
	       (method static make-cell::cell (::obj)
		       "MAKE_CELL")
	       (method static cell-set!::obj (::cell ::obj)
		       "CELL_SET")
	       (method static cell-ref::obj (::cell)
		       "CELL_REF")
	       (method static cell?::bool (::obj)
		       "CELLP")
	       
	       (method static c-cnst?::bool (::obj)
		       "CNSTP")
	       (method static c-opaque?::bool (::obj)
		       "OPAQUEP")
	       
	       (method static declare-cnst-table::obj (::obj)
		       "DECLARE_CNST_TABLE")
	       (method static cnst-table-set!::obj (::int ::obj)
		       "CNST_TABLE_SET")
	       (method static cnst-table-ref::obj (::int)
		       "CNST_TABLE_REF")
	       
	       (method static close-init-string::obj (::obj)
		       "close_init_string")
	       
	       (method static var->root::obj (::obj)
		       "VAR_ROOT")
	       (method static GC-add-globv!::obj (::obj)
		       "GC_ADD_GLOBV")
	       (method static GC-add-roots!::obj (::obj ::obj)
		       "GC_ADD_ROOTS")
	       
	       (method static GC-profile-push::long (::string ::obj)
		       "GC_profile_push")
	       (method static GC-collect-profile-push::long (::string ::obj)
		       "GC_collect_profile_push")
	       (method static GC-profile-pop::long  ()
		       "GC_profile_pop")
	       
	       (method static %exit::obj (::obj)
		       "BIGLOO_EXIT"))
	    
	    (export bigloo-mangle "bigloo_mangle")
	    (export bigloo-module-mangle "bigloo_module_mangle")
	    (export bigloo-mangled? "bigloo_mangledp")
	    (export bigloo-demangle "bigloo_demangle")
	    (export bigloo-class-mangled? "bigloo_class_mangledp")
	    (export bigloo-class-demangle "bigloo_class_demangle")
	    (export bigloo-exit-apply "bigloo_exit_apply"))

   (export  *bigloo-strict-r5rs-strings*
	    (check-version! ::obj ::string ::obj)
	    (inline cnst?::bool ::obj)
	    (inline opaque?::bool ::obj)
	    (inline closure-arity::int ::procedure)
	    (inline unspecified::unspecified)
	    (bigloo-mangled?::bool ::bstring)
	    (bigloo-need-mangling?::bool ::bstring)
	    (bigloo-class-mangled?::bool ::bstring)
	    (bigloo-mangle::bstring ::bstring)
	    (bigloo-module-mangle::bstring ::bstring ::bstring)
	    (bigloo-demangle ::bstring)
	    (bigloo-class-demangle::bstring ::bstring)
	    (register-exit-function! ::procedure)
	    (bigloo-exit-apply::obj ::obj))

   (pragma  (c-procedure-light? nesting)
	    (va-procedure? nesting)
	    (procedure-entry nesting)
	    (tprocedure-l-entry nesting)
	    (procedure-arity nesting args-safe)
	    (correct-arity? nesting args-safe)
	    (make-fx-procedure no-cfa-top nesting args-safe)
	    (make-va-procedure no-cfa-top nesting args-safe)
	    (procedure-set! no-cfa-top nesting args-safe)
	    (procedure-ref no-cfa-top side-effect-free nesting args-safe)
	    (procedure-l-set! nesting args-safe)
	    (procedure-l-ref nesting args-safe)
	    (procedure-el-set! nesting args-safe)
	    (procedure-el-ref nesting args-safe)
	    (procedure-1-el-set! nesting args-safe)
	    (procedure-1-el-ref nesting args-safe)
	    (cell? (predicate-of cell) nesting)
	    (cell-set! nesting args-safe)
	    (cell-ref nesting  args-safe)
	    (c-cnst? (predicate-of cnst) nesting)
	    (c-opaque? (predicate-of opaque) nesting))

   (option  (set! *unsafe-version* #t)))

;*---------------------------------------------------------------------*/
;*    Set to #t for a pure r5rs interpretation of escape String        */
;*    sequences. Set to #f to evaluates sequences such a \t, \n        */
;*    as C strings.                                                    */
;*---------------------------------------------------------------------*/
(define *bigloo-strict-r5rs-strings* #f)

;*---------------------------------------------------------------------*/
;*    check-version! ...                                               */
;*    -------------------------------------------------------------    */
;*    This function is in charge of the coherence of all module        */
;*    of an executable (i.e. does all module compiled by the           */
;*    same Bigloo's version).                                          */
;*---------------------------------------------------------------------*/
(define (check-version! module release level)
   (cond
      ((not (string? *release*))
       (set! *modules* (list module))
       (set! *release* release)
       (set! *level*   level))
      ((or (let ((min (-fx (minfx (string-length release)
				  (string-length *release*))
			   1)))
	      (not (string=? (substring release 0 min)
			     (substring *release* 0 min))))
	   (and (char? level) (char? *level*) (not (char=? *level* level))))
       (define (release-name release level)
	  (if (char? level)
	      (let ((s (string-copy " (level 0)")))
		 (string-set! s 8 level)
		 (string-append release s))
	      release))
       (error (string-append "Some modules have been compiled by: "
			     (release-name *release* *level*))
	      (string-append "and other by: "
			     (release-name release level))
	      (cons module *modules*)))
      (else
       (set! *modules* (cons module *modules*)))))

;*---------------------------------------------------------------------*/
;*    Some variables for check-version!                                */
;*---------------------------------------------------------------------*/
(define *release* #f)
(define *level*   #f)
(define *modules* '())
   
;*---------------------------------------------------------------------*/
;*    closure-arity ...                                                */
;*---------------------------------------------------------------------*/
(define-inline (closure-arity proc)
   (procedure-arity proc))

;*---------------------------------------------------------------------*/
;*    unspecified ...                                                  */
;*---------------------------------------------------------------------*/
(define-inline (unspecified)
   __unspec__)

;*---------------------------------------------------------------------*/
;*    cnst? ...                                                        */
;*---------------------------------------------------------------------*/
(define-inline (cnst? obj)
   (c-cnst? obj))

;*---------------------------------------------------------------------*/
;*    opaque? ...                                                      */
;*---------------------------------------------------------------------*/
(define-inline (opaque? obj)
   (c-opaque? obj))

;*---------------------------------------------------------------------*/
;*    4bits->char ...                                                  */
;*---------------------------------------------------------------------*/
(define-inline (4bits->char num)
   (let ((hexa "0123456789abcdef"))
      (string-ref hexa num)))

;*---------------------------------------------------------------------*/
;*    mangle-at! ...                                                   */
;*---------------------------------------------------------------------*/
(define (mangle-at! new old len offset)
   (let loop ((r 0)
	      (w offset)
	      (new-len offset)
	      (checksum 0))
      (if (=fx r len)
	  (begin
	     (string-set! new w #\z)
	     (string-set! new
			  (+fx w 1)
			  (4bits->char (bit-and checksum 15)))
	     (string-set! new
			  (+fx w 2)
			  (4bits->char (bit-and (bit-rsh checksum 4) 15)))
	     (+fx w 3))
	  (let ((c (string-ref old r)))
	     (if (or (and (char-alphabetic? c) (not (char=? c #\z)))
		     (char-numeric? c)
		     (char=? c #\_))
		 (begin 
		    (string-set! new w c)
		    (loop (+fx r 1)
			  (+fx w 1)
			  (+fx new-len 1)
			  checksum))
		 (let ((ic (char->integer c)))
		    (string-set! new w #\z)
		    (string-set! new
				 (+fx w 1)
				 (4bits->char (bit-and ic 15)))
		    (string-set! new
				 (+fx w 2)
				 (4bits->char (bit-and (bit-rsh ic 4) 15)))
		    (loop (+fx r 1)
			  (+fx w 3)
			  (+fx new-len 3)
			  (bit-xor checksum (char->integer c)))))))))

;*---------------------------------------------------------------------*/
;*    bigloo-mangle ...                                                */
;*---------------------------------------------------------------------*/
(define (bigloo-mangle string)
   (let* ((len (string-length string))
	  (new (make-string (+fx (*fx len 3) 7))))
      (if (=fx len 0)
	  (error "bigloo-mangle-string" "Can't mangle empty string" string)
	  (let ((stop (mangle-at! new string len 4)))
	     (blit-string! "BgL_" 0 new 0 4)
	     (substring new 0 stop)))))

;*---------------------------------------------------------------------*/
;*    bigloo-module-mangle ...                                         */
;*---------------------------------------------------------------------*/
(define (bigloo-module-mangle id module)
   (let* ((len (+fx (string-length id) (string-length module)))
	  (new (make-string (+fx (*fx len 3) 12))))
      (if (=fx len 0)
	  (error "bigloo-mangle-string" "Can't mangle empty string" string)
	  (let ((mod-start (mangle-at! new id (string-length id) 4)))
	     (string-set! new mod-start #\z)
	     (string-set! new (+fx 1 mod-start) #\z)
	     (let ((stop (mangle-at! new module
				     (string-length module)
				     (+fx mod-start 2))))
		(blit-string! "BGl_" 0 new 0 4)
		(substring new 0 stop))))))

;*---------------------------------------------------------------------*/
;*    bigloo-mangled? ...                                              */
;*---------------------------------------------------------------------*/
(define (bigloo-mangled? string)
   (let ((len (string-length string)))
      (and (>fx len 7)
	   (or (substring=? string "BgL_" 4)
	       (substring=? string "BGl_" 4))
	   (char=? (string-ref string (-fx len 3)) #\z)
	   (or (char-alphabetic? (string-ref string (-fx len 2)))
	       (char-numeric? (string-ref string (-fx len 2))))
	   (or (char-alphabetic? (string-ref string (-fx len 1)))
	       (char-numeric? (string-ref string (-fx len 1)))))))

;*---------------------------------------------------------------------*/
;*    bigloo-need-mangling? ...                                        */
;*---------------------------------------------------------------------*/
(define (bigloo-need-mangling? string)
   (let ((len (string-length string)))
      (and (>fx len 0)
	   (or (not (or (char-alphabetic? (string-ref string 0))
			(char=? (string-ref string 0) #\_)))
	       (let loop ((i 1))
		  (if (>=fx i len)
		      #f
		      (let ((c (string-ref string i)))
			 (if (or (char-alphabetic? c)
				 (char-numeric? c)
				 (char=? c #\_))
			     (loop (+fx i 1))
			     #t))))))))
		     
;*---------------------------------------------------------------------*/
;*    bigloo-demangle ...                                              */
;*---------------------------------------------------------------------*/
(define (bigloo-demangle string)
   (let* ((len (string-length string))
	  (clen (-fx len 3)))
      (define (err)
	 (error "bigloo-demangle" "Illegal mangling on" string))
      (define (char->digit c)
	 (if (char-numeric? c)
	     (-fx (char->integer c) (char->integer #\0))
	     (+fx 10 (-fx (char->integer c) (char->integer #\a)))))
      (define (get-8bits-integer r)
	 (let* ((c1 (string-ref string (+fx r 1)))
		(c2 (string-ref string (+fx r 2)))
		(i1 (char->digit c1))
		(i2 (char->digit c2)))
	    (+fx i1 (bit-lsh i2 4))))
      (define (bigloo-demangle-at offset)
	 (let ((new (make-string clen)))
	    (let loop ((r offset)
		       (w 0)
		       (checksum 0))
	       (if (=fx r clen)
		   ;; we still have to check the checksum
		   (if (=fx checksum (get-8bits-integer r))
		       (values (substring new 0 w) (+fx r 3))
		       (err))
		   (let ((c (string-ref string r)))
		      (if (char=? c #\z)
			  (if (char=? (string-ref string (+fx r 1)) #\z)
			      (values (substring new 0 (-fx w 1)) (+fx r 2))
			      (let* ((i (get-8bits-integer r))
				     (nc (integer->char i)))
				 (string-set! new w nc)
				 (loop (+fx r 3)
				       (+fx w 1)
				       (bit-xor checksum i))))
			  (begin
			     (string-set! new w c)
			     (loop (+fx r 1)
				   (+fx w 1)
				   checksum))))))))
      (define (bigloo-demangle-simple)
	 (multiple-value-bind (str offset)
	    (bigloo-demangle-at 4)
	    (values str #unspecified)))
      (define (bigloo-demangle-module)
	 (multiple-value-bind (id offset)
	    (bigloo-demangle-at 4)
	    (multiple-value-bind (module offset)
	       (bigloo-demangle-at offset)
	       (values id module))))
      (cond
	 ((<fx len 8)
	  (error "bigloo-demangle" "Not a Bigloo mangled identifier" string))
	 ((substring=? string "BgL_" 4)
	  (bigloo-demangle-simple))
	 ((substring=? string "BGl_" 4)
	  (bigloo-demangle-module))
	 (else
	  string))))

;*---------------------------------------------------------------------*/
;*    bigloo-class-mangled? ...                                        */
;*---------------------------------------------------------------------*/
(define (bigloo-class-mangled? string)
   (let ((len (string-length string)))
      (and (>fx len 8)
	   (char=? (string-ref string (-fx len 1)) #\t)
	   (char=? (string-ref string (-fx len 2)) #\l)
	   (char=? (string-ref string (-fx len 3)) #\g)
	   (char=? (string-ref string (-fx len 4)) #\b)
	   (char=? (string-ref string (-fx len 5)) #\_)
	   (bigloo-mangled? (substring string 0 (-fx len 5))))))
   
;*---------------------------------------------------------------------*/
;*    bigloo-class-demangle ...                                        */
;*---------------------------------------------------------------------*/
(define (bigloo-class-demangle string)
   (string-append (bigloo-demangle
		   (substring string 0 (-fx (string-length string) 5)))
		  "_bglt"))
   
;*---------------------------------------------------------------------*/
;*    *bigloo-exit-functions* ...                                      */
;*---------------------------------------------------------------------*/
(define *bigloo-exit-functions* '())

;*---------------------------------------------------------------------*/
;*    register-exit-function! ...                                      */
;*---------------------------------------------------------------------*/
(define (register-exit-function! fun)
   (if (not (correct-arity? fun 1))
       (error "bigloo-exit-register!"
	      "Wrong procedure arity"
	      fun)
       (set! *bigloo-exit-functions* (cons fun *bigloo-exit-functions*))))

;*---------------------------------------------------------------------*/
;*    bigloo-exit-apply ...                                            */
;*---------------------------------------------------------------------*/
(define (bigloo-exit-apply val)
   (if (pair? *bigloo-exit-functions*)
       (let ((fun (car *bigloo-exit-functions*)))
	  (set! *bigloo-exit-functions* (cdr *bigloo-exit-functions*))
	  (bigloo-exit-apply (fun val)))
       val))
