From ea5725436eaf5ca4f9b46a6b10ab3c4557d5c59e Mon Sep 17 00:00:00 2001 From: marting Date: Wed, 28 Jun 2000 10:27:34 +0000 Subject: [PATCH] Added several cwd-aligns. with-env usees with-lock. Some corrections to getenv. --- scsh/newports.scm | 37 ++++++++++++++++++++----------------- scsh/scsh.scm | 13 ++++++------- scsh/syscalls.scm | 18 +++++++++++------- scsh/syscalls1.c | 46 +++++++++++++++++++++++++++++----------------- scsh/syscalls1.h | 2 +- 5 files changed, 67 insertions(+), 49 deletions(-) diff --git a/scsh/newports.scm b/scsh/newports.scm index 4699494..b7b20a8 100644 --- a/scsh/newports.scm +++ b/scsh/newports.scm @@ -227,7 +227,8 @@ (set-port-limit! port size) (set-port-buffer! port new-buffer)) -; TODO flush on stdinput is required +; TODO flush on stdinput is required but probably impossible since current-input-port is a fluid and may change without notice. One possibility would be to override (current-input-port) + ;;; This port can ONLY be flushed with a newline or a close-output ;;; flush-output won't help (define (make-line-output-proc size) @@ -339,12 +340,13 @@ ;;; replace rts/channel-port.scm begin (define (open-file fname flags . maybe-mode) - (let ((fd (apply open-fdes fname flags maybe-mode)) - (access (bitwise-and flags open/access-mask))) - ((if (or (= access open/read) (= access open/read+write)) - make-input-fdport - make-output-fdport) - fd 0))) + (with-cwd-aligned + (let ((fd (apply open-fdes fname flags maybe-mode)) + (access (bitwise-and flags open/access-mask))) + ((if (or (= access open/read) (= access open/read+write)) + make-input-fdport + make-output-fdport) + fd 0)))) (define (open-input-file fname . maybe-flags) (let ((flags (:optional maybe-flags 0))) @@ -641,16 +643,17 @@ (define (call-with-mumble-file open close) (lambda (string proc) - (let ((port #f)) - (dynamic-wind (lambda () - (if port - (warn "throwing back into a call-with-...put-file" - string) - (set! port (open string)))) - (lambda () (proc port)) - (lambda () - (if port - (close port))))))) + (with-cwd-aligned + (let ((port #f)) + (dynamic-wind (lambda () + (if port + (warn "throwing back into a call-with-...put-file" + string) + (set! port (open string)))) + (lambda () (proc port)) + (lambda () + (if port + (close port)))))))) ;;; replace rts/channel-port.scm begin (define call-with-input-file diff --git a/scsh/scsh.scm b/scsh/scsh.scm index 57f3c28..19b66bf 100644 --- a/scsh/scsh.scm +++ b/scsh/scsh.scm @@ -130,8 +130,6 @@ (%free-env (env:c-struct env))) (define env-lock (make-lock)) -(define (obtain-env-lock) (obtain-lock env-lock)) ; Thunks for -(define (release-env-lock) (release-lock env-lock)) ; DYNAMIC-WINDs. (define current-process-env #f) (define $current-env #f) @@ -153,9 +151,10 @@ (set! current-process-env current-env-val))))) (define (with-env-aligned* thunk) - (dynamic-wind obtain-env-lock - (lambda () (dynamic-wind align-env! thunk values)) - release-env-lock)) + (dynamic-wind (lambda () + (with-lock env-lock + align-env!)) + thunk values)) (define (with-total-env* alist thunk) (let-fluid $current-env (make-threads-env alist) thunk)) @@ -309,12 +308,12 @@ (process-chdir dir) (set-cache:cwd *unix-cwd* (process-cwd))) -;;; Dynamic-wind is not the rigth thing to take care of the lock; +;;; Dynamic-wind is not the right thing to take care of the lock; ;;; it would release the lock on every context switch. ;;; With-lock releases the lock on a condition, using call/cc will ;;; skrew things up -;;; Should be moved somewhere else +;;; Should be moved to somewhere else (define (with-lock lock thunk) (with-handler (lambda (condition more) (release-lock lock) diff --git a/scsh/syscalls.scm b/scsh/syscalls.scm index fbe7dae..33a6312 100644 --- a/scsh/syscalls.scm +++ b/scsh/syscalls.scm @@ -482,10 +482,11 @@ (define (file-info fd/port/fname . maybe-chase?) - (let ((chase? (:optional maybe-chase? #t))) - (receive (err info) (file-info/errno fd/port/fname chase?) - (if err (errno-error err file-info fd/port/fname chase?) - info)))) + (with-cwd-aligned + (let ((chase? (:optional maybe-chase? #t))) + (receive (err info) (file-info/errno fd/port/fname chase?) + (if err (errno-error err file-info fd/port/fname chase?) + info))))) (define file-attributes @@ -885,7 +886,7 @@ ;;; ENV->ALIST (define-foreign %load-env (scm_envvec) - desc)) + desc) (define (env->list) (%load-env)) @@ -924,6 +925,9 @@ (align_env (desc)) ignore) +(define-foreign %free-env + (free_envvec (desc)) + desc) ;;; GETENV, SETENV ;;; they all assume an aligned env @@ -941,8 +945,8 @@ "#define errno_on_nonzero_or_false(x) ((x) ? s48_enter_fixnum(errno) : S48_FALSE)" "" "") -(define-foreign envvec-delete-env (delete_env (string var)) - ignore) +(define-foreign envvec-delete-env (delete_env (desc var)) + desc) ;;; Fd-ports diff --git a/scsh/syscalls1.c b/scsh/syscalls1.c index 101fe2b..b4e940e 100644 --- a/scsh/syscalls1.c +++ b/scsh/syscalls1.c @@ -447,14 +447,28 @@ void align_env(s48_value pointer_to_struct) current_env = thread_env; } +s48_value free_envvec (s48_value pointer_to_struct) +{ + struct envvec* envv = (struct envvec*) s48_extract_integer(pointer_to_struct); + int i; + if (envv->revealed) + { + envv->gcable = 1; + return S48_FALSE; + } + for (i=0; isize; i++) + Free(envv->env[i]); + Free(envv->env); + Free(envv); + return S48_TRUE; +} - -int envvec_setenv(s48_value scheme_name, s48_value entry){ +s48_value envvec_setenv(s48_value scheme_name, s48_value entry){ char * name = s48_extract_string(scheme_name); int namelen = strlen(name); char **ptr = environ; char ** newenv; - int size = current_env->size; + int size; int number_of_entries = 0; char * newentry = Malloc(char, S48_STRING_LENGTH(entry) + 1); if ( !newentry) return s48_enter_fixnum(errno); @@ -463,7 +477,7 @@ int envvec_setenv(s48_value scheme_name, s48_value entry){ fprintf(stderr, "no current_env, giving up" ); exit (1); } - + size = current_env->size; while (*ptr){ if ( ( strncmp(*ptr, name, namelen) == 0) && (*ptr)[namelen] == '=') { @@ -498,14 +512,6 @@ int envvec_setenv(s48_value scheme_name, s48_value entry){ } } -//char** scm_envvec(int *len) /* Returns environ c-vector & its length. */ -//{ -// char **ptr=environ; -// while( *ptr ) ptr++; -// *len = ptr-environ; -// return(environ); -//} - s48_value scm_envvec(){ return char_pp_2_string_list(environ); } @@ -559,7 +565,7 @@ int create_env(s48_value vec, s48_value * envvec_addr) newenv = Malloc(char*, envsize+1); if( !newenv ) return errno; - thread_env = Malloc (struct envvec, 4); + thread_env = Malloc (struct envvec, 4); // TODO: why 4 ?? if( !thread_env ) { Free (newenv); return errno; @@ -591,17 +597,23 @@ int create_env(s48_value vec, s48_value * envvec_addr) } /* Delete the env var. */ -void delete_env(const char *var) +s48_value delete_env(s48_value name) { - int varlen = strlen(var); - char **ptr = environ-1; + int varlen = S48_STRING_LENGTH (name); + char * var = s48_extract_string (name); + char **ptr = environ; char **ptr2; - do if( !*++ptr ) return; + if (!current_env) { + fprintf(stderr, "no current_env, giving up" ); + exit (1); + } + do if( !*++ptr ) return S48_FALSE; while( strncmp(*ptr, var, varlen) || (*ptr)[varlen] != '=' ); ptr2 = ptr; while (*++ptr2); *ptr = *ptr2; *ptr2 = NULL; + return S48_TRUE; } diff --git a/scsh/syscalls1.h b/scsh/syscalls1.h index 9af659e..650d4fb 100644 --- a/scsh/syscalls1.h +++ b/scsh/syscalls1.h @@ -45,7 +45,7 @@ s48_value scm_envvec(void); int install_env(s48_value vec); -void delete_env(const char *var); +s48_value delete_env(s48_value var); s48_value scm_gethostname(void);