Update of /cvsroot/scsh/scsh-0.6/scsh
In directory usw-pr-cvs1:/tmp/cvs-serv3836/scsh
Modified Files:
scsh.scm syscalls.c syscalls.scm syscalls1.c syscalls1.h
Log Message:
Implement environment per thread via process-resource/thread-fluids.
Index: scsh.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/scsh.scm,v
retrieving revision 1.17
retrieving revision 1.18
diff -C2 -r1.17 -r1.18
*** scsh.scm 2001/07/10 14:52:57 1.17
--- scsh.scm 2001/08/06 08:33:24 1.18
***************
*** 52,56 ****
;;; Common code.
- ;; JMG: this should spawn a thread to prevent deadlocking the vm
(define (really-fork/pipe+ forker conns maybe-thunk)
(let* ((pipes (map (lambda (conn) (call-with-values pipe cons))
--- 52,55 ----
***************
*** 114,286 ****
- ;;; Environment stuff
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (define-record env
- c-struct ; An alien -- pointer to an envvec struct
- alist) ; Corresponding alist
-
- ;;; Once more, Olin's define-record is not sufficient
- (define (make-environ c-struct alist)
- (let ((env (make-env c-struct alist)))
- (add-finalizer! env env-finalizer)
- env))
-
- (define (env-finalizer env)
- (display "freeing env")
- (%free-env (env:c-struct env)))
-
- (define env-lock (make-lock))
-
- (define current-process-env #f)
- (define $current-env #f)
- (define (install-env)
- (set! current-process-env
- (make-threads-env (environ-env->alist)))
- (set! $current-env (make-fluid current-process-env))
- (%align-env (env:c-struct (current-env))))
-
- (define (make-threads-env alist)
- (make-environ (alist->envvec alist) alist))
-
- (define (current-env) (fluid $current-env))
-
- (define (align-env!)
- (let ((current-env-val (current-env)))
- (if (not (eq? current-env-val current-process-env))
- (begin (%align-env (env:c-struct current-env-val))
- (set! current-process-env current-env-val)))))
-
- (define (with-env-aligned* thunk)
- (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))
-
- (define (with-env* alist-delta thunk)
- (let ((new-env (fold (lambda (key/val alist)
- (alist-update (car key/val) (cdr key/val) alist))
- (env->alist)
- alist-delta)))
- (let-fluid $current-env (make-threads-env new-env) thunk)))
-
- ;(define (lp) (display (getenv "BLA")) (sleep 2000) (lp))
-
- (define (env->alist)
- (with-env-aligned*
- (lambda ()
- (environ-env->alist))))
-
- (define (alist->env alist)
- (with-env-aligned*
- (lambda ()
- (let ((env (current-env)))
- (envvec-alist->env alist)
- (set-env:alist env alist)))))
-
- (define (delete-env name)
- (let ((env (current-env)))
- (set-env:alist env (alist-delete name (env:alist env))))
- (envvec-delete-env name))
-
- (define (setenv name value)
- (with-env-aligned*
- (lambda ()
- (if value
- (begin
- (envvec-setenv name value)
- (let ((env (current-env)))
- (set-env:alist env (alist-update name value (env:alist env)))))
- (delete-env name)))))
-
- (define (getenv name)
- (with-env-aligned*
- (lambda ()
- (let* ((here (assoc name (env:alist (current-env))))
- (here (if here (cdr here) here)))
- (if (not (equal? here (envvec-getenv name)))
- (error "not equal" here (envvec-getenv name))
- here)))))
-
-
- ;;; These two functions are obsoleted by the more general INFIX-SPLITTER and
- ;;; JOIN-STRINGS functions. However, we keep SPLIT-COLON-LIST defined
- ;;; internally so the top-level startup code (INIT-SCSH) can use it
- ;;; to split up $PATH without requiring the field-splitter or regexp code.
-
- (define (split-colon-list clist)
- (let ((len (string-length clist)))
- (if (= 0 len) '() ; Special case "" -> ().
-
- ;; Main loop.
- (let split ((i 0))
- (cond ((string-index clist #\: i) =>
- (lambda (colon)
- (cons (substring clist i colon)
- (split (+ colon 1)))))
- (else (list (substring clist i len))))))))
-
- ;;; Unix colon lists typically use colons as separators, which
- ;;; is not as clean to deal with as terminators, but that's Unix.
- ;;; Note ambiguity: (s-l->c-l '()) = (s-l->c-l '("")) = "".
-
- ; (define (string-list->colon-list slist)
- ; (if (pair? slist)
- ; (apply string-append
- ; (let colonise ((lis slist)) ; LIS is always
- ; (let ((tail (cdr lis))) ; a pair.
- ; (cons (car lis)
- ; (if (pair? tail)
- ; (cons ":" (colonise tail))
- ; '())))))
- ; "")) ; () case.
-
-
- (define (alist-delete key alist)
- (filter (lambda (key/val) (not (equal? key (car key/val)))) alist))
-
- (define (alist-update key val alist)
- (cons (cons key val)
- (alist-delete key alist)))
-
- ;;; Remove shadowed entries from ALIST. Preserves element order.
- ;;; (This version shares no structure.)
-
- (define (alist-compress alist)
- (reverse (let compress ((alist alist) (ans '()))
- (if (pair? alist)
- (let ((key/val (car alist))
- (alist (cdr alist)))
- (compress alist (if (assoc (car key/val) ans) ans
- (cons key/val ans))))
- ans))))
-
- (define (add-before elt before list)
- (let rec ((list list))
- (if (pair? list)
- (let ((x (car list)))
- (if (equal? x before)
- (cons elt list)
- (cons x (rec (cdr list)))))
- (cons elt list))))
-
- ;;; In ADD-AFTER, the labelled LET adds ELT after the last occurrence of AFTER
- ;;; in LIST, and returns the list. However, if the LET finds no occurrence
- ;;; of AFTER in LIST, it returns #F instead.
-
- (define (add-after elt after list)
- (or (let rec ((list list))
- (if (pair? list)
- (let* ((x (car list))
- (tail (cdr list))
- (ans (rec tail))) ; #f if AFTER wasn't encountered.
- (cond (ans (cons x ans))
- ((equal? x after)
- (cons x (cons elt tail)))
- (else #f))) ; AFTER doesn't appear in LIST.
- #f)) ; AFTER doesn't appear in LIST.
- (cons elt list)))
;;; Should be moved to somewhere else
--- 113,116 ----
***************
*** 294,307 ****
(release-lock lock)
result))))
;;; A resource is a part of the process state for which every thread
;;; has its own value
(define-syntax make-process-resource
(syntax-rules ()
((make-process-resource
initialize-resource
! thread-read-resource thread-set-resource with-resource*
! with-resource-aligned* process-read-resource process-set-resource)
(begin
(define *resource-cache* 'uninitialized)
--- 124,152 ----
(release-lock lock)
result))))
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A resource is a part of the process state for which every thread
;;; has its own value
+ ;;; uses the procedures:
+ ;;; (process-read-resource (-> 'X))
+ ;;; (process-set-resource ('X -> unspec))
+ ;;; (resource-eq? ('X 'X -> bool))
+
+ ;;; defines the procedures:
+ ;;; (initialize-resource (-> unspec)) ; call on startup
+ ;;; (with-resource* ((-> 'X) -> 'X))
+ ;;; (with-resource-aligned* ((-> 'X) -> 'X))
+ ;;; (thread-read-resource (-> 'X))
+ ;;; (thread-set-resource ('X -> unspec))
+
(define-syntax make-process-resource
(syntax-rules ()
((make-process-resource
initialize-resource
! thread-read-resource thread-set-resource! thread-change-resource
! with-resource* with-resource-aligned*
! process-read-resource process-set-resource resource-eq?)
(begin
(define *resource-cache* 'uninitialized)
***************
*** 310,313 ****
--- 155,161 ----
(define (initialize-resource)
(set! *resource-cache* (process-read-resource))
+ (set! $resource ;;; TODO The old thread-fluid will remain
+ (make-thread-fluid
+ (process-read-resource)))
(set! resource-lock (make-lock)))
***************
*** 328,337 ****
;;; The thread-specific resource: A thread fluid
! (define $resource
! (make-thread-fluid
! (process-read-resource)))
(define (thread-read-resource) (thread-fluid $resource))
! (define (set-resource! dir) (set-thread-fluid! $resource dir))
(define (let-resource dir thunk)
(let-thread-fluid $resource dir thunk))
--- 176,183 ----
;;; The thread-specific resource: A thread fluid
! (define $resource 'emtpy-resource-value)
(define (thread-read-resource) (thread-fluid $resource))
! (define (thread-set-resource! dir) (set-thread-fluid! $resource dir))
(define (let-resource dir thunk)
(let-thread-fluid $resource dir thunk))
***************
*** 352,363 ****
(define (align-resource!)
(let ((dir (thread-read-resource)))
! (if (not (string=? dir (cache-value)))
! (change-and-cache dir))))
! (define (thread-set-resource dir)
(with-lock resource-lock
(lambda ()
(change-and-cache dir)
! (set-resource! (cache-value)))))
;;; For thunks that don't raise exceptions or throw to continuations,
--- 198,209 ----
(define (align-resource!)
(let ((dir (thread-read-resource)))
! (if (not (resource-eq? dir (cache-value)))
! (change-and-cache dir))))
! (define (thread-change-resource dir)
(with-lock resource-lock
(lambda ()
(change-and-cache dir)
! (thread-set-resource! (cache-value)))))
;;; For thunks that don't raise exceptions or throw to continuations,
***************
*** 386,396 ****
(define resource-reinitializer
! (make-reinitializer initialize-resource))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; working directory per thread
(make-process-resource
! initialize-cwd cwd chdir with-cwd* with-cwd-aligned*
! process-cwd process-chdir)
(initialize-cwd)
--- 232,242 ----
(define resource-reinitializer
! (make-reinitializer (lambda () (warn "calling resumer")
(initialize-resource))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; working directory per thread
(make-process-resource
! initialize-cwd cwd thread-set-cwd! chdir with-cwd* with-cwd-aligned*
! process-cwd process-chdir string=?)
(initialize-cwd)
***************
*** 400,407 ****
(make-process-resource
! initialize-umask umask set-umask with-umask* with-umask-aligned*
! process-umask set-process-umask)
(initialize-umask)
;;; Sugar:
--- 246,413 ----
(make-process-resource
! initialize-umask umask thread-set-umask set-umask
! with-umask* with-umask-aligned*
! process-umask set-process-umask =)
(initialize-umask)
+
+
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;; Environment per thread
+
+ (define-record env
+ envvec
+ alist) ; Corresponding alist
+
+ (define-record-discloser type/env
+ (lambda (e)
+ (list 'env (env:envvec e) (env:alist e))))
+
+ (define (env=? e1 e2)
+ (and (env:envvec e1)
+ (eq? (env:envvec e1)
+ (env:envvec e2))))
+
+ (define-record envvec
+ environ ;; char**
+ )
+
+ (define (add-envvec-finalizer! envvec)
+ (add-finalizer! envvec envvec-finalizer))
+
+ (define-exported-binding "envvec-record-type" type/envvec)
+ (define-exported-binding "add-envvec-finalizer!" add-envvec-finalizer!)
+
+ (define (envvec-finalizer envvec)
+ (%free-env envvec))
+
+ (define (environ**-read)
+ (let ((alist.envvec (environ-env->alist)))
+ (make-env (cdr alist.envvec) (car alist.envvec))))
+
+ (define (environ**-set env)
+ (if (env:envvec env)
+ (%align-env (env:envvec env))
+ (set-env:envvec env (envvec-alist->env (env:alist env)))))
+
+ (define (getenv var)
+ (let* ((env (thread-read-env))
+ (res (assoc var (env:alist env))))
+ (if res (cdr res) res)))
+
+ (define (env->alist)
+ (env:alist (thread-read-env)))
+
+ (define (setenv var val)
+ (let* ((env (thread-read-env))
+ (alist (alist-update
+ var
+ val
+ (fold cons '() (env:alist env)))))
+ (thread-set-env!
+ (make-env
+ #f
+ alist
+ ))))
+
+ (define (alist->env alist)
+ (thread-set-env!
+ (make-env
+ #f
+ alist)))
+
+ (define (with-env* alist-delta thunk)
+ (let ((new-env (fold (lambda (key/val alist)
+ (alist-update (car key/val) (cdr key/val) alist))
+ (env->alist)
+ alist-delta)))
+ (with-total-env* new-env thunk)))
+
+ (define (with-total-env* alist thunk)
+ (with-env-internal* (make-env #f alist) thunk))
+
+ (make-process-resource install-env thread-read-env thread-set-env!
+ useless-set-env
+ with-env-internal* with-env-aligned*
+ environ**-read environ**-set env=?)
+
+ ;;; These two functions are obsoleted by the more general INFIX-SPLITTER and
+ ;;; JOIN-STRINGS functions. However, we keep SPLIT-COLON-LIST defined
+ ;;; internally so the top-level startup code (INIT-SCSH) can use it
+ ;;; to split up $PATH without requiring the field-splitter or regexp code.
+
+ (define (split-colon-list clist)
+ (let ((len (string-length clist)))
+ (if (= 0 len) '() ; Special case "" -> ().
+
+ ;; Main loop.
+ (let split ((i 0))
+ (cond ((string-index clist #\: i) =>
+ (lambda (colon)
+ (cons (substring clist i colon)
+ (split (+ colon 1)))))
+ (else (list (substring clist i len))))))))
+
+ ;;; Unix colon lists typically use colons as separators, which
+ ;;; is not as clean to deal with as terminators, but that's Unix.
+ ;;; Note ambiguity: (s-l->c-l '()) = (s-l->c-l '("")) = "".
+
+ ; (define (string-list->colon-list slist)
+ ; (if (pair? slist)
+ ; (apply string-append
+ ; (let colonise ((lis slist)) ; LIS is always
+ ; (let ((tail (cdr lis))) ; a pair.
+ ; (cons (car lis)
+ ; (if (pair? tail)
+ ; (cons ":" (colonise tail))
+ ; '())))))
+ ; "")) ; () case.
+
+
+ (define (alist-delete key alist)
+ (filter (lambda (key/val) (not (equal? key (car key/val)))) alist))
+
+ (define (alist-update key val alist)
+ (cons (cons key val)
+ (alist-delete key alist)))
+
+ ;;; Remove shadowed entries from ALIST. Preserves element order.
+ ;;; (This version shares no structure.)
+
+ (define (alist-compress alist)
+ (reverse (let compress ((alist alist) (ans '()))
+ (if (pair? alist)
+ (let ((key/val (car alist))
+ (alist (cdr alist)))
+ (compress alist (if (assoc (car key/val) ans) ans
+ (cons key/val ans))))
+ ans))))
+
+ (define (add-before elt before list)
+ (let rec ((list list))
+ (if (pair? list)
+ (let ((x (car list)))
+ (if (equal? x before)
+ (cons elt list)
+ (cons x (rec (cdr list)))))
+ (cons elt list))))
+
+ ;;; In ADD-AFTER, the labelled LET adds ELT after the last occurrence of AFTER
+ ;;; in LIST, and returns the list. However, if the LET finds no occurrence
+ ;;; of AFTER in LIST, it returns #F instead.
+
+ (define (add-after elt after list)
+ (or (let rec ((list list))
+ (if (pair? list)
+ (let* ((x (car list))
+ (tail (cdr list))
+ (ans (rec tail))) ; #f if AFTER wasn't encountered.
+ (cond (ans (cons x ans))
+ ((equal? x after)
+ (cons x (cons elt tail)))
+ (else #f))) ; AFTER doesn't appear in LIST.
+ #f)) ; AFTER doesn't appear in LIST.
+ (cons elt list)))
+
;;; Sugar:
***************
*** 892,896 ****
(define (really-fork clear-interactive? maybe-thunk)
! (((structure-ref interrupts with-interrupts-inhibited) (lambda ()
(let ((pid (%%fork)))
(if (zero? pid)
--- 898,905 ----
(define (really-fork clear-interactive? maybe-thunk)
! (with-env-aligned* ; not neccessary here but doing it on exec
! ; genereates no cache in the parent
! (lambda ()
! (((structure-ref interrupts with-interrupts-inhibited) (lambda ()
(let ((pid (%%fork)))
(if (zero? pid)
***************
*** 908,912 ****
;; Parent
(let ((proc (new-child-proc pid)))
! (lambda () proc))))))))
--- 917,921 ----
;; Parent
(let ((proc (new-child-proc pid)))
! (lambda () proc))))))))))
Index: syscalls.c
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/syscalls.c,v
retrieving revision 1.12
retrieving revision 1.13
diff -C2 -r1.12 -r1.13
*** syscalls.c 2001/06/01 16:22:26 1.12
--- syscalls.c 2001/08/06 08:33:24 1.13
***************
*** 652,781 ****
}
- s48_value df_scm_envvec(void)
- {
- extern s48_value scm_envvec(void);
- s48_value ret1 = S48_FALSE;
- S48_DECLARE_GC_PROTECT(1);
- s48_value r1;
-
-
-
- S48_GC_PROTECT_1(ret1);
- r1 = scm_envvec();
- ret1 = r1;
- S48_GC_UNPROTECT();
- return ret1;
- }
-
- s48_value df_install_env(s48_value g1)
- {
- extern int install_env(s48_value );
- s48_value ret1 = S48_FALSE;
- S48_DECLARE_GC_PROTECT(1);
- int r1;
-
-
-
- S48_GC_PROTECT_1(ret1);
- r1 = install_env(g1);
- ret1 = errno_or_false(r1);
- S48_GC_UNPROTECT();
- return ret1;
- }
-
- s48_value df_create_env(s48_value g1, s48_value mv_vec)
- {
- extern int create_env(s48_value , s48_value *);
- s48_value ret1 = S48_FALSE;
- S48_DECLARE_GC_PROTECT(2);
- int r1;
- s48_value r2 = 0;
-
-
-
- S48_GC_PROTECT_2(mv_vec,ret1);
- r1 = create_env(g1, &r2);
- ret1 = errno_or_false(r1);
- S48_VECTOR_SET(mv_vec,0,r2);
- S48_GC_UNPROTECT();
- return ret1;
- }
-
- s48_value df_align_env(s48_value g1)
- {
- extern void align_env(s48_value );
-
-
- align_env(g1);
- return S48_FALSE;
- }
-
- s48_value df_free_envvec(s48_value g1)
- {
- extern s48_value free_envvec(s48_value );
- s48_value ret1 = S48_FALSE;
- S48_DECLARE_GC_PROTECT(1);
- s48_value r1;
-
-
-
- S48_GC_PROTECT_1(ret1);
- r1 = free_envvec(g1);
- ret1 = r1;
- S48_GC_UNPROTECT();
- return ret1;
- }
-
- s48_value df_envvec_setenv(s48_value g1, s48_value g2)
- {
- extern s48_value envvec_setenv(s48_value , s48_value );
- s48_value ret1 = S48_FALSE;
- S48_DECLARE_GC_PROTECT(1);
- s48_value r1;
-
-
-
- S48_GC_PROTECT_1(ret1);
- r1 = envvec_setenv(g1, g2);
- ret1 = r1;
- S48_GC_UNPROTECT();
- return ret1;
- }
-
- s48_value df_getenv(s48_value g1, s48_value mv_vec)
- {
- extern char *getenv(const char *);
- s48_value ret1 = S48_FALSE;
- S48_DECLARE_GC_PROTECT(2);
- char *r1;
-
-
-
- S48_GC_PROTECT_2(mv_vec,ret1);
- r1 = getenv(s48_extract_string(g1));
- ret1 = S48_VECTOR_REF(mv_vec,0);
- SetAlienVal(S48_CAR(ret1),(long) r1);
S48_SET_CDR(ret1,strlen_or_false(r1));//str-and-len
- S48_GC_UNPROTECT();
- return ret1;
- }
-
- #define errno_on_nonzero_or_false(x) ((x) ? s48_enter_fixnum(errno) :
S48_FALSE)
-
- s48_value df_delete_env(s48_value g1)
- {
- extern s48_value delete_env(s48_value );
- s48_value ret1 = S48_FALSE;
- S48_DECLARE_GC_PROTECT(1);
- s48_value r1;
-
-
-
- S48_GC_PROTECT_1(ret1);
- r1 = delete_env(g1);
- ret1 = r1;
- S48_GC_UNPROTECT();
- return ret1;
- }
-
s48_value df_sleep_until(s48_value g1)
{
--- 652,655 ----
***************
*** 873,884 ****
S48_EXPORT_FUNCTION(df_open_dir);
S48_EXPORT_FUNCTION(df_scm_sort_filevec);
! S48_EXPORT_FUNCTION(df_scm_envvec);
! S48_EXPORT_FUNCTION(df_install_env);
! S48_EXPORT_FUNCTION(df_create_env);
! S48_EXPORT_FUNCTION(df_align_env);
! S48_EXPORT_FUNCTION(df_free_envvec);
! S48_EXPORT_FUNCTION(df_envvec_setenv);
! S48_EXPORT_FUNCTION(df_getenv);
! S48_EXPORT_FUNCTION(df_delete_env);
S48_EXPORT_FUNCTION(set_cloexec);
S48_EXPORT_FUNCTION(fcntl_read);
--- 747,754 ----
S48_EXPORT_FUNCTION(df_open_dir);
S48_EXPORT_FUNCTION(df_scm_sort_filevec);
! S48_EXPORT_FUNCTION(scm_envvec);
! S48_EXPORT_FUNCTION(create_env);
! S48_EXPORT_FUNCTION(align_env);
! S48_EXPORT_FUNCTION(free_envvec);
S48_EXPORT_FUNCTION(set_cloexec);
S48_EXPORT_FUNCTION(fcntl_read);
Index: syscalls.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/syscalls.scm,v
retrieving revision 1.23
retrieving revision 1.24
diff -C2 -r1.23 -r1.24
*** syscalls.scm 2001/07/10 14:52:57 1.23
--- syscalls.scm 2001/08/06 08:33:24 1.24
***************
*** 809,874 ****
;;; ENV->ALIST
! (define-foreign %load-env (scm_envvec)
! desc)
- (define (env->list)
- (%load-env))
-
(define (environ-env->alist)
! (env-list->alist (env->list)))
!
;;; ALIST->ENV
-
- (define-foreign %install-env/errno
- (install_env (vector-desc env-vec))
- (to-scheme integer errno_or_false))
! (define-errno-syscall (%install-env env-vec) %install-env/errno)
;;; assumes aligned env
(define (envvec-alist->env alist)
- (%install-env (alist->env-vec alist)))
-
- ;;; create new env for thread
- (define-foreign %create-env/errno
- (create_env (vector-desc env-vec))
- (to-scheme integer errno_or_false)
- desc)
-
- (define-errno-syscall (%create-env env-vec)
- %create-env/errno
- bvec)
-
- (define (alist->envvec alist)
(%create-env (alist->env-vec alist)))
-
- (define-foreign %align-env
- (align_env (desc))
- ignore)
-
- (define-foreign %free-env
- (free_envvec (desc))
- desc)
- ;;; GETENV, SETENV
- ;;; they all assume an aligned env
-
-
- (define-foreign %envvec-setenv (envvec_setenv (desc name) (desc entry))
- desc)
-
- (define (envvec-setenv name value)
- (%envvec-setenv name (string-append name "=" value)))
-
- (define-foreign envvec-getenv (getenv (string var))
- static-string)
! (foreign-source
! "#define errno_on_nonzero_or_false(x) ((x) ? s48_enter_fixnum(errno) :
S48_FALSE)"
! "" "")
! (define-foreign envvec-delete-env (delete_env (desc var))
! desc)
--- 809,832 ----
;;; ENV->ALIST
! (define-stubless-foreign %load-env () "scm_envvec")
(define (environ-env->alist)
! (let ((env-list.envvec (%load-env)))
! (cons (env-list->alist (car env-list.envvec))
! (cdr env-list.envvec))))
;;; ALIST->ENV
! ;;; (%create-env ((vector 'X) -> address))
! (define-stubless-foreign %create-env (envvec) "create_env")
;;; assumes aligned env
(define (envvec-alist->env alist)
(%create-env (alist->env-vec alist)))
! (define-stubless-foreign %align-env (envvec) "align_env")
! (define-stubless-foreign %free-env (envvec) "free_envvec")
Index: syscalls1.c
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/syscalls1.c,v
retrieving revision 1.17
retrieving revision 1.18
diff -C2 -r1.17 -r1.18
*** syscalls1.c 2001/06/19 11:33:08 1.17
--- syscalls1.c 2001/08/06 08:33:24 1.18
***************
*** 492,513 ****
*******************************************************************************
*/
! struct envvec {
! char **env; /* Null-terminated vector of strings. Malloc'd. */
! int size; /* Length of env. */
! int revealed; /* True => exported to C code */
! int gcable; /* True => no pointers to us from Scheme heap.
*/
! };
! /* Note that the SIZE field tells you how many words of memory are allocated
! ** for the block of memory to which the ENV field points. This includes the
! ** terminating null pointer, and may include more words beyond that. It is
! ** *not* the number of strings stored in ENV; it is always greater than this
! ** value.
! **
! ** The REVEALED field is incremented if either the ENV block or the entire
! ** struct is handed out to C code.
! **
! ** If the structure becomes gc'able, but is REVEALED (hence cannot be freed),
! ** the GC simply sets GCABLE and forgets about it.
! */
/* The envvec corresponding to the current environment.
--- 492,500 ----
*******************************************************************************
*/
! static s48_value envvec_record_type_binding = S48_FALSE;
! static s48_value add_envvec_finalizerB_binding = S48_FALSE;
!
! #define ENVVEC_ENVIRON(envvec) \
! ((char**) s48_extract_integer(S48_RECORD_REF((envvec),0)))
/* The envvec corresponding to the current environment.
***************
*** 517,668 ****
** !current_env || current_env->env == environ
*/
! struct envvec *current_env = 0;
! void align_env(s48_value pointer_to_struct)
{
! struct envvec* thread_env;
! thread_env = (struct envvec*) s48_extract_integer(pointer_to_struct);
! environ = thread_env->env;
! 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; i<envv->size; i++)
! Free(envv->env[i]);
! Free(envv->env);
! Free(envv);
return S48_TRUE;
}
! 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;
! int number_of_entries = 0;
! char * newentry = Malloc(char, S48_STRING_LENGTH(entry) + 1);
! if ( !newentry) return s48_enter_fixnum(errno);
!
! if (!current_env) {
! fprintf(stderr, "no current_env, giving up" );
! exit (1);
! }
! size = current_env->size;
! while (*ptr){
! if ( ( strncmp(*ptr, name, namelen) == 0) && (*ptr)[namelen] == '=')
! {
! *ptr = strcpy(newentry,s48_extract_string(entry));
! return S48_FALSE;
! }
! ptr++;
! number_of_entries++;
! }
! if (number_of_entries >= size) { // I never had this problem, but...
! fprintf(stderr, "currupt env, giving up %d %d", number_of_entries,size);
! exit (1);
! }
! else if (number_of_entries < (size - 1)) // is space left after the NULL ?
! {
! *ptr = strcpy(newentry,s48_extract_string(entry));
! *++ptr = NULL;
! return S48_FALSE;
! }
! else // number_of_entries == (size - 1)
! {
! int newsize = size + 1; // TODO: add more
! char ** newenv = Malloc (char *, newsize);
! if( !newenv) return s48_enter_fixnum(errno);
! current_env->env = newenv;
! current_env->size = newsize;
! memcpy(newenv, environ, number_of_entries * sizeof (char *));
! newenv[number_of_entries] = strcpy(newentry, s48_extract_string(entry));
! newenv[number_of_entries + 1] = NULL;
! environ = newenv;
! return S48_FALSE;
! }
}
s48_value scm_envvec(){
! return char_pp_2_string_list(environ);
}
/* Load the (Scheme) strings in the (Scheme) vector VEC into environ.
- ** Somewhat wasteful of memory: we do not free any of the memory
- ** in the old environ -- don't know if it is being shared elsewhere.
*/
! int install_env(s48_value vec)
{
int i, envsize;
char **newenv;
!
! envsize = S48_VECTOR_LENGTH(vec);
!
! if (envsize >= (current_env->size))
! {
! newenv = Malloc(char*, envsize+1);
! if( !newenv ) return errno;
! Free(current_env->env);
! current_env->env = newenv;
! }
! else newenv = current_env->env;
!
! for( i=0; i<envsize; i++ ) {
! char *s = scheme2c_strcpy(S48_VECTOR_REF(vec,i));
! if (!s) {
! /* Return all the memory and bail out. */
! int e = errno;
! while(--i) Free(newenv[i]);
! Free(newenv);
! return e;
! }
! newenv[i] = s;
! }
!
! newenv[i] = NULL;
! environ = newenv;
! return 0;
! }
!
! int create_env(s48_value vec, s48_value * envvec_addr)
! {
! int i, envsize;
! char **newenv;
! struct envvec* thread_env;
envsize = S48_VECTOR_LENGTH(vec);
newenv = Malloc(char*, envsize+1);
! if( !newenv ) return errno;
! thread_env = Malloc (struct envvec, 4); // TODO: why 4 ??
! if( !thread_env ) {
! Free (newenv);
! return errno;
! }
!
! thread_env->env = newenv;
! thread_env->size = envsize + 1;
! thread_env->revealed = 0;
! thread_env->gcable = 0;
for( i=0; i<envsize; i++ ) {
char *s = scheme2c_strcpy(S48_VECTOR_REF(vec,i));
if (!s) {
/* Return all the memory and bail out. */
- int e = errno;
while(--i) Free(newenv[i]);
Free(newenv);
Free(thread_env);
! return e;
}
newenv[i] = s;
--- 504,587 ----
** !current_env || current_env->env == environ
*/
! s48_value current_env = S48_FALSE;
! s48_value align_env(s48_value envvec)
{
! environ = ENVVEC_ENVIRON(envvec);
! current_env = envvec;
! return S48_TRUE;
}
! char** original_environ = 0;
!
! s48_value free_envvec (s48_value envvec)
{
! char** env = ENVVEC_ENVIRON(envvec);
! int i=0;
! if (env == original_environ)
{
return S48_FALSE;
}
! while (env[i] != 0){
! Free(env[i]);
! i++;
! }
! Free(env);
return S48_TRUE;
}
! s48_value make_envvec(char** newenv){
! s48_value thread_env;
!
! thread_env = s48_make_record(envvec_record_type_binding);
!
! S48_RECORD_SET(thread_env, 0, s48_enter_integer((long)newenv));
! s48_call_scheme(S48_SHARED_BINDING_REF(add_envvec_finalizerB_binding),
! 1,
! thread_env);
! return thread_env;
}
s48_value scm_envvec(){
! s48_value thread_env;
! if (current_env == 0){
! thread_env = make_envvec(environ);
! current_env = thread_env;
! }
! else thread_env = current_env;
!
! if (original_environ == 0)
! original_environ = environ;
!
! return s48_cons (char_pp_2_string_list(environ),
! thread_env);
}
/* Load the (Scheme) strings in the (Scheme) vector VEC into environ.
*/
! s48_value create_env(s48_value vec)
{
int i, envsize;
char **newenv;
! s48_value thread_env;
! S48_DECLARE_GC_PROTECT(1);
! S48_GC_PROTECT_1(vec);
envsize = S48_VECTOR_LENGTH(vec);
newenv = Malloc(char*, envsize+1);
! if( !newenv ) s48_raise_out_of_memory_error();
+
for( i=0; i<envsize; i++ ) {
char *s = scheme2c_strcpy(S48_VECTOR_REF(vec,i));
if (!s) {
/* Return all the memory and bail out. */
while(--i) Free(newenv[i]);
Free(newenv);
Free(thread_env);
! s48_raise_out_of_memory_error();
}
newenv[i] = s;
***************
*** 670,700 ****
newenv[envsize] = NULL;
!
! *envvec_addr = s48_enter_integer((long) thread_env);
- return 0;
}
- /* Delete the env var. */
- s48_value delete_env(s48_value name)
- {
- int varlen = S48_STRING_LENGTH (name);
- char * var = s48_extract_string (name);
- char **ptr = environ;
- char **ptr2;
- 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;
- }
-
-
/*****************************************************************************/
--- 589,602 ----
newenv[envsize] = NULL;
!
! thread_env = make_envvec(newenv);
! environ = newenv;
! current_env = thread_env;
!
! S48_GC_UNPROTECT();
! return thread_env;
}
/*****************************************************************************/
***************
*** 766,768 ****
--- 668,679 ----
return s48_enter_string (ret);
+ }
+
+ void s48_init_syscalls2(){
+ S48_GC_PROTECT_GLOBAL(envvec_record_type_binding);
+ S48_GC_PROTECT_GLOBAL(add_envvec_finalizerB_binding);
+ S48_GC_PROTECT_GLOBAL(current_env);
+ envvec_record_type_binding = s48_get_imported_binding("envvec-record-type");
+ add_envvec_finalizerB_binding =
+ s48_get_imported_binding("add-envvec-finalizer!");
}
Index: syscalls1.h
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/syscalls1.h,v
retrieving revision 1.13
retrieving revision 1.14
diff -C2 -r1.13 -r1.14
*** syscalls1.h 2001/01/02 14:43:27 1.13
--- syscalls1.h 2001/08/06 08:33:24 1.14
***************
*** 66,76 ****
s48_value scsh_seteuid(s48_value uid);
! int put_env(const char *s);
! s48_value scm_envvec(void);
! int install_env(s48_value vec);
! s48_value delete_env(s48_value var);
s48_value scm_gethostname(void);
--- 66,76 ----
s48_value scsh_seteuid(s48_value uid);
! s48_value align_env(s48_value pointer_to_struct);
! s48_value free_envvec (s48_value pointer_to_struct);
! s48_value scm_envvec(void);
! s48_value create_env(s48_value vec);
s48_value scm_gethostname(void);
|