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

add `identifier-bindig-symbol'; fix free-id-table for renames

Browse Source 
The implement of `free-id-table' uses `identifier-binding'
to decide on a symbolic name as a key for each identifier,
but `identifier-binding' doesn't provide enough information
for local and top-level bindings. The new `identifier-binding-symbol'
function provides that information.

Closes PR 13911
This commit is contained in:
Matthew Flatt 2013-07-10 06:43:07 -06:00
parent 46db1d2d64
commit fe98a80c22
9 changed files with 894 additions and 833 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
pkgs/racket-pkgs/racket-doc/scribblings/reference/stx-comp.scrbl
View File

@ -218,4 +218,19 @@ Same as @racket[(identifier-binding id-stx (sub1 (syntax-local-phase-level)))].}
Same as @racket[(identifier-binding id-stx #f)].}
@defproc[(identifier-binding-symbol [id-stx syntax?]
[phase-level (or/c exact-integer? #f)
(syntax-local-phase-level)])
symbol?]{
Like @racket[identifier-binding], but produces a symbol that
corresponds to the binding. The symbol result is the same for any
identifiers that are @racket[free-identifier=?].
When @racket[identifier-binding] would produce a list, then the second
element of that list is the result that
@racket[identifier-binding-symbol] produces.}
@close-eval[stx-eval]

7
pkgs/racket-pkgs/racket-test/tests/racket/id-table-test.rktl
View File

@ -328,4 +328,11 @@
))
(let ()
(define-syntax name 'dummy)
(define-syntax alias (make-rename-transformer #'name))
(define table (make-free-id-table))
(free-id-table-set! table #'alias 0)
(test 0 free-id-table-ref table #'name))
(report-errs)

15
pkgs/racket-pkgs/racket-test/tests/racket/stx.rktl
View File

@ -614,6 +614,21 @@
(test eval 'expand-to-top-form (eval (expand-syntax-to-top-form #'eval)))
(test #t syntax? (expand-syntax-to-top-form (datum->syntax #f 'eval))))
(let ()
(define-syntax name 'dummy)
(define-syntax alias (make-rename-transformer #'name))
(test (identifier-binding-symbol #'name)
identifier-binding-symbol #'alias))
(require (only-in racket/base [add1 increment-by-one]))
(test (identifier-binding-symbol #'add1)
identifier-binding-symbol #'increment-by-one)
(define top-level-add1 add1)
(define-syntax top-level-increment-by-one (make-rename-transformer #'top-level-add1))
(test (identifier-binding-symbol #'top-level-add1)
identifier-binding-symbol #'top-level-increment-by-one)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; origin tracking
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

3
racket/lib/collects/racket/HISTORY.txt
View File

@ -1,3 +1,6 @@
Version 5.3.900.6
Added identifier-binding-symbol
Version 5.3.900.5
Added call-with-default-reading-parameterization
racket/file: added call-with-atomic-output-file

5
racket/lib/collects/syntax/private/id-table.rkt
View File

@ -402,10 +402,7 @@ Notes (FIXME?):
bound-identifier=?)
(define (free-identifier->symbol id phase)
(let ([binding (identifier-binding id phase)])
(if (pair? binding)
(cadr binding)
(syntax-e id))))
(identifier-binding-symbol id phase))
(make-code free-id-table
free-identifier->symbol

1636
racket/src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

2
racket/src/racket/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1108
#define EXPECTED_PRIM_COUNT 1109
#define EXPECTED_UNSAFE_COUNT 100
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "5.3.900.5"
#define MZSCHEME_VERSION "5.3.900.6"
#define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 3
#define MZSCHEME_VERSION_Z 900
#define MZSCHEME_VERSION_W 5
#define MZSCHEME_VERSION_W 6
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

38
racket/src/racket/src/syntax.c
View File

@ -88,6 +88,7 @@ static Scheme_Object *module_binding(int argc, Scheme_Object **argv);
static Scheme_Object *module_trans_binding(int argc, Scheme_Object **argv);
static Scheme_Object *module_templ_binding(int argc, Scheme_Object **argv);
static Scheme_Object *module_label_binding(int argc, Scheme_Object **argv);
static Scheme_Object *module_binding_symbol(int argc, Scheme_Object **argv);
static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv);
static Scheme_Object *identifier_prune_to_module(int argc, Scheme_Object **argv);
static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv);
@ -446,6 +447,8 @@ void scheme_init_stx(Scheme_Env *env)
GLOBAL_IMMED_PRIM("identifier-prune-lexical-context" , identifier_prune , 1, 2, env);
GLOBAL_IMMED_PRIM("identifier-prune-to-source-module", identifier_prune_to_module, 1, 1, env);
GLOBAL_IMMED_PRIM("identifier-binding-symbol" , module_binding_symbol , 1, 2, env);
GLOBAL_NONCM_PRIM("syntax-source-module" , syntax_src_module , 1, 2, env);
GLOBAL_FOLDING_PRIM("syntax-tainted?", syntax_tainted_p, 1, 1, 1, env);
@ -2042,6 +2045,7 @@ static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn,
Scheme_Object *rename_insp;
if (scheme_hash_get(free_id_recur, id)) {
*_sealed = 1;
return id;
}
scheme_hash_set(free_id_recur, id, id);
@ -4041,7 +4045,7 @@ static Scheme_Object *resolve_env(Scheme_Object *a, Scheme_Object *orig_phase,
EXPLAIN(fprintf(stderr, "%d search result: %p\n", depth, rename));
if (rename) {
if (mrn->sealed < STX_SEAL_BOUND)
if ((mrn->sealed < STX_SEAL_BOUND) && is_in_module)
mresult_depends_unsealed = 1;
if (mrn->kind == mzMOD_RENAME_MARKED) {
@ -4159,7 +4163,7 @@ static Scheme_Object *resolve_env(Scheme_Object *a, Scheme_Object *orig_phase,
get_names[6] = (mrn->insp ? mrn->insp : mresult_insp);
EXPLAIN(fprintf(stderr, "%d mresult_insp %p %p\n", depth, mresult_insp, mrn->insp));
} else {
if (mrn->sealed < STX_SEAL_ALL)
if ((mrn->sealed < STX_SEAL_ALL) && is_in_module)
mresult_depends_unsealed = 1;
mresult = scheme_false;
mresult_skipped = -1;
@ -6314,6 +6318,12 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *stx_datum,
free_id_recur);
release_recur_table(free_id_recur);
if (!sealed) {
free_id_recur = make_recur_table();
extract_module_free_id_binding((Scheme_Object *)mrn,
mrn->free_id_renames->keys[i],
mrn->free_id_renames->vals[i],
&sealed,
free_id_recur);
scheme_signal_error("write: unsealed local-definition or module context"
" found in syntax object");
}
@ -8560,7 +8570,8 @@ static Scheme_Object *module_label_eq(int argc, Scheme_Object **argv)
return do_module_eq("free-label-identifier=?", MZ_LABEL_PHASE, argc, argv);
}
static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **argv, Scheme_Object *dphase)
static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **argv,
Scheme_Object *dphase, int get_symbol)
{
Scheme_Object *a, *m, *nom_mod, *nom_a, *phase;
Scheme_Object *src_phase_index, *mod_phase, *nominal_src_phase;
@ -8601,6 +8612,14 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar
NULL,
NULL);
if (get_symbol) {
if ((!m || SAME_OBJ(m, scheme_undefined)) && nom_a)
a = nom_a;
if (SCHEME_STXP(a))
a = SCHEME_STX_VAL(a);
return a;
}
if (!m)
return scheme_false;
else if (SAME_OBJ(m, scheme_undefined)) {
@ -8616,22 +8635,27 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar
static Scheme_Object *module_binding(int argc, Scheme_Object **argv)
{
return do_module_binding("identifier-binding", argc, argv, scheme_make_integer(0));
return do_module_binding("identifier-binding", argc, argv, scheme_make_integer(0), 0);
}
static Scheme_Object *module_trans_binding(int argc, Scheme_Object **argv)
{
return do_module_binding("identifier-transformer-binding", argc, argv, scheme_make_integer(1));
return do_module_binding("identifier-transformer-binding", argc, argv, scheme_make_integer(1), 0);
}
static Scheme_Object *module_templ_binding(int argc, Scheme_Object **argv)
{
return do_module_binding("identifier-template-binding", argc, argv, scheme_make_integer(-1));
return do_module_binding("identifier-template-binding", argc, argv, scheme_make_integer(-1), 0);
}
static Scheme_Object *module_label_binding(int argc, Scheme_Object **argv)
{
return do_module_binding("identifier-label-binding", argc, argv, scheme_false);
return do_module_binding("identifier-label-binding", argc, argv, scheme_false, 0);
}
static Scheme_Object *module_binding_symbol(int argc, Scheme_Object **argv)
{
return do_module_binding("identifier-binding-symbol", argc, argv, scheme_make_integer(0), 1);
}
static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv)