suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add name argument to make-parameter

Browse Source
This commit is contained in:
Matthew Flatt 2019-09-05 06:55:22 -06:00
parent cccaf4e46e
commit 91d702c6fe
6 changed files with 70 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
pkgs/racket-doc/scribblings/reference/parameters.scrbl
View File

@ -31,18 +31,26 @@ value originally associated with a parameter through
reachable, even if the parameter is mutated.
@defproc[(make-parameter [v any/c]
[guard (or/c (any/c . -> . any) #f) #f])
[guard (or/c (any/c . -> . any) #f) #f]
[name symbol? 'parameter-procedure])
parameter?]{
Returns a new parameter procedure. The value of the parameter is
initialized to @racket[v] in all threads. If @racket[guard] is
supplied, it is used as the parameter's guard procedure. A guard
initialized to @racket[v] in all threads.
If @racket[guard] is not @racket[#f],
it is used as the parameter's guard procedure. A guard
procedure takes one argument. Whenever the parameter procedure is
applied to an argument, the argument is passed on to the guard
procedure. The result returned by the guard procedure is used as the
new parameter value. A guard procedure can raise an exception to
reject a change to the parameter's value. The @racket[guard] is not
applied to the initial @racket[v].}
applied to the initial @racket[v].
The @racket[name] argument is used as the parameter procedure's name
as reported by @racket[object-name].
@history[#:changed "7.4.0.6" @elem{Added the @racket[name] argument.}]}
@defform[(parameterize ([parameter-expr value-expr] ...)
body ...+)

5
pkgs/racket-test-core/tests/racket/param.rktl
View File

@ -166,9 +166,12 @@
(test v cd)
(test v current-directory))))
(arity-test make-parameter 1 2)
(test 'this-one object-name (make-parameter 7 #f 'this-one))
(arity-test make-parameter 1 3)
(err/rt-test (make-parameter 0 zero-arg-proc))
(err/rt-test (make-parameter 0 two-arg-proc))
(err/rt-test (make-parameter 0 #f 7))
(define-struct bad-test (value exn?))

75
racket/src/cs/rumble/parameter.ss
View File

@ -24,7 +24,7 @@
[v (if guard
(|#%app| guard v)
v)])
(loop (intmap-set ht p (make-thread-cell v #t))
(loop (intmap-set ht (parameter-key p) (make-thread-cell v #t))
(cddr args)))]))]
[(parameter? (car args))
(raise-arguments-error 'extend-parameterization
@ -53,7 +53,8 @@
#f))
(define-record-type parameter-data
(fields guard))
(fields guard
(mutable name))) ; not actually mutable, but ensures fresh allocations
(define-record-type derived-parameter-data
(parent parameter-data)
@ -69,6 +70,9 @@
(define (parameter-guard p)
(parameter-data-guard (wrapper-procedure-data p)))
(define (parameter-key p)
(wrapper-procedure-data p))
(define (derived-parameter? v)
(and (wrapper-procedure? v)
(derived-parameter-data? (wrapper-procedure-data v))))
@ -78,28 +82,27 @@
(define/who make-parameter
(case-lambda
[(v) (make-parameter v #f)]
[(v guard)
[(v) (make-parameter v #f 'parameter-procedure)]
[(v guard) (make-parameter v guard 'parameter-procedure)]
[(v guard name)
(check who (procedure-arity-includes/c 1) :or-false guard)
(let ([default-c (make-thread-cell v #t)])
(letrec ([self
(make-wrapper-procedure
(|#%name|
parameter-procedure
(case-lambda
[()
(let ([c (or (parameter-cell self)
default-c)])
(thread-cell-ref c))]
[(v)
(let ([c (or (parameter-cell self)
default-c)])
(thread-cell-set! c (if guard
(guard v)
v)))]))
3
(make-parameter-data guard))])
self))]))
(check who symbol? name)
(let ([default-c (make-thread-cell v #t)]
[data (make-parameter-data guard name)])
(make-arity-wrapper-procedure
(case-lambda
[()
(let ([c (or (parameter-cell data)
default-c)])
(thread-cell-ref c))]
[(v)
(let ([c (or (parameter-cell data)
default-c)])
(thread-cell-set! c (if guard
(guard v)
v)))])
3
data))]))
(define/who (make-derived-parameter p guard wrap)
(check who authentic-parameter?
@ -107,16 +110,16 @@
p)
(check who (procedure-arity-includes/c 1) guard)
(check who (procedure-arity-includes/c 1) wrap)
(make-wrapper-procedure (let ([self p])
(|#%name|
parameter-procedure
(case-lambda
[(v) (self (guard v))]
[() (wrap (self))])))
3
(make-derived-parameter-data
guard
p)))
(make-arity-wrapper-procedure
(case-lambda
[(v) (p (guard v))]
[() (wrap (p))])
3
(make-derived-parameter-data
guard
(parameter-data-name
(wrapper-procedure-data p))
p)))
(define/who (parameter-procedure=? a b)
(check who parameter? a)
@ -133,10 +136,12 @@
(make-parameter root-inspector
(lambda (v)
(check who inspector? v)
v)))
v)
'current-inspector))
(define/who current-code-inspector
(make-parameter root-inspector
(lambda (v)
(check who inspector? v)
v)))
v)
'current-code-inspector))

2
racket/src/cs/rumble/procedure.ss
View File

@ -502,7 +502,7 @@
[(#%box? name) (#%unbox name)]
[(#%vector? name) (or (#%vector-ref name 0)
(object-name (#%vector-ref name 1)))]
[(parameter-data? name) 'parameter-procedure]
[(parameter-data? name) (parameter-data-name name)]
[else name])))
;; ----------------------------------------

15
racket/src/racket/src/thread.c
View File

@ -570,7 +570,7 @@ void scheme_init_thread(Scheme_Startup_Env *env)
ADD_PARAMETER("current-thread-group", current_thread_set, MZCONFIG_THREAD_SET, env);
ADD_PRIM_W_ARITY("parameter?" , parameter_p , 1, 1, env);
ADD_PRIM_W_ARITY("make-parameter" , make_parameter , 1, 2, env);
ADD_PRIM_W_ARITY("make-parameter" , make_parameter , 1, 3, env);
ADD_PRIM_W_ARITY("make-derived-parameter", make_derived_parameter, 3, 3, env);
ADD_PRIM_W_ARITY("parameter-procedure=?" , parameter_procedure_eq, 2, 2, env);
ADD_PRIM_W_ARITY("parameterization?" , parameterization_p , 1, 1, env);
@ -7842,11 +7842,18 @@ static Scheme_Object *make_parameter(int argc, Scheme_Object **argv)
Scheme_Object *p, *cell, *a[1];
ParamData *data;
void *k;
const char *name;
k = scheme_make_pair(scheme_true, scheme_false); /* generates a key */
if (argc > 1)
scheme_check_proc_arity("make-parameter", 1, 1, argc, argv);
scheme_check_proc_arity2("make-parameter", 1, 1, argc, argv, 1);
if (argc > 2) {
if (!SCHEME_SYMBOLP(argv[2]))
scheme_wrong_contract("make-parameter", "parameter?", 2, argc, argv);
name = scheme_symbol_val(argv[2]);
} else
name = "parameter-procedure";
data = MALLOC_ONE_RT(ParamData);
#ifdef MZTAG_REQUIRED
@ -7855,11 +7862,11 @@ static Scheme_Object *make_parameter(int argc, Scheme_Object **argv)
data->key = (Scheme_Object *)k;
cell = scheme_make_thread_cell(argv[0], 1);
data->defcell = cell;
data->guard = ((argc > 1) ? argv[1] : NULL);
data->guard = (((argc > 1) && SCHEME_TRUEP(argv[1])) ? argv[1] : NULL);
a[0] = (Scheme_Object *)data;
p = scheme_make_prim_closure_w_arity(do_param_fast, 1, a,
"parameter-procedure", 0, 1);
name, 0, 1);
((Scheme_Primitive_Proc *)p)->pp.flags |= SCHEME_PRIM_TYPE_PARAMETER;
return p;

8
racket/src/schemify/parameter-result.rkt
View File

@ -6,18 +6,14 @@
(define (parameter-result? v prim-knowns knowns mutated)
(and (wrap-pair? v)
(let ([v (wrap-cdr v)])
(and (wrap-pair? v)
(let ([v (wrap-cdr v)])
(or (wrap-null? v)
(and (wrap-pair? v)
(wrap-null? (wrap-cdr v)))))))
(let ([u-rator (unwrap (wrap-car v))])
(or (eq? u-rator 'make-parameter)
(eq? u-rator 'derived-parameter)
(eq? u-rator 'make-pthread-parameter)
(and (symbol? u-rator)
(let ([k (hash-ref knowns u-rator #f)])
(and (known-copy? k)
(let ([id (known-copy-id k)])
(or (eq? 'make-parameter id)
(eq? 'make-derived-parameter id)
(eq? 'make-pthread-parameter id))))))))))