;*=====================================================================*/
;*    serrano/prgm/project/bigloo/runtime/Llib/os.scm                  */
;*    -------------------------------------------------------------    */
;*    Author      :  SERRANO Manuel                                    */
;*    Creation    :  Tue Aug  5 10:57:59 1997                          */
;*    Last change :  Fri Nov 14 21:45:26 2003 (serrano)                */
;*    -------------------------------------------------------------    */
;*    Os dependant variables (setup by configure).                     */
;*    -------------------------------------------------------------    */
;*    Source documentation:                                            */
;*       @path ../../manuals/body.texi@                                */
;*       @node Operating System Interface@                             */
;*=====================================================================*/

;*---------------------------------------------------------------------*/
;*    The module                                                       */
;*---------------------------------------------------------------------*/
(module __os
   
   (import  __error)
   
   (use     __type
	    __bigloo
	    __tvector
	    __bexit
	    __r4_numbers_6_5_fixnum
	    __r4_numbers_6_5_flonum
	    __r4_booleans_6_1
	    __r4_symbols_6_4
	    __r4_vectors_6_8
	    __r4_control_features_6_9
	    __r4_pairs_and_lists_6_3
	    __r4_characters_6_6
	    __r4_equivalence_6_2
	    __r4_strings_6_7
	    __r4_ports_6_10_1
	    __foreign
	    __evenv
	    __r4_ports_6_10_1
	    __r4_output_6_10_3
	    __r4_input_6_10_2)
   
   (extern  (c-signal::obj (::int ::procedure) "c_signal")
	    (c-get-signal-handler::obj (::int) "get_signal_handler")
	    (*the-command-line*::obj "command_line")
	    (*the-executable-name*::string "executable_name")
	    (macro c-getenv?::bool (::string) "(long)getenv")
	    (macro c-getenv::string (::string) "(char *)getenv")
	    (c-setenv::int (::string ::string) "bgl_setenv")
	    (macro c-system::int  (::string) "system")
	    (c-date::string () "c_date")
	    (macro c-chdir::bool (::string) "chdir")
	    (macro c-getcwd::string (::string ::int) "(char *)(long)getcwd")
	    (c-chmod::bool (::string ::bool ::bool ::bool) "bgl_chmod")
	    (macro c-chmod-int::bool (::string ::int) "chmod")
	    (%gethostname::string () "bgl_gethostname")
	    
            (macro runtime-default-executable-name::string "BGL_DEFAULT_A_OUT")
            (macro runtime-default-script-name::string "BGL_DEFAULT_A_BAT")
	    (macro runtime-os-class::string "OS_CLASS")
	    (macro runtime-os-name::string "OS_NAME")
	    (macro runtime-os-arch::string "OS_ARCH")
	    (macro runtime-os-version::string "OS_VERSION")
	    (macro runtime-os-tmp::string "OS_TMP")
	    (macro runtime-file-separator::char "FILE_SEPARATOR")
	    (macro runtime-path-separator::char "PATH_SEPARATOR")
	    (macro runtime-static-library-suffix::string "STATIC_LIB_SUFFIX")
	    (macro runtime-shared-library-suffix::string "SHARED_LIB_SUFFIX")
	    (c-sleep::void (::long) "bgl_sleep")
	    (macro %dload-init-sym::string "BGL_DYNAMIC_LOAD_INIT")
	    (%dload::int (::string ::string) "bgl_dload")
	    (%dload-error::string () "bgl_dload_error"))
    
   (java    (class foreign
	       (field static *the-command-line*::obj
		      "command_line")
	       (field static *the-executable-name*::string
		      "executable_name")
	       (method static c-signal::obj (::int ::procedure)
		       "c_signal")
	       (method static c-get-signal-handler::obj (::int)
		       "get_signal_handler")
	       (method static c-getenv?::bool (::string)
		       "getenv_exists")
	       (method static c-getenv::string (::string)
		       "getenv")
	       (method static c-setenv::int (::string ::string)
		       "bgl_setenv")
	       (method static c-system::int  (::string)
		       "system")
	       (method static c-date::string ()
		       "c_date")
	       (method static c-chdir::bool (::string)
		       "chdir")
	       (method static c-getcwd::string (::string ::int)
		       "getcwd")
	       (method static c-chmod::bool (::string ::bool ::bool ::bool)
		       "bgl_chmod")
	       (method static c-chmod-int::bool (::string ::int)
		       "bgl_chmod")
	       (method static c-sleep::void (::long)
		       "bgl_sleep")
	       (field static %dload-init-sym::string
		      "BGL_DYNAMIC_LOAD_INIT")
	       (method static %dload::int (::string ::string)
		       "bgl_dload")
	       (method static %dload-error::string ()
		       "bgl_dload_error")
	       (method static %gethostname::string ()
		       "bgl_gethostname"))
	    
	    (class runtime
	       (field static default-executable-name::string
		      "BGL_DEFAULT_A_OUT")
	       (field static default-script-name::string
		      "BGL_DEFAULT_A_BAT")
	       (field static os-class::string
		      "OS_CLASS")
	       (field static os-name::string
		      "OS_NAME")
	       (field static os-arch::string
		      "OS_ARCH")
	       (field static os-version::string
		      "OS_VERSION")
	       (field static os-tmp::string
		      "OS_TMP")
	       (field static file-separator::char
		      "FILE_SEPARATOR")
	       (field static path-separator::char
		      "PATH_SEPARATOR")
	       (field static static-library-suffix::string
		      "STATIC_LIB_SUFFIX")
	       (field static shared-library-suffix::string
		      "SHARED_LIB_SUFFIX")
	       "bigloo.os"))
   
   (export  (signal num::int ::procedure)
	    (get-signal-handler::obj ::int)
	    
	    (getenv ::string)
	    (putenv ::string ::string)
	    (date::string)
	    (inline chdir::bool string::string)
	    (system . strings)
	    (system->string . strings)
	    (pwd)
	    (command-line)
	    (executable-name::string)
	    (basename::bstring ::bstring)
	    (dirname::bstring ::bstring)
	    (prefix::bstring ::bstring)
	    (suffix::bstring ::bstring)
	    (chmod::bool ::bstring . opts)
	    (make-file-name::bstring ::bstring ::bstring)
	    (make-file-path::bstring ::bstring ::bstring . obj)
	    (find-file/path ::bstring ::obj)
	    (make-static-library-name::bstring ::bstring)
	    (make-shared-library-name::bstring ::bstring)
            (default-executable-name)
            (default-script-name)
	    (os-class)
            (os-name)
	    (os-arch)
	    (os-version)
	    (os-tmp)
	    (file-separator)
	    (path-separator)
	    *dynamic-load-path*
	    *default-java-package*
	    (inline sleep ::long)
	    (dynamic-load ::bstring . opt)
	    (unix-path->list::pair-nil ::bstring)
	    (inline hostname::string)))

