; OS-specific functions. They are mostly POSIX -- but very Gambit-specific ; $Id: OS-spec.scm,v 3.3 2003/08/11 20:14:21 oleg Exp oleg $ ; Compilation optimization options (declare (block) (standard-bindings) ) (include "myenv.scm") ; include target dependent stuff (c-declare "#include ") (c-declare "#include ") (c-declare "#include ") (c-declare "#include ") (c-declare "#include ") (c-declare "#include ") (c-declare "#include ") ;---------------------------------------------------------------------------- ; Time and timing ; Get the current time, the number of seconds since Jan 1, 1970. ; see man time(2) for more details (define OS:time (c-lambda () unsigned-int "___result = time(0);")) (define OS:sleep (c-lambda (unsigned-int) unsigned-int "sleep")) ; get the current time in the desired format. See man pages for strftime() ; for more details. ; Note, cftime() function would be more convenient here; alas, it is ; absent on some platforms (e.g., HP/UX). strftime() seems to be more ; portable ; The conversion is performed keeping in mind the current timezone ; (as specified by the env variable TZ). If one wants to obtain the ; GMT (UTC) time stamp, perform (OS:putenv "TZ" "GMT0") prior to ; application of this function (define OS:cftime (c-lambda (char-string int) char-string "time_t clock_val = ___arg2; struct tm conv_time; char buffer[60]; buffer[0] = '\\0'; strftime(buffer,sizeof(buffer)-1,___arg1, (localtime_r(&clock_val,&conv_time),&conv_time)); ___result = buffer;")) ; Parse and read-in a time specification from an ASCII string ; Return the time value in epoch seconds, or 0 if the conversion ; failed ; The function is the inverse of OS:cftime: ; (= time-val ; (OS:string->time "%a, %d %b %Y %T GMT" ; (OS:cftime "%a, %d %b %Y %X %Z" time-val))) ; ; must be #t for any time-val (epoch seconds) ; string, provided that TZ is set up to GMT0 (define OS:string->time ; format time-spec-string time-value-in-epoch-secs (c-lambda (char-string char-string) unsigned-int "struct tm parsed_spec = {0,0,0,0,0,0,0}; /* printf(\"strptime returned %x\\n\",strptime(___arg2, ___arg1,&parsed_spec)); printf(\"tm_sec %d\\n\",parsed_spec.tm_sec); printf(\"tm_min %d\\n\",parsed_spec.tm_min); printf(\"tm_hour %d\\n\",parsed_spec.tm_hour); printf(\"tm_mday %d\\n\",parsed_spec.tm_mday); printf(\"tm_mon %d\\n\",parsed_spec.tm_mon); printf(\"tm_year %d\\n\",parsed_spec.tm_year); printf(\"tm_wday %d\\n\",parsed_spec.tm_wday); printf(\"tm_yday %d\\n\",parsed_spec.tm_yday); printf(\"tm_isdst %d\\n\",parsed_spec.tm_isdst); printf(\"\\n mktime %d\\n\",mktime(&parsed_spec)); */ ___result = strptime(___arg2, ___arg1,&parsed_spec) == (char *)0 ? 0 : mktime(&parsed_spec);")) ;---------------------------------------------------------------------------- ; Files and directories (define OS:remove (c-lambda (char-string) int "remove")) ; remove a given file when the application finishes (atexit) ; Note as all the work is done at exit, we can't rely on any ; data structures we got from Scheme. We need to copy all the data ; we need, and use static memory as much as possible (c-declare "static char To_Remove_atexit_names [512]; /* set of names separated with \0 */ static char * To_Remove_atexit_curr_ptr = To_Remove_atexit_names; /* A function that is called at exit */ static void To_Remove_atexit(void) { register char * p; for(p=To_Remove_atexit_names; p 0 && To_Remove_atexit_curr_ptr + len + 1 < To_Remove_atexit_names + sizeof(To_Remove_atexit_names) ) { strcpy(To_Remove_atexit_curr_ptr,___arg1); To_Remove_atexit_curr_ptr += len + 1; ___result = to_register ? atexit(To_Remove_atexit) == 0 : 1; }") file-name) (error "remove-at-exit registration failed"))) (define OS:rename (c-lambda (char-string char-string) bool "___result = !rename(___arg1,___arg2);")) ; set the process's file mode creation mask to the given value and ; return the previous value of the mask. ; (OS:umask 0) allows access to everyone, ; (OS:umask #o077) forbids access to newly created files from everyone ; but the owner (define OS:umask (c-lambda (unsigned-int) unsigned-int "umask")) ; Make a unique name for a temporary file (define OS:tmpnam (c-lambda () char-string "___result = tmpnam(0);")) (define OS:file-exists? (c-lambda (char-string) scheme-object "___result = access(___arg1,R_OK) == 0 ? ___TRU : ___FAL;")) ; Return the size of an existing file ; If there was a problem opening the file, -1 is returned (c-declare "#include #include int stat(const char * path, struct stat * buf);") (define OS:file-length (c-lambda (char-string) int "struct stat file_status; if( stat(___arg1,&file_status) != 0 ) perror(\"getting stat\"), ___result = -1; else ___result = file_status.st_size;")) ; Change directory, make it if it didn't exist (define (OS:ch-mk-dir dir-name) (let ((result ((c-lambda (char-string) int "___result = 0; if( chdir(___arg1) ) { if( (___result = errno) == ENOENT ) if( mkdir(___arg1,0777) ) ___result = errno; else ___result = chdir(___arg1) ? errno : 0; }") dir-name))) (if (positive? result) (error "Error " result " changing/creating directory")))) ; Go back to the parent directory (define (OS:ch-parent-dir) (let ((result ((c-lambda () int "___result = chdir(\"..\") ? errno : 0;")))) (if (positive? result) (error "Error " result " getting back to the parent directory")))) ; Get the current directory (define OS:getcwd (c-lambda () char-string "char buffer[255+1]; ___result = getcwd(buffer,sizeof(buffer)-1);")) ; Just change the directory (define (OS:chdir dir-name) (let ((result ((c-lambda (char-string) int "if( ___result = 0, chdir(___arg1) ) ___result = errno;") dir-name))) (if (positive? result) (error "Error " result " changing directory to " dir-name)))) (define PATH-SEPARATOR-CHAR #\/) ; These procedures are implemented in Gambit 2.4 ;(define flush-output ; (c-lambda () void "fflush(stdout);")) ; redirect the standard error to a file, which is opened ; in the append mode (and created, if necessary) (define OS:stderr->file (c-lambda (char-string) void "const int new_file_handle = open(___arg1,O_WRONLY|O_APPEND|O_CREAT,0777); if( new_file_handle < 0 ) perror(\"error opening the file for stderr->file\"), exit(4); if( dup2(new_file_handle,2) < 0 ) perror(\"dup2 error while stderr->file\"), exit(4); ")) ;---------------------------------------------------------------------------- ; Gambit ports ; A few preliminaries, taken from lib/_io.scm file of the Gambit ; distribution. (c-declare "#include \"os.h\"") ; From the Gambit distribution (##define-macro (port-input-char-count port) `(##vector-ref ,port 16)) (##define-macro (port-input-stream port) `(##vector-ref ,port 22)) (##define-macro (port-output-stream port) `(##vector-ref ,port 23)) ; Determining if a port is a i/o stream port. i/o stream ports ; permit fast implementations of the functions below. ; We base our decision on a comparison of the number of slots in the port ; vector with the number of slots in ##stderr, which is definitely ; an i/o stream port. (define OS:stream-port? (let ((stream-port-size (##vector-length ##stderr))) (lambda (port) ; the body of the function (= stream-port-size (##vector-length port))))) ; procedure+: write-substring STR I J PORT ; write (substring STR I J) into the output PORT. ; If PORT is a i/o stream port, a highly-efficient implementation is ; possible. (define (write-substring str i j port) (##declare (multilisp) (extended-bindings) (not safe) (block) (fixnum) (inlining-limit 134) ) (assert (##output-port? port) (<= 0 i j (##string-length str))) (if (OS:stream-port? port) (or ; A fast path ((c-lambda ((pointer "___STREAM") scheme-object int int) scheme-object " FILE *stream = ___arg1 == 0 ? 0 : ___arg1->stdio_stream; if (stream == 0) /* stream is closed? */ ___result = ___FAL; else if( !___STRINGP(___arg2) ) ___result = ___FAL; /* object to write is not a string */ else { int len = ___STRINGLENGTH(___arg2); int i; if( ___arg4 < len) len = ___arg4; for(i=___arg3; istdio_stream; FILE *ostream = ___arg2==0 ? 0 : ___arg2->stdio_stream; register int count = ___arg3; /* May be negative-- means unlimited */ if (istream == 0 || ostream == 0) /* stream is closed? */ ___result = ___FAL; else if( count == 0 ) ___result = ___FIX(0); /* nothing to copy */ else { ___WORD look_ahead = ___arg1->lookahead; char buffer[8192]; /* we read/write by blocks of that many bytes*/ register int i; if( ___CHARP(look_ahead) ) putc(___INT(look_ahead),ostream), count--, ___arg1->lookahead = ___FAL; if( count < 0 ) { /* copy till EOF */ for(;;) { int count_read = fread(buffer,1,sizeof(buffer),istream); int count_written = 0; if( count_read > 0 ) count_written = fwrite(buffer,1,count_read,ostream); if( count_written < count_read || ferror(istream) ) { ___result = ___FAL; /* something bad happened -- abort */ break; } if( !feof(istream) ) continue; ___result = ___EOF; break; } } else { /* copy count bytes */ ___result = ___FIX(0); while(count>0) { int count_to_read = count < sizeof(buffer) ? count : sizeof(buffer); int count_read = fread(buffer,1,count_to_read,istream); int count_written = 0; if( count_read > 0 ) count_written = fwrite(buffer,1,count_read,ostream), count -= count_written; if( count_written < count_read || ferror(istream) ) { ___result = ___FAL; /* something bad happened -- abort */ break; } if( !feof(istream) ) continue; ___result = ___EOF; break; } } } ")) (lambda (in-port out-port . maxchars) (let ((count (and (pair? maxchars) (car maxchars)))) (cond ((and (OS:stream-port? in-port) (OS:stream-port? out-port)) (or (stream-port-copy (port-input-stream in-port) (port-output-stream out-port) (or count -1)) (##signal '##signal.io-error "IO error on" in-port))) (count ; count was given, slow path (let loop ((count count)) (if (positive? count) (let ((c (##read-char in-port))) (if (##eof-object? c) c (begin (##write-char c out-port) (loop (-- count))))) 0))) (else ; copy till EOF, slow path (do ((c (##read-char in-port) (##read-char in-port))) ((##eof-object? c) c) (##write-char c out-port)))))) )) ; procedure+: OS:set-keep-alive port ; ; If the port is connected to a stream that is opened on a socket that ; supports keep-alive, activate the keep-alive feature. ; If the keep-alive option is set, when the protocol determines that ; the port connection is broken, it sends a SIGPIPE signel to the process. ; The signal is fatal if uncaught. See "man setsockopt" for more detail. ; If the port, stream, or the protocol do not support the keep-alive ; option, this procedure does nothing. ; Return result: a boolean indicating if the keep-alive option has been ; successfully set. (c-declare "#include ") (define (OS:set-keep-alive port) (and (OS:stream-port? port) ((c-lambda ((pointer "___STREAM")) scheme-object " FILE *stream = ___arg1 == 0 ? 0 : ___arg1->stdio_stream; if (stream == 0) /* stream is closed? */ ___result = ___FAL; else { int fh = fileno(stream); int value = 1; ___result = setsockopt(fh, SOL_SOCKET, SO_KEEPALIVE, (char*)&value, sizeof(value)) < 0 ? ___FAL : ___TRU; } ") (port-input-stream port)))) ; procedure+: OS:ftell port -> INT or #f ; ; If the port is connected to an input or output stream, ; return the position in that stream. ; Otherwise, return #f. ; Raise an IO error if ftell reports an error. ; ; We should take care to decrement the position if the lookahead ; buffer is not empty. (define (OS:ftell port) (let ((stream (cond ((output-port? port) (and (OS:stream-port? port) (port-output-stream port))) ((input-port? port) (and (OS:stream-port? port) (port-input-stream port))) (else (error "OS:ftell - the argument is not a port"))))) (and stream (let ((res ((c-lambda ((pointer "___STREAM")) unsigned-long " FILE *stream = ___arg1 == 0 ? 0 : ___arg1->stdio_stream; errno = 0; if (stream == 0) /* stream is closed? */ errno = EBADF, ___result = 0; else { if( (___result = ftell(stream)) == (unsigned long)(-1) ) ___result = 0; if( ___result > 0 && ___CHARP(___arg1->lookahead) ) ___result--; } ") stream))) (if (zero? res) (if (not (zero? (OS:errno))) (##signal '##signal.io-error "ftell error" port) res) res))))) ; procedure+: OS:fseek-abs port pos -> pos or #f ; ; If the port is connected to an input or output stream, ; set the current absolute position to 'pos' and return 'pos'. ; Otherwise, return #f. ; Raise an IO error if fseek reports an error. (define (OS:fseek-abs port pos) (let ((stream (cond ((input-port? port) (and (OS:stream-port? port) (port-input-stream port))) ((output-port? port) (and (OS:stream-port? port) (port-output-stream port))) (else (error "OS:fseek-abs - the argument is not a port"))))) (and stream (let ((res ((c-lambda ((pointer "___STREAM") unsigned-long) unsigned-long " FILE *stream = ___arg1 == 0 ? 0 : ___arg1->stdio_stream; errno = 0; if (stream == 0) /* stream is closed? */ errno = EBADF, ___result = 0; else { ___arg1->lookahead = ___FAL; /* Drop look-ahead */ ___result = ___arg2; if( fseek(stream,___arg2,SEEK_SET) < 0 ) ___result = 0; } ") stream pos))) (if (zero? res) (if (not (zero? (OS:errno))) (##signal '##signal.io-error "fseek error" port) res) res))))) ;---------------------------------------------------------------------------- ; Process/environment queries ; return a real-user-ID of the current process (define OS:getuid (c-lambda () int "getuid")) ; return an effective-user-ID of the current process (define OS:geteuid (c-lambda () int "geteuid")) ; return a real-group-ID of the current process (define OS:getgid (c-lambda () int "getgid")) ; return an effective-group-ID of the current process (define OS:getegid (c-lambda () int "getegid")) ; Quering process IDs ; returns the process ID of the calling process (define OS:getpid (c-lambda () int "getpid")) ; returns the process ID of its parent (define OS:getppid (c-lambda () int "getppid")) ; returns the process group ID of the calling process (define OS:getpgrp (c-lambda () int "getpgrp")) (define OS:getenv (c-lambda (char-string) char-string "getenv")) (define OS:putenv (c-lambda (char-string char-string) void "const char * env_string = malloc(strlen(___arg1)+strlen(___arg2)+3); assert(env_string); sprintf(env_string,\"%s=%s\",___arg1,___arg2); assert(putenv(env_string) == 0);")) ;---------------------------------------------------------------------------- ; OS error handling (define OS:strerror (c-lambda () char-string "___result = strerror(errno);")) (define OS:errno (c-lambda () int "___result = errno;")) ;---------------------------------------------------------------------------- ; Formatting functions ; Like a regular sprintf, but with only one, flonum argument (define OS:flonum->sprintf ; format-string flonum (c-lambda (char-string double) char-string "static char buffer[100]; sprintf(buffer,___arg1,___arg2); ___result = buffer;")) ; Like a regular sprintf, but with only one, int argument (define OS:int->sprintf ; format-string int (fixnum) (c-lambda (char-string int) char-string "static char buffer[100]; sprintf(buffer,___arg1,___arg2); ___result = buffer;")) ; OS:strtod string ; Like the UNIX strtod() function: read a flonum ; from a string ; Returns a pair: (cons val stop-pos) ; where val is the value read, stop-pos is ; the position after the last char read from the str ; if stop-pos = 0: conversion failed ; if stop-pos = (string-length str): the entire string ; has been read (define (OS:strtod str) (let* ((rv (cons #f #f)) (val ((c-lambda (char-string scheme-object) double "char * p_end; ___result = strtod(___arg1,&p_end); ___SETCDR(___arg2,___FIX((p_end - ___arg1)));") str rv))) (set-car! rv val) rv)) ;---------------------------------------------------------------------------- ; Interprocess communication and synchronization ; Procedure+: OS:within-critical-section ID THUNK ; ; Execute the THUNK within a critical section named ID. If one OS process ; is within a critical section, all other processes/threads that try to enter ; the same critical section (with the same ID) would be blocked. ; ; At present, a critical section lock is implemented via an file exclusive ; lock. The ID then must be a string, the name of this file. The file ; would be open for writing (or created if necessary), and locked in an ; exclusive mode. The file would not be deleted after the procedure is over. ; It is the responsibility of the user to make sure the file with a given ; name (path name) can actually be created and opened. ; The result of the THUNK is returned. (define (OS:within-critical-section id thunk) ; Open a file returning its OS handle (define open-file ; fname (c-lambda (char-string) int "___result = open(___arg1,O_WRONLY|O_CREAT,0777);")) (define close-file ; file-handle (c-lambda (int) void "close(___arg1);")) (define lock-file ; file-handle (c-lambda (int) bool "___result = !lockf(___arg1,F_LOCK,0);")) (let ((section-id ; an id of the section: an OS file ; handle in our case (open-file id))) (cond ((negative? section-id) (##signal '##SIGNAL.IO-ERROR "IO error: " (OS:strerror) " while opening or creating a 'lock' file " id)) ((not (lock-file section-id)) (##signal '##SIGNAL.IO-ERROR "IO error: " (OS:strerror) " while locking the file " id)) (else (let ((result (thunk))) (close-file section-id) result))))) ; Procedure+: OS:within-timeout TIMEOUT THUNK ; ; Execute the THUNK after setting an alarm timer to expire in TIMEOUT ; seconds. If the THUNK finishes before the timer expires, its result is ; returned, the timer is reset and the previous alarm handler is restored. ; Otherwise, the alarm triggers, and the ___raise_interrupt (___INTR_USER) ; is called. Gambit's kernel will relay this interrupt to an appropriate ; Gambit signal handler in effect. See ##catch-signal for more details. (c-declare "#include typedef void (*SIGNAL_HANDLER)(int); static SIGNAL_HANDLER original_alarm_handler = SIG_DFL; static void set_our_alarm(const unsigned int timeout_interval); int ALARM_RAISED = 0; static void our_sigalarm_handler(int x) { ALARM_RAISED=1; /*___raise_interrupt (___INTR_USER);*/ } static void set_our_alarm(const unsigned int timeout_interval) { ALARM_RAISED = 0; if( timeout_interval > 0 ) { #if !defined(SA_RESETHAND) /* Obsolete interface */ original_alarm_handler = signal(SIGALRM,our_sigalarm_handler); #else /* prevent open(2) and read(2) from being restarted*/ struct sigaction action, old_action; memset(&action,0,sizeof(action)); action.sa_handler = our_sigalarm_handler; action.sa_flags = SA_RESETHAND; if( sigaction(SIGALRM,&action,&old_action) == 0 ) original_alarm_handler = old_action.sa_handler; #endif alarm(timeout_interval); } else /* reset the timer, restore the previous handler */ alarm(0), signal(SIGALRM,original_alarm_handler); } ") (define (OS:within-timeout timeout thunk) (define set-alarm ; seconds, 0 cancels a previously set alarm (c-lambda (unsigned-int) void "set_our_alarm")) (set-alarm timeout) (begin0 (thunk) (set-alarm 0))) ; Procedure+: OS:waitpid PID [option] -> [PID,status] or #f ; ; Wait for the child process PID. PID can be a child process PID (if positive), ; any process ID (if zero), a process in the current process group (if -1) ; or a process in a specific process group (if less than -1). ; option is currently a symbol 'NOHANG ; Return: ; a pair ; PID of the terminated child ; status of the terminated child ; If an error occurred, a signal is raised. ; If NOHANG option was given and all children are still running, return #f ; See "man waitpid" for more details. ; (c-declare "#include ") (define (OS:waitpid pid #!optional (option #f)) (let* ((option (cond ((not option) 0) ((eq? option 'NOHANG) ((c-lambda () int "___result = WNOHANG;"))) (else (error "OS:waitpid: Wrong option: " option)))) (rv (cons #f #f)) (result ((c-lambda (int int scheme-object) scheme-object " int status = 0; int rc = waitpid(___arg1,&status,___arg2); if (rc == 0) ___result = ___FAL; else if (rc < 0) ___result = ___FIX(errno); else { ___SETCAR(___arg3,___FIX(rc)); ___SETCDR(___arg3,___FIX(status)); ___result = ___TRU; } ") pid option rv))) (cond ((integer? result) (error "waitpid error, errno: " result)) ((eq? #t result) rv) (else result)))) ;---------------------------------------------------------------------------- ; Misc low-level functions ; Perform a linear transformation ax+b, where x is int, and the result must ; be int. a and b are floats (define OS:ax+b (c-lambda (int float float) int "___result = (int)(___arg1 * ___arg2 + ___arg3);")) ; Execute a command via 'system' system call (define (OS:system . args) ((c-lambda (char-string) void "if( system(___arg1) < 0 ) perror(\"failed 'system' call\"), exit(4);") (apply string-append args)))