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

bc: fix interaction of prop:object-name and prop:procedure

Browse Source 
Document the fact that `prop:object-name` takes precedence for the
`object-name` result, and make printing also use `object-name` instead
of the propcedure's name when they're differet.

Also, repair constructor-style printing of a transparent structure
type that has `prop:object-name`.

Closes #2585
This commit is contained in:
Matthew Flatt 2021-04-29 11:09:41 -06:00
parent 5ae19c56e1
commit 6f1875c384
4 changed files with 78 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
pkgs/racket-doc/scribblings/reference/struct-inspectors.scrbl
View File

@ -175,10 +175,6 @@ only (some) procedures, @tech{structures}, @tech{structure types},
@tech{ports}, @tech{loggers}, and @tech{prompt tags} have names.
See also @secref["infernames"].
The name (if any) of a procedure is always a symbol. The
@racket[procedure-rename] function creates a procedure with a specific
name.
If a @tech{structure}'s type implements the @racket[prop:object-name] property,
and the value of the @racket[prop:object-name] property is an integer, then the
corresponding field of the structure is the name of the structure.
@ -190,6 +186,12 @@ type is an integer), then its name is the implementing procedure's name.
Otherwise, its name matches the name of the @tech{structure type} that it
instantiates.
The name (if any) of a procedure is a symbol, unless the procedure is
also a structure whose type has the @racket[prop:object-name]
property, in which case @racket[prop:object-name] takes precedence.
The @racket[procedure-rename] function creates a procedure with a
specific name.
The name of a @tech{regexp value} is a string or byte string. Passing
the string or byte string to @racket[regexp], @racket[byte-regexp],
@racket[pregexp], or @racket[byte-pregexp] (depending on the kind of

40
pkgs/racket-test-core/tests/racket/print.rktl
View File

@ -826,4 +826,44 @@
(show println writeln displayln)
(show pretty-print pretty-write pretty-display))
;; ----------------------------------------
(let ()
(struct named-procedure (procedure name)
#:property prop:procedure (struct-field-index procedure)
#:property prop:object-name (struct-field-index name))
(define f (named-procedure (lambda (x) x) "string name"))
(test "#<procedure:string name>" format "~s" f)
(test "string name" object-name f)
(define f2 (named-procedure (lambda (x) x) '("string name")))
(test "#<procedure>" format "~s" f2)
(test '("string name") object-name f2)
(define f3 (procedure-rename f 'other-name))
(test "#<procedure:other-name>" format "~a" f3)
(test 'other-name object-name f3))
(let ()
(struct named-procedure (procedure name)
#:property prop:procedure (struct-field-index procedure)
#:property prop:object-name (struct-field-index name)
#:transparent)
(define f (named-procedure (procedure-rename (lambda (x) x) 'inner) "string name"))
(test "(named-procedure #<procedure:inner> \"string name\")" format "~v" f)
(test "string name" object-name f)
(define f2 (named-procedure (procedure-rename (lambda (x) x) 'inner) '("string name")))
(test "(named-procedure #<procedure:inner> '(\"string name\"))" format "~v" f2)
(test '("string name") object-name f2)
(define f3 (procedure-rename f 'other-name))
(test "#<procedure:other-name>" format "~a" f3)
(test 'other-name object-name f3))
;; ----------------------------------------
(report-errs)

5
racket/src/bc/src/fun.c
View File

@ -2446,7 +2446,10 @@ Scheme_Object *scheme_proc_struct_name_source(Scheme_Object *a)
while (SCHEME_CHAPERONE_PROC_STRUCTP(a)) {
if (SCHEME_CHAPERONEP(a))
a = SCHEME_CHAPERONE_VAL(a);
if (scheme_reduced_procedure_struct
if (scheme_object_name_property
&& scheme_struct_type_property_ref(scheme_object_name_property, a)) {
return a;
} else if (scheme_reduced_procedure_struct
&& scheme_is_struct_instance(scheme_reduced_procedure_struct, a)
&& SCHEME_TRUEP(((Scheme_Structure *)a)->slots[2])) {
return a;

36
racket/src/bc/src/print.c
View File

@ -2300,8 +2300,10 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
if (SCHEME_TRUEP(prefab))
notdisplay = to_quoted(obj, pp, notdisplay);
if (notdisplay == 3) {
if (SCHEME_CHAPERONEP(obj))
obj = SCHEME_CHAPERONE_VAL(obj);
vec = scheme_vector_to_list(vec);
vec = scheme_make_pair(scheme_object_name(obj), SCHEME_CDR(vec));
vec = scheme_make_pair(SCHEME_STRUCT_NAME_SYM(obj), SCHEME_CDR(vec));
print_pair(vec, notdisplay, compact, ht, mt, pp, scheme_pair_type, 1, 1);
} else {
if (SCHEME_TRUEP(prefab))
@ -2311,6 +2313,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
closed = 1;
} else {
Scheme_Object *src;
int check_object_name;
if (SCHEME_CHAPERONEP(obj))
obj = SCHEME_CHAPERONE_VAL(obj);
@ -2318,8 +2321,11 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
if (SCHEME_PROC_STRUCTP(obj)) {
/* Name by procedure? */
src = scheme_proc_struct_name_source(obj);
} else
check_object_name = 1;
} else {
src = obj;
check_object_name = 0;
}
if (SAME_OBJ(src, obj)) {
intptr_t l;
@ -2327,8 +2333,17 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
Scheme_Object *name;
print_utf8_string(pp, "#<", 0, 2); /* used to have "struct:" prefix */
if (scheme_reduced_procedure_struct
&& scheme_is_struct_instance(scheme_reduced_procedure_struct, obj)) {
if (check_object_name
&& scheme_object_name_property
&& scheme_struct_type_property_ref(scheme_object_name_property, obj)) {
name = scheme_object_name(obj);
if (SCHEME_PATHP(name)) /* consistency with CS */
name = scheme_path_to_char_string(name);
print_utf8_string(pp, "procedure:", 0, ((SCHEME_SYMBOLP(name) || SCHEME_CHAR_STRINGP(name))
? 10
: 9));
} else if (scheme_reduced_procedure_struct
&& scheme_is_struct_instance(scheme_reduced_procedure_struct, obj)) {
/* Since scheme_proc_struct_name_source() didn't redirect, this one
must have a name. */
print_utf8_string(pp, "procedure:", 0, 10);
@ -2339,10 +2354,15 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
name = SCHEME_STRUCT_NAME_SYM(obj);
}
s = scheme_symbol_val(name);
l = SCHEME_SYM_LEN(name);
print_utf8_string(pp, s, 0, l);
if (SCHEME_SYMBOLP(name)) {
s = scheme_symbol_val(name);
l = SCHEME_SYM_LEN(name);
print_utf8_string(pp, s, 0, l);
} else if (SCHEME_CHAR_STRINGP(name)) {
name = scheme_char_string_to_byte_string(name);
print_utf8_string(pp, SCHEME_BYTE_STR_VAL(name), 0, SCHEME_BYTE_STRLEN_VAL(name));
}
PRINTADDRESS(pp, obj);
print_utf8_string(pp, ">", 0, 1);
} else {