;*---------------------------------------------------------------------*/
;*    Variables setup ...                                              */
;*---------------------------------------------------------------------*/
(define (default-executable-name) runtime-default-executable-name)
(define (default-script-name) runtime-default-script-name)
(define (os-class) runtime-os-class)
(define (os-name) runtime-os-name)
(define (os-arch) runtime-os-arch)
(define (os-version) runtime-os-version)
(define (os-tmp) runtime-os-tmp)
(define (file-separator) runtime-file-separator)
(define (path-separator) runtime-path-separator)

;*---------------------------------------------------------------------*/
;*    command-line ...                                                 */
;*---------------------------------------------------------------------*/
(define (command-line)
   *the-command-line*)

;*---------------------------------------------------------------------*/
;*    executable-name ...                                              */
;*---------------------------------------------------------------------*/
(define (executable-name)
   *the-executable-name*)

;*---------------------------------------------------------------------*/
;*    signal ...                                                       */
;*---------------------------------------------------------------------*/
(define (signal num proc)
   (cond
      ((not (=fx (procedure-arity proc) 1))
       (error "signal" "Wrong number of arguments" proc))
      ((or (<fx num 0) (>fx num 31))
       (error "signal" "Illegal signal" num))
      (else
       (c-signal num proc))))

;*---------------------------------------------------------------------*/
;*    get-signal-handler ...                                           */
;*---------------------------------------------------------------------*/
(define (get-signal-handler num)
   (c-get-signal-handler num))

;*---------------------------------------------------------------------*/
;*    getenv ...                                                       */
;*---------------------------------------------------------------------*/
(define (getenv string)
   (if (and (string=? (os-class) "win32")
            (string=? string "HOME"))
       (set! string "USERPROFILE"))
   (if (c-getenv? string)
       (let ((result (c-getenv string)))
          (if (string-ptr-null? result)
              #f
              result))
       #f))

;*---------------------------------------------------------------------*/
;*    putenv ...                                                       */
;*---------------------------------------------------------------------*/
(define (putenv string val)
   (if (and (string=? (os-class) "win32")
            (string=? string "HOME"))
       (set! string "USERPROFILE"))
   (=fx (c-setenv string val) 0))

;*---------------------------------------------------------------------*/
;*    system ...                                                       */
;*---------------------------------------------------------------------*/
(define (system . strings)
   (cond
      ((null? strings)
       #f)
      ((null? (cdr strings))
       (c-system (car strings)))
      (else
       (c-system (apply string-append strings)))))
   
;*---------------------------------------------------------------------*/
;*    system->string ...                                               */
;*---------------------------------------------------------------------*/
(define (system->string . strings)
   (let* ((c (apply string-append "| " strings))
	  (p (open-input-file c)))
      (unwind-protect (read-string p)
		      (close-input-port p))))
      
;*---------------------------------------------------------------------*/
;*    date ...                                                         */
;*---------------------------------------------------------------------*/
(define (date)
   (let* ((dt (c-date))
	  (len (string-length dt)))
      (if (char=? (string-ref dt (-fx len 1)) #\Newline)
	  (substring dt 0 (-fx len 1))
	  dt)))

;*---------------------------------------------------------------------*/
;*    chdir ...                                                        */
;*---------------------------------------------------------------------*/
(define-inline (chdir dirname)
   (if (c-chdir dirname) #f #t))

;*---------------------------------------------------------------------*/
;*    pwd ...                                                          */
;*---------------------------------------------------------------------*/
(define (pwd)
   (let ((string (make-string 1024)))
      (c-getcwd string 1024)))
	  
;*---------------------------------------------------------------------*/
;*    basename ...                                                     */
;*---------------------------------------------------------------------*/
(define (basename string)
   (let* ((len   (-fx (string-length string) 1))
	  (start (if (and (>fx len 0)
			  (char=? (string-ref string len)
				  runtime-file-separator))
		     (-fx len 1)
		     len)))
      (let loop ((index start))
	 (cond
	    ((=fx index -1)
	     string)
	    ((char=? (string-ref string index) runtime-file-separator)
	     (substring string (+fx index 1) (+fx start 1)))
	    (else
	     (loop (-fx index 1)))))))

;*---------------------------------------------------------------------*/
;*    prefix ...                                                       */
;*---------------------------------------------------------------------*/
(define (prefix string)
   (let ((len (-fx (string-length string) 1)))
      (let loop ((e len)
                 (s len))
         (cond
            ((<=fx s 0)
             (substring string 0 (+fx 1 e)))
            (else
             (if (and (eq? (string-ref string s) #\.)
                      (=fx e len))
                 (loop (-fx s 1) (-fx s 1))
                 (loop e (-fx s 1))))))))

;*---------------------------------------------------------------------*/
;*    dirname ...                                                      */
;*---------------------------------------------------------------------*/
(define (dirname string)
   (let ((len (-fx (string-length string) 1)))
      (if (=fx len -1)
	  "."
	  (let loop ((read len))
	     (cond
		((=fx read 0)
		 (if (char=? (string-ref string read) runtime-file-separator)
		     (make-string 1 runtime-file-separator)
		     "."))
		((char=? (string-ref string read) runtime-file-separator)
		 (substring string 0 read))
		(else
		 (loop (-fx read 1))))))))

;*---------------------------------------------------------------------*/
;*    suffix ...                                                       */
;*---------------------------------------------------------------------*/
(define (suffix string)
   (let* ((len (string-length string))
          (len-1 (-fx len 1)))
      (let loop ((read len-1))
         (cond
            ((<fx read 0)
             "")
            ((char=? (string-ref string read) runtime-file-separator)
	     "")
            ((char=? (string-ref string read) #\.)
             (cond
                ((=fx read len-1)
                 "")
                (else
                 (substring string (+fx read 1) len))))
            (else
             (loop (-fx read 1)))))))

;*---------------------------------------------------------------------*/
;*    chmod ...                                                        */
;*---------------------------------------------------------------------*/
(define (chmod file::bstring . mode)
   (let loop ((mode mode)
	      (read? #f)
	      (write? #f)
	      (exec? #f))
      (cond
	 ((null? mode)
	  (c-chmod file read? write? exec?))
	 ((fixnum? (car mode))
	  (c-chmod-int file (car mode)))
	 ((eq? (car mode) 'read)
	  (loop (cdr mode)
		#t
		write?
		exec?))
	 ((eq? (car mode) 'write)
	  (loop (cdr mode)
		read?
		#t
		exec?))
	 ((eq? (car mode) 'execute)
	  (loop (cdr mode)
		read?
		write?
		#t))
	 (else
	  (error "chmod" "Unknown mode" mode)))))
	     
;*---------------------------------------------------------------------*/
;*    @deffn make-file-name@ ...                                       */
;*    -------------------------------------------------------------    */
;*    This function build a file name from a path and a                */
;*    relative file-name.                                              */
;*---------------------------------------------------------------------*/
(define (make-file-name directory::bstring file::bstring)
   (if (=fx (string-length directory) 0)
       file
       (let* ((ldir  (string-length directory))
	      (lfile (string-length file))
	      (len   (+fx ldir (+fx lfile 1)))
	      (str   (make-string len runtime-file-separator)))
	  (blit-string-ur! directory 0 str 0 ldir)
	  (blit-string-ur! file 0 str (+fx 1 ldir) lfile)
	  str)))

;*---------------------------------------------------------------------*/
;*    @deffn make-file-path@ ...                                       */
;*    -------------------------------------------------------------    */
;*    This function build a absolute file name from a path and a       */
;*    relative file-name.                                              */
;*---------------------------------------------------------------------*/
(define (make-file-path directory::bstring file::bstring . obj)
   (if (and (=fx (string-length directory) 0) (null? obj))
       file
       (let* ((ldir  (string-length directory))
	      (lfile (string-length file))
	      (len (let loop ((obj obj)
			      (l (+fx ldir (+fx 1 lfile))))
		      (cond
			 ((null? obj)
			  l)
			 ((not (string? (car obj)))
			  (bigloo-type-error 'make-file-path
					     "string"
					     (car obj)))
			 (else
			  (loop (cdr obj) (+fx 1
					       (+fx (string-length (car obj))
						    l)))))))
	      (str  (make-string len runtime-file-separator)))
	  (blit-string-ur! directory 0 str 0 ldir)
	  (blit-string-ur! file 0 str (+fx 1 ldir) lfile)
	  (let loop ((obj obj)
		     (w (+fx 1 (+fx ldir lfile))))
	     (if (null? obj)
		 str
		 (let ((lo (string-length (car obj))))
		    (blit-string-ur! (car obj) 0 str (+fx 1 w) lo)
		    (loop (cdr obj) (+fx w (+fx lo 1)))))))))

;*---------------------------------------------------------------------*/
;*    @deffn find-file/path@ ...                                       */
;*---------------------------------------------------------------------*/
(define (find-file/path file-name path)
   (cond
      ((=fx (string-length file-name) 0)
       #f)
      ((char=? (string-ref file-name 0) runtime-file-separator)
       (if (file-exists? file-name)
           file-name
           #f))
      (else
       (let loop ((path path))
	  (if (null? path)
	      #f
	      (let ((fname (make-file-name (car path) file-name)))
		 (if (file-exists? fname)
		     fname
		     (loop (cdr path)))))))))

;*---------------------------------------------------------------------*/
;*    make-static-library-name ...                                     */
;*    -------------------------------------------------------------    */
;*    This function, adds the proper static library extension.         */
;*---------------------------------------------------------------------*/
(define (make-static-library-name libname::bstring)
   (string-append libname "." runtime-static-library-suffix))

;*---------------------------------------------------------------------*/
;*    make-shared-library-name ...                                     */
;*    -------------------------------------------------------------    */
;*    This function, adds the proper shared library extension.         */
;*---------------------------------------------------------------------*/
(define (make-shared-library-name libname::bstring)
   (string-append libname "." runtime-shared-library-suffix))

;*---------------------------------------------------------------------*/
;*    sleep ...                                                        */
;*---------------------------------------------------------------------*/
(define-inline (sleep ms)
   (c-sleep ms)
   ms)

;*---------------------------------------------------------------------*/
;*    *dynamic-load-path* ...                                          */
;*---------------------------------------------------------------------*/
(define *dynamic-load-path* '("" "."))

;*---------------------------------------------------------------------*/
;*    *default-java-package* ...                                       */
;*    -------------------------------------------------------------    */
;*    The default package for non qualified imported Java definitions. */
;*    -------------------------------------------------------------    */
;*    See the -pckg-java compiler option.                              */
;*---------------------------------------------------------------------*/
(define *default-java-package* "bigloo.foreign")

;*---------------------------------------------------------------------*/
;*    dynamic-load ...                                                 */
;*---------------------------------------------------------------------*/
(define (dynamic-load lib . inits)
    (define (err proc::obj msg obj)
      (error (if (string? proc)
		 (string-append "dynamic-load:" proc)
		 "dynamic-load")
	     msg obj))
   (let ((init (if (and (pair? inits) (string? (car inits)))
		   (car inits)
		   %dload-init-sym))
	 (flib  (cond-expand
		   (bigloo-c
		    (find-file/path lib *dynamic-load-path*))
		   (bigloo-jvm
		    lib)
		   (else
		    (find-file/path lib *dynamic-load-path*)))))
      (if (not (string? flib))
	  (err #f "Can't find library" lib)
	  (case (%dload flib init)
	     ((0)
	      flib)
	     ((1)
	      (err flib (%dload-error) flib))
	     ((2)
	      (err "Can't find init symbol" init (%dload-error)))
	     ((3)
	      (err #f "Not supported on this architecture" flib))))))
	 
	  
;*---------------------------------------------------------------------*/
;*    unix-path->list ...                                              */
;*---------------------------------------------------------------------*/
(define (unix-path->list str)
   (let ((stop (string-length str)))
      (let loop ((mark 0)
		 (r 0)
		 (res '()))
	 (cond
	    ((=fx stop r)
	     (let ((res (if (<fx mark r)
			    (cons (substring str mark r) res)
			    res)))
		(reverse! res)))
	    ((char=? (string-ref str r) #\:)
	     (if (<fx mark r)
		 (loop (+fx 1 r) (+fx 1 r) (cons (substring str mark r) res))
		 (loop (+fx 1 r) (+fx 1 r) res)))
	    (else
	     (loop mark (+fx 1 r) res))))))
	     
;*---------------------------------------------------------------------*/
;*    hostname ...                                                     */
;*---------------------------------------------------------------------*/
(define-inline (hostname)
   (%gethostname))
