Add export and read-only attributes to variables
* geesh/environment.scm (<variable>): New record type. (make-environment): Initialize variables as records. (var-ref): Extract value from record. (set-var!): Inject value into record and throw an error if variable is read-only. (set-var-export!): New public function. (set-var-read-only!): New public function. (environment->environ): Only include exported variables.
This commit is contained in:
parent
d4bb8ae438
commit
e784aaa658
|
@ -27,6 +27,8 @@
|
||||||
var-ref
|
var-ref
|
||||||
var-ref*
|
var-ref*
|
||||||
set-var!
|
set-var!
|
||||||
|
set-var-export!
|
||||||
|
set-var-read-only!
|
||||||
delete-environment-vars!
|
delete-environment-vars!
|
||||||
environment->environ
|
environment->environ
|
||||||
environ->alist
|
environ->alist
|
||||||
|
@ -47,6 +49,13 @@
|
||||||
;;;
|
;;;
|
||||||
;;; Code:
|
;;; Code:
|
||||||
|
|
||||||
|
(define-record-type <variable>
|
||||||
|
(make-variable value export? read-only?)
|
||||||
|
variable?
|
||||||
|
(value variable-value)
|
||||||
|
(export? variable-exported?)
|
||||||
|
(read-only? variable-read-only?))
|
||||||
|
|
||||||
(define-record-type <environment>
|
(define-record-type <environment>
|
||||||
(%make-environment vars functions arguments status
|
(%make-environment vars functions arguments status
|
||||||
break-prompt continue-prompt)
|
break-prompt continue-prompt)
|
||||||
|
@ -62,7 +71,8 @@
|
||||||
;; In order to insure that each pair in the 'vars' alist is mutable,
|
;; In order to insure that each pair in the 'vars' alist is mutable,
|
||||||
;; we copy each one into a new list.
|
;; we copy each one into a new list.
|
||||||
(%make-environment (map (match-lambda
|
(%make-environment (map (match-lambda
|
||||||
((key . val) (cons key val)))
|
((key . val)
|
||||||
|
(cons key (make-variable val #t #f))))
|
||||||
vars)
|
vars)
|
||||||
'()
|
'()
|
||||||
arguments
|
arguments
|
||||||
|
@ -73,7 +83,9 @@
|
||||||
(define (var-ref env name)
|
(define (var-ref env name)
|
||||||
"Get the value of the variable @var{name} in @var{env}. If
|
"Get the value of the variable @var{name} in @var{env}. If
|
||||||
@var{name} is unset, return @code{#f}."
|
@var{name} is unset, return @code{#f}."
|
||||||
(assoc-ref (environment-vars env) name))
|
(and=> (assoc-ref (environment-vars env) name)
|
||||||
|
(match-lambda
|
||||||
|
(($ <variable> value _ _) value))))
|
||||||
|
|
||||||
(define (var-ref* env name)
|
(define (var-ref* env name)
|
||||||
"Get the value of the variable @var{name} in @var{env}. If
|
"Get the value of the variable @var{name} in @var{env}. If
|
||||||
|
@ -82,8 +94,39 @@
|
||||||
|
|
||||||
(define (set-var! env name val)
|
(define (set-var! env name val)
|
||||||
"Set the variable @var{name} to @var{val} in @var{env}."
|
"Set the variable @var{name} to @var{val} in @var{env}."
|
||||||
(set-environment-vars! env (acons name val
|
(match (assoc-ref (environment-vars env) name)
|
||||||
|
(#f (set-environment-vars!
|
||||||
|
env (acons name (make-variable val #f #f)
|
||||||
(environment-vars env))))
|
(environment-vars env))))
|
||||||
|
(($ <variable> _ export? read-only?)
|
||||||
|
(when read-only? (throw 'variable-assignment-error))
|
||||||
|
(set-environment-vars!
|
||||||
|
env (acons name (make-variable val export? #f)
|
||||||
|
(environment-vars env))))))
|
||||||
|
|
||||||
|
(define* (set-var-export! env name #:optional val)
|
||||||
|
"Set the export attribute for variable @var{name} in @var{env}. If
|
||||||
|
@var{val} is specified, update the variable's value as well."
|
||||||
|
(match (assoc-ref (environment-vars env) name)
|
||||||
|
(#f (set-environment-vars! env (acons name (make-variable val #t #f)
|
||||||
|
(environment-vars env))))
|
||||||
|
(($ <variable> value export? read-only?)
|
||||||
|
(when (and read-only? val) (throw 'variable-assignment-error))
|
||||||
|
(set-environment-vars!
|
||||||
|
env (acons name (make-variable (or val value) #t read-only?)
|
||||||
|
(environment-vars env))))))
|
||||||
|
|
||||||
|
(define* (set-var-read-only! env name #:optional val)
|
||||||
|
"Set the read-only attribute for variable @var{name} in @var{env}.
|
||||||
|
If @var{val} is specified, update the variable's value as well."
|
||||||
|
(match (assoc-ref (environment-vars env) name)
|
||||||
|
(#f (set-environment-vars! env (acons name (make-variable val #f #t)
|
||||||
|
(environment-vars env))))
|
||||||
|
(($ <variable> value export? read-only?)
|
||||||
|
(when (and read-only? val) (throw 'variable-assignment-error))
|
||||||
|
(set-environment-vars!
|
||||||
|
env (acons name (make-variable (or val value) export? #t)
|
||||||
|
(environment-vars env))))))
|
||||||
|
|
||||||
(define (delete-environment-vars! env names)
|
(define (delete-environment-vars! env names)
|
||||||
(set-environment-vars! env (remove (match-lambda
|
(set-environment-vars! env (remove (match-lambda
|
||||||
|
@ -95,7 +138,11 @@
|
||||||
@code{\"name=value\"} strings (an @dfn{environ}). If @var{bindings}
|
@code{\"name=value\"} strings (an @dfn{environ}). If @var{bindings}
|
||||||
is set to a list of pairs of strings, those name-value pairs take
|
is set to a list of pairs of strings, those name-value pairs take
|
||||||
precedence over the ones in @var{env}."
|
precedence over the ones in @var{env}."
|
||||||
(let loop ((env-vars (append bindings (environment-vars env)))
|
(let ((exported (filter-map (match-lambda
|
||||||
|
((name . ($ <variable> val export? _))
|
||||||
|
(and export? val `(,name . ,val))))
|
||||||
|
(environment-vars env))))
|
||||||
|
(let loop ((env-vars (append bindings exported))
|
||||||
(acc '())
|
(acc '())
|
||||||
(seen '()))
|
(seen '()))
|
||||||
(match env-vars
|
(match env-vars
|
||||||
|
@ -105,7 +152,7 @@ precedence over the ones in @var{env}."
|
||||||
(loop rest
|
(loop rest
|
||||||
(cons (string-append name "=" value) acc)
|
(cons (string-append name "=" value) acc)
|
||||||
(cons name seen))))
|
(cons name seen))))
|
||||||
(() acc))))
|
(() acc)))))
|
||||||
|
|
||||||
(define (environ->alist environ)
|
(define (environ->alist environ)
|
||||||
(define (string-split-1 str char_pred)
|
(define (string-split-1 str char_pred)
|
||||||
|
|
Loading…
Reference in New Issue