}
}
+DEFINE_PRIMITIVE ("GET-ENVIRONMENT", Prim_get_environment, 0, 0, 0)
+{
+ PRIMITIVE_HEADER (0);
+ LPTCH env_block = GetEnvironmentStrings();
+ if (env_block == 0)
+ PRIMITIVE_RETURN (sharp_f);
+
+ // Variable strings are separated by NULL byte, and the block is
+ // terminated by a NULL byte.
+
+ LPTSTR scan = (LPTSTR) env_block;
+ int n = 0;
+ while ((*scan) != '\0')
+ {
+ n += 1;
+ scan += (lstrlen(scan) + 1);
+ }
+
+ SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, n, true));
+ SCHEME_OBJECT * to = (VECTOR_LOC (v, 0));
+ scan = (LPTSTR) env_block;
+ while ((*scan) != '\0')
+ {
+ (*to++) = (char_pointer_to_string (scan));
+ scan += (lstrlen(scan) + 1);
+ }
+ FreeEnvironmentStrings(env_block);
+ PRIMITIVE_RETURN (v);
+}
+
#define VQRESULT(index, value) \
VECTOR_SET (result, index, (ulong_to_integer (value)))
: (char_pointer_to_string (variable_value)));
}
}
+
+DEFINE_PRIMITIVE ("GET-ENVIRONMENT", Prim_get_environment, 0, 0, 0)
+{
+ PRIMITIVE_HEADER (0);
+ char ** scan = environ;
+ int n = 0;
+ while ((*scan++) != 0)
+ n += 1;
+ SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, n, true));
+ SCHEME_OBJECT * to = (VECTOR_LOC (v, 0));
+ scan = environ;
+ while ((*scan) != 0)
+ (*to++) = (char_pointer_to_string (*scan++));
+ PRIMITIVE_RETURN (v);
+}
\f
#define HOSTNAMESIZE 1024
(define key-weak-eqv-hash-table-type)
(define datum-weak-eqv-hash-table-type)
(define non-pointer-hash-table-type)
+(define string-ci-hash-table-type)
(define string-hash-table-type)
(define strong-eq-hash-table-type)
(define strong-eqv-hash-table-type)
(make eqv-hash-mod eqv? #t hash-table-entry-type:datum-weak))
(set! non-pointer-hash-table-type ;Open-coded
(open-type! eq-hash-mod eq? #f hash-table-entry-type:strong))
+ (set! string-ci-hash-table-type
+ (make string-ci-hash string-ci=? #t hash-table-entry-type:strong))
(set! string-hash-table-type
(make string-hash string=? #t hash-table-entry-type:strong))
(set! strong-eq-hash-table-type ;Open-coded
(define make-key-weak-eqv-hash-table)
(define make-datum-weak-eqv-hash-table)
(define make-non-pointer-hash-table)
+(define make-string-ci-hash-table)
(define make-string-hash-table)
(define make-strong-eq-hash-table)
(define make-strong-eqv-hash-table)
(init make-key-weak-eqv-hash-table key-weak-eqv-hash-table-type)
(init make-datum-weak-eqv-hash-table datum-weak-eqv-hash-table-type)
(init make-non-pointer-hash-table non-pointer-hash-table-type)
+ (init make-string-ci-hash-table string-ci-hash-table-type)
(init make-string-hash-table string-hash-table-type)
(init make-strong-eq-hash-table strong-eq-hash-table-type)
(init make-strong-eqv-hash-table strong-eqv-hash-table-type))
((runtime stream) initialize-conditions!)
((runtime regular-sexpression) initialize-conditions!)
;; System dependent stuff
- ((runtime os-primitives) initialize-system-primitives!)
+ (runtime os-primitives)
;; Floating-point environment -- needed by threads.
(runtime floating-point-environment)
((runtime thread) initialize-high!)
(error "Wrong value type in registry entry:"
name))
value))))))
-\f
-(define get-environment-variable)
-(define set-environment-variable!)
-(define set-environment-variable-default!)
-(define delete-environment-variable!)
-(define reset-environment-variables!)
-(let ((environment-variables '())
- (environment-defaults '()))
-
- ;; Kludge: since getenv returns #f for unbound,
- ;; that can also be the marker for a deleted variable
- (define-integrable *variable-deleted* #f)
-
- (define (env-error proc var)
- (error "Variable must be a string:" var proc))
-
- (define (default-variable! var val)
- (if (and (not (assoc var environment-variables))
- (not ((ucode-primitive get-environment-variable 1)
- (string-for-primitive var))))
- (set! environment-variables
- (cons (cons var (if (procedure? val) (val) val))
- environment-variables)))
- unspecific)
-
- (set! get-environment-variable
- (lambda (variable)
- (if (not (string? variable))
- (env-error 'get-environment-variable variable))
- (let ((variable (string-upcase variable)))
- (cond ((assoc variable environment-variables)
- => cdr)
- (else
- ((ucode-primitive get-environment-variable 1)
- (string-for-primitive variable)))))))
-
- (set! set-environment-variable!
- (lambda (variable value)
- (if (not (string? variable))
- (env-error 'set-environment-variable! variable))
- (let ((variable (string-upcase variable)))
- (cond ((assoc variable environment-variables)
- => (lambda (pair) (set-cdr! pair value)))
- (else
- (set! environment-variables
- (cons (cons variable value) environment-variables)))))
- unspecific))
-
- (set! delete-environment-variable!
- (lambda (variable)
- (if (not (string? variable))
- (env-error 'delete-environment-variable! variable))
- (set-environment-variable! variable *variable-deleted*)))
-
- (set! reset-environment-variables!
- (lambda ()
- (set! environment-variables '())
- (for-each (lambda (def) (default-variable! (car def) (cdr def)))
- environment-defaults)))
-
- (set! set-environment-variable-default!
- (lambda (var val)
- (if (not (string? var))
- (env-error 'set-environment-variable-default! var))
- (let ((var (string-upcase var)))
- (cond ((assoc var environment-defaults)
- => (lambda (pair) (set-cdr! pair val)))
- (else
- (set! environment-defaults
- (cons (cons var val) environment-defaults))))
- (default-variable! var val))))
-
- )
+
+(define (os/make-env-cache)
+ (make-string-ci-hash-table))
\f
(define current-user-name)
(define current-home-directory)
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Operating-system primitives
+;;; package: (runtime os-primitives)
+
+(declare (usual-integrations))
+\f
+(define (get-environment-variable name)
+ (guarantee string? name 'get-environment-variable)
+ (hash-table-ref/default %env-cache name #f))
+
+(define (get-environment-variables)
+ (hash-table-fold %env-cache
+ (lambda (name value result)
+ (if value
+ (cons (cons name value) result)
+ result))
+ '()))
+
+(define (set-environment-variable! name value)
+ (guarantee string? name 'set-environment-variable!)
+ (if value
+ (guarantee string? value 'set-environment-variable!))
+ (hash-table-set! %env-cache name value))
+
+(define (delete-environment-variable! name)
+ (guarantee string? name 'delete-environment-variable!)
+ (hash-table-delete! %env-cache name))
+
+(define (reset-environment-variables!)
+ (hash-table-clear! %env-cache)
+ (vector-for-each (lambda (s)
+ (let ((i (string-find-next-char s #\=)))
+ (if i
+ (hash-table-set! %env-cache
+ (string-head s i)
+ (string-tail s (fix:+ i 1))))))
+ ((ucode-primitive get-environment 0))))
+
+(define-deferred %env-cache
+ (os/make-env-cache))
+
+(add-boot-init!
+ (lambda ()
+ (reset-environment-variables!)
+ (add-event-receiver! event:after-restart reset-environment-variables!)))
\ No newline at end of file
(define-package (runtime os-primitives)
(parent (runtime))
+ (files "os-primitives")
(export ()
copy-file
current-home-directory
file-time->global-decoded-time
file-time->local-decoded-time
file-time->universal-time
+ get-environment-variables ;R7RS
get-environment-variable ;R7RS
init-file-specifier->pathname
os/exec-path
make-key-weak-eq-hash-table
make-key-weak-eqv-hash-table
make-non-pointer-hash-table
+ make-string-ci-hash-table
make-string-hash-table
make-strong-eq-hash-table
make-strong-eqv-hash-table
(or access-time (file-access-time-direct filename))
(or modification-time (file-modification-time-direct filename)))))
\f
-;;;; Environment variables
-
-(define environment-variables)
-
-(define (get-environment-variable name)
- (guarantee string? name 'get-environment-variable)
- (let ((value (hash-table-ref/default environment-variables name 'none)))
- (if (eq? value 'none)
- (let ((value
- ((ucode-primitive get-environment-variable 1)
- (string-for-primitive name))))
- (hash-table-set! environment-variables name value)
- value)
- value)))
-
-(define (set-environment-variable! name value)
- (guarantee string? name 'set-environment-variable!)
- (if value
- (guarantee string? value 'set-environment-variable!))
- (hash-table-set! environment-variables name value))
-
-(define (delete-environment-variable! name)
- (guarantee string? name 'delete-environment-variable!)
- (hash-table-delete! environment-variables name))
-
-(define (reset-environment-variables!)
- (hash-table-clear! environment-variables))
-
-(define (initialize-system-primitives!)
- (set! environment-variables (make-string-hash-table))
- (add-event-receiver! event:after-restart reset-environment-variables!))
-\f
;;;; MIME types
(define (os/suffix-mime-type suffix)
(set-thread-timer-interval! ti-outside)
(set! ti-outside)
unspecific))))
+
+(define (os/make-env-cache)
+ (make-string-hash-table))
\f
(define (file-line-ending pathname)
;; This works because the line translation is harmless when not
projects / mit-scheme.git / commitdiff