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

avoid generating unnecessary struct-accessor and -mutator names

Browse Source 
svn: r14566
This commit is contained in:
Matthew Flatt 2009-04-20 13:14:40 +00:00
parent da4742700b
commit f51f8c8b7f
4 changed files with 42 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/scheme/private/class-internal.ss
View File

@ -1327,9 +1327,9 @@
rename-super-temp ... rename-super-extra-temp ...
rename-inner-temp ... rename-inner-extra-temp ...
method-accessor ...) ; for a local call that needs a dynamic lookup
(let ([local-field-accessor (make-struct-field-accessor local-accessor local-field-pos)]
(let ([local-field-accessor (make-struct-field-accessor local-accessor local-field-pos #f)]
...
[local-field-mutator (make-struct-field-mutator local-mutator local-field-pos)]
[local-field-mutator (make-struct-field-mutator local-mutator local-field-pos #f)]
...)
(syntax-parameterize
([this-param (make-this-map (quote-syntax this-id)
@ -2102,9 +2102,9 @@
;; Use public field names to name the accessors and mutators
(let-values ([(inh-accessors inh-mutators)
(values
(map (lambda (id) (make-class-field-accessor super id))
(map (lambda (id) (make-class-field-accessor super id #f))
inherit-field-names)
(map (lambda (id) (make-class-field-mutator super id))
(map (lambda (id) (make-class-field-mutator super id #f))
inherit-field-names))])
;; -- Reset field table to register accessor and mutator info --
;; There are more accessors and mutators than public fields...
@ -2959,7 +2959,7 @@
(loop (wrapper-object-wrapped loop-object)))))))
(define (class-field-X who which cwhich class name)
(define (class-field-X who which cwhich class name proc-field-name)
(unless (class? class)
(raise-type-error who "class" class))
(unless (symbol? name)
@ -2969,17 +2969,17 @@
(obj-error who "no such field: ~a~a"
name
(for-class (class-name class)))))])
(which (cwhich (car p)) (cdr p) name)))
(which (cwhich (car p)) (cdr p) proc-field-name)))
(define (make-class-field-accessor class name)
(define (make-class-field-accessor class name keep-name?)
(class-field-X 'class-field-accessor
make-struct-field-accessor class-field-ref
class name))
class name (and keep-name? name)))
(define (make-class-field-mutator class name)
(define (make-class-field-mutator class name keep-name?)
(class-field-X 'class-field-mutator
make-struct-field-mutator class-field-set!
class name))
class name (and keep-name? name)))
(define-struct generic (name applicable))
@ -3060,7 +3060,7 @@
(define-syntaxes (class-field-accessor class-field-mutator generic/form)
(let ([mk
(lambda (make targets)
(lambda (make targets extra-args)
(lambda (stx)
(syntax-case stx ()
[(_ class-expr name)
@ -3072,8 +3072,9 @@
stx
name))
(with-syntax ([name (localize name)]
[make make])
(syntax/loc stx (make class-expr `name))))]
[make make]
[extra-args extra-args])
(syntax/loc stx (make class-expr `name . extra-args))))]
[(_ class-expr)
(raise-syntax-error
#f
@ -3081,9 +3082,9 @@
targets)
stx)])))])
(values
(mk (quote-syntax make-class-field-accessor) "class")
(mk (quote-syntax make-class-field-mutator) "class")
(mk (quote-syntax make-generic/proc) "class or interface"))))
(mk (quote-syntax make-class-field-accessor) "class" (list #'#t))
(mk (quote-syntax make-class-field-mutator) "class" (list #'#t))
(mk (quote-syntax make-generic/proc) "class or interface" null))))
(define-syntax (class-field-accessor-traced stx)
(syntax-case stx ()

10
collects/scribblings/reference/struct.scrbl
View File

@ -237,7 +237,8 @@ The result of @scheme[make-struct-type] is five values:
@defproc[(make-struct-field-accessor [accessor-proc struct-accessot-procedure?]
[field-pos exact-nonnegative-integer?]
[field-name symbol?])
[field-name (or/c symbol? #f)
(symbol->string (format "field~a" field-pos))])
procedure?]{
Returns a field accessor that is equivalent to @scheme[(lambda (s)
@ -245,13 +246,14 @@ Returns a field accessor that is equivalent to @scheme[(lambda (s)
an @tech{accessor} returned by @scheme[make-struct-type]. The name of the
resulting procedure for debugging purposes is derived from
@scheme[field-name] and the name of @scheme[accessor-proc]'s
structure type.
structure type if @scheme[field-name] is a symbol.
For examples, see @scheme[make-struct-type].}
@defproc[(make-struct-field-mutator [mutator-proc struct-mutator-procedure?]
[field-pos exact-nonnegative-integer?]
[field-name symbol?])
[field-name (or/c symbol? #f)
(symbol->string (format "field~a" field-pos))])
procedure?]{
Returns a field mutator that is equivalent to @scheme[(lambda (s v)
@ -259,7 +261,7 @@ Returns a field mutator that is equivalent to @scheme[(lambda (s v)
a @tech{mutator} returned by @scheme[make-struct-type]. The name of the
resulting procedure for debugging purposes is derived from
@scheme[field-name] and the name of @scheme[mutator-proc]'s
structure type.
structure type if @scheme[field-name] is a symbol.
For examples, see @scheme[make-struct-type].}

5
src/mzscheme/src/jit.c
View File

@ -2863,12 +2863,13 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
if (reorder_ok) {
if (no_call < 2) {
generate(rator, jitter, 0, 0, JIT_V1); /* sync'd below */
generate(rator, jitter, 0, 0, JIT_V1); /* sync'd below, or not */
}
CHECK_LIMIT();
}
mz_rs_sync();
if (!no_call)
mz_rs_sync();
END_JIT_DATA(20);

22
src/mzscheme/src/struct.c
View File

@ -2164,19 +2164,29 @@ static Scheme_Object *make_struct_field_xxor(const char *who, int getter,
pos = parse_pos(who, i, argv, argc);
if (argc > 2) {
if (!SCHEME_SYMBOLP(argv[2])) {
scheme_wrong_type(who, "symbol", 2, argc, argv);
return NULL;
if (SCHEME_FALSEP(argv[2])) {
fieldstr = NULL;
fieldstrlen = 0;
} else {
if (!SCHEME_SYMBOLP(argv[2])) {
scheme_wrong_type(who, "symbol or #f", 2, argc, argv);
return NULL;
}
fieldstr = scheme_symbol_val(argv[2]);
fieldstrlen = SCHEME_SYM_LEN(argv[2]);
}
fieldstr = scheme_symbol_val(argv[2]);
fieldstrlen = SCHEME_SYM_LEN(argv[2]);
} else {
sprintf(digitbuf, "field%d", (int)SCHEME_INT_VAL(argv[1]));
fieldstr = digitbuf;
fieldstrlen = strlen(fieldstr);
}
if (getter) {
if (!fieldstr) {
if (getter)
name = "accessor";
else
name = "mutator";
} else if (getter) {
name = (char *)GET_NAME((char *)i->struct_type->name, -1,
fieldstr, fieldstrlen, 0);
} else {