From 91d702c6fe14ce3b142a39f3675ce2ad270567c8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 5 Sep 2019 06:55:22 -0600 Subject: [PATCH] add name argument to `make-parameter` --- .../scribblings/reference/parameters.scrbl | 16 +++- pkgs/racket-test-core/tests/racket/param.rktl | 5 +- racket/src/cs/rumble/parameter.ss | 75 ++++++++++--------- racket/src/cs/rumble/procedure.ss | 2 +- racket/src/racket/src/thread.c | 15 +++- racket/src/schemify/parameter-result.rkt | 8 +- 6 files changed, 70 insertions(+), 51 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/parameters.scrbl b/pkgs/racket-doc/scribblings/reference/parameters.scrbl index 631ee66e56..bd046053e9 100644 --- a/pkgs/racket-doc/scribblings/reference/parameters.scrbl +++ b/pkgs/racket-doc/scribblings/reference/parameters.scrbl @@ -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 ...+) diff --git a/pkgs/racket-test-core/tests/racket/param.rktl b/pkgs/racket-test-core/tests/racket/param.rktl index 79626332d9..259d450bef 100644 --- a/pkgs/racket-test-core/tests/racket/param.rktl +++ b/pkgs/racket-test-core/tests/racket/param.rktl @@ -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?)) diff --git a/racket/src/cs/rumble/parameter.ss b/racket/src/cs/rumble/parameter.ss index 63125a076b..e9a8a3dd30 100644 --- a/racket/src/cs/rumble/parameter.ss +++ b/racket/src/cs/rumble/parameter.ss @@ -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)) diff --git a/racket/src/cs/rumble/procedure.ss b/racket/src/cs/rumble/procedure.ss index 424122c2ca..c25fe01bb1 100644 --- a/racket/src/cs/rumble/procedure.ss +++ b/racket/src/cs/rumble/procedure.ss @@ -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]))) ;; ---------------------------------------- diff --git a/racket/src/racket/src/thread.c b/racket/src/racket/src/thread.c index 068ae787c8..0bff5b2b7f 100644 --- a/racket/src/racket/src/thread.c +++ b/racket/src/racket/src/thread.c @@ -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; diff --git a/racket/src/schemify/parameter-result.rkt b/racket/src/schemify/parameter-result.rkt index 249f7af960..c43270aa3e 100644 --- a/racket/src/schemify/parameter-result.rkt +++ b/racket/src/schemify/parameter-result.rkt @@ -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))))))))))