From aff3916c934e573cd5434f4e7201931df451a2f6 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 13 May 2018 19:43:57 -0700 Subject: [PATCH] Implement get-environment-variables for R7RS. --- src/microcode/prntenv.c | 30 ++++++++++++++ src/microcode/pruxenv.c | 15 +++++++ src/runtime/hash-table.scm | 5 +++ src/runtime/make.scm | 2 +- src/runtime/ntprm.scm | 76 ++--------------------------------- src/runtime/os-primitives.scm | 70 ++++++++++++++++++++++++++++++++ src/runtime/runtime.pkg | 3 ++ src/runtime/unxprm.scm | 35 ++-------------- 8 files changed, 130 insertions(+), 106 deletions(-) create mode 100644 src/runtime/os-primitives.scm diff --git a/src/microcode/prntenv.c b/src/microcode/prntenv.c index fe44b68c8..b9c8ec95a 100644 --- a/src/microcode/prntenv.c +++ b/src/microcode/prntenv.c @@ -63,6 +63,36 @@ The result is either a string (the variable's value),\n\ } } +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))) diff --git a/src/microcode/pruxenv.c b/src/microcode/pruxenv.c index f47b80fd2..ca6432aa1 100644 --- a/src/microcode/pruxenv.c +++ b/src/microcode/pruxenv.c @@ -164,6 +164,21 @@ The result is either a string (the variable's value),\n\ : (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); +} #define HOSTNAMESIZE 1024 diff --git a/src/runtime/hash-table.scm b/src/runtime/hash-table.scm index aa9f1dcd2..bd5f8b54c 100644 --- a/src/runtime/hash-table.scm +++ b/src/runtime/hash-table.scm @@ -1202,6 +1202,7 @@ USA. (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) @@ -1242,6 +1243,8 @@ USA. (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 @@ -1258,6 +1261,7 @@ USA. (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) @@ -1277,6 +1281,7 @@ USA. (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)) diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 6b6a5cdc4..b7044064e 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -494,7 +494,7 @@ USA. ((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!) diff --git a/src/runtime/ntprm.scm b/src/runtime/ntprm.scm index a26b60343..a7c1f718a 100644 --- a/src/runtime/ntprm.scm +++ b/src/runtime/ntprm.scm @@ -126,79 +126,9 @@ USA. (error "Wrong value type in registry entry:" name)) value)))))) - -(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)) (define current-user-name) (define current-home-directory) diff --git a/src/runtime/os-primitives.scm b/src/runtime/os-primitives.scm new file mode 100644 index 000000000..510dad4af --- /dev/null +++ b/src/runtime/os-primitives.scm @@ -0,0 +1,70 @@ +#| -*-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)) + +(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 diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 60afc8418..987d93416 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -880,6 +880,7 @@ USA. (define-package (runtime os-primitives) (parent (runtime)) + (files "os-primitives") (export () copy-file current-home-directory @@ -910,6 +911,7 @@ USA. 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 @@ -2492,6 +2494,7 @@ USA. 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 diff --git a/src/runtime/unxprm.scm b/src/runtime/unxprm.scm index 4844b0b7d..d673d3285 100644 --- a/src/runtime/unxprm.scm +++ b/src/runtime/unxprm.scm @@ -158,38 +158,6 @@ USA. (or access-time (file-access-time-direct filename)) (or modification-time (file-modification-time-direct filename))))) -;;;; 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!)) - ;;;; MIME types (define (os/suffix-mime-type suffix) @@ -338,6 +306,9 @@ USA. (set-thread-timer-interval! ti-outside) (set! ti-outside) unspecific)))) + +(define (os/make-env-cache) + (make-string-hash-table)) (define (file-line-ending pathname) ;; This works because the line translation is harmless when not -- 2.25.1