diff --git a/collects/scribblings/gui/text-class.scrbl b/collects/scribblings/gui/text-class.scrbl index 587d1afca1..48c191c282 100644 --- a/collects/scribblings/gui/text-class.scrbl +++ b/collects/scribblings/gui/text-class.scrbl @@ -1611,7 +1611,7 @@ See @|ateoldiscuss| for a discussion of @scheme[at-eol?]. [whole-line? any/c #f]) void?]{ -Returns the @techlink{location} of a given @techlink{position}. +Returns the @techlink{location} of a given @techlink{position}. See also @method[text% position-locations]. @boxisfillnull[(scheme x) @elem{the x-@techlink{location} of the @techlink{position} @scheme[start] in editor coordinates} ] @@ -1634,6 +1634,22 @@ maximum bottom @techlink{location} for the whole line is returned in @scheme[y]. } +@defmethod[(position-locations [start nonnegative-exact-integer?] + [top-x (or/c (box/c real?) false/c) #f] + [top-y (or/c (box/c real?) false/c) #f] + [bottom-x (or/c (box/c real?) false/c) #f] + [bottom-y (or/c (box/c real?) false/c) #f] + [at-eol? any/c #f] + [whole-line? any/c #f]) + void?]{ + +Like @method[text% position-location], but returns both the ``top'' +and ``bottom'' results at once. + +@|OVD| @|FCA| + +} + @defmethod[(position-paragraph [start nonnegative-exact-integer?] [at-eol? any/c #f]) nonnegative-exact-integer?]{ diff --git a/collects/scribblings/reference/struct.scrbl b/collects/scribblings/reference/struct.scrbl index 9105c07995..6c5375bda5 100644 --- a/collects/scribblings/reference/struct.scrbl +++ b/collects/scribblings/reference/struct.scrbl @@ -119,12 +119,13 @@ are initialized with @scheme[auto-v]. The total field count (including The @scheme[props] argument is a list of pairs, where the @scheme[car] of each pair is a structure type property descriptor, and the -@scheme[cdr] is an arbitrary value. Each property in @scheme[props] -must be distinct, including properties that are automatically added by -properties that are directly included in @scheme[props]. See -@secref["structprops"] for more information about properties. When -@scheme[inspector] is @scheme['prefab], then @scheme[props] must be -@scheme[null]. +@scheme[cdr] is an arbitrary value. A property can be specified +multiple times in in @scheme[props] (including properties that are +automatically added by properties that are directly included in +@scheme[props]) only if the associated values are @scheme[eq?], +otherwise the @exnraise[exn:fail:contract]. See @secref["structprops"] +for more information about properties. When @scheme[inspector] is +@scheme['prefab], then @scheme[props] must be @scheme[null]. The @scheme[inspector] argument normally controls access to reflective information about the structure type and its instances; see diff --git a/collects/tests/mzscheme/struct.ss b/collects/tests/mzscheme/struct.ss index f2fb73a171..dd2b96d6a8 100644 --- a/collects/tests/mzscheme/struct.ss +++ b/collects/tests/mzscheme/struct.ss @@ -108,9 +108,9 @@ (make-struct-type 'bb type 0 0 #f (list (cons prop:p 12))) (make-struct-type 'bb btype 0 0 #f (list (cons prop:p3 12))) - (err/rt-test (make-struct-type 'bb type 0 0 #f (list (cons prop:p 12) (cons prop:p 12))) exn:application:mismatch?) - (err/rt-test (make-struct-type 'bb btype 0 0 #f (list (cons prop:p3 12) (cons prop:p3 12))) exn:application:mismatch?) - (err/rt-test (make-struct-type 'bb #f 0 0 #f (list (cons prop:p 12) (cons prop:p2 12) (cons prop:p 12))) exn:application:mismatch?) + (err/rt-test (make-struct-type 'bb type 0 0 #f (list (cons prop:p 12) (cons prop:p 13))) exn:application:mismatch?) + (err/rt-test (make-struct-type 'bb btype 0 0 #f (list (cons prop:p3 12) (cons prop:p3 13))) exn:application:mismatch?) + (err/rt-test (make-struct-type 'bb #f 0 0 #f (list (cons prop:p 12) (cons prop:p2 12) (cons prop:p 13))) exn:application:mismatch?) (err/rt-test (make-struct-type 'bb type 0 0 #f (list (cons (let-values ([(p p? p-v) (make-struct-type-property 'p (lambda (v s) ;; this guard will fail! @@ -643,9 +643,19 @@ (let ([try (lambda (base prop:procedure) (err/rt-test (make-struct-type '? base 1 0 #f (list (cons prop:procedure 0) - (cons prop:procedure 0)) + (cons prop:procedure 1)) #f #f '(0))) - (err/rt-test (make-struct-type '? base 1 0 #f (list (cons prop:procedure 0)) #f 0)) + ;; Ok to re-set to same value: + (test #t list? (call-with-values + (lambda () (make-struct-type '? base 1 0 #f (list (cons prop:procedure 0) + (cons prop:procedure 0)) + #f #f '(0))) + list)) + (err/rt-test (make-struct-type '? base 1 0 #f (list (cons prop:procedure 0)) #f 1)) + (test #t list? (call-with-values + (lambda () (make-struct-type '? base 1 0 #f (list (cons prop:procedure 0)) #f 0)) + list)) + (let-values ([(prop:s s? s-get) (make-struct-type-property 's #f (list (cons prop:procedure (lambda (v) (add1 v)))))]) (define-struct a (x y) #:super base #:property prop:s 0) @@ -655,7 +665,19 @@ (err/rt-test (make-struct-type-property 't #f 10)) (err/rt-test (make-struct-type-property 't #f (list (cons prop:s 10)))) - (err/rt-test (make-struct-type-property 't #f (list (cons prop:s void) (cons prop:procedure void)))) + + ;; Allow multiple inheritances of a property at this stage, because we can't in general + ;; tell whether the results will be eq? + (test #t list? + (call-with-values + (lambda () + (make-struct-type-property 't #f (list (cons prop:s void) (cons prop:s values)))) + list)) + (test #t list? + (call-with-values + (lambda () + (make-struct-type-property 't #f (list (cons prop:s void) (cons prop:procedure values)))) + list)) (let-values ([(prop:t t? t-get) (make-struct-type-property 't #f (list (cons prop:s (lambda (v) (add1 v)))))] diff --git a/src/mred/wxme/wx_media.cxx b/src/mred/wxme/wx_media.cxx index 939f238739..de07d671ad 100644 --- a/src/mred/wxme/wx_media.cxx +++ b/src/mred/wxme/wx_media.cxx @@ -3645,8 +3645,10 @@ long wxMediaEdit::PositionLine(long start, Bool eol) return line->GetLine(); } -void wxMediaEdit::PositionLocation(long start, double *x, double *y, - Bool top, Bool eol, Bool wholeLine) +void wxMediaEdit::PositionLocations(long start, + double *tx, double *ty, + double *bx, double *by, + Bool eol, Bool wholeLine) { double horiz, h, descent, space, topy; int align; @@ -3662,44 +3664,44 @@ void wxMediaEdit::PositionLocation(long start, double *x, double *y, if (start <= 0) { if (wholeLine) { - if (x) { + if (tx || bx) { double xl; xl = firstLine->GetLeftLocation(maxWidth); - *x = xl; + if (tx) *tx = xl; + if (bx) *bx = xl; } - if (y) { + if (ty || by) { double yl; yl = firstLine->GetLocation(); - *y = yl; - if (!top) - (*y) += firstLine->h; + if (ty) *ty = yl; + if (by) *by = yl + firstLine->h; } return; } line = firstLine; } else if (start >= len) { if (extraLine && !eol) { - if (y) - *y = totalHeight - (top ? extraLineH : 0); - if (x) - *x = 0; + if (ty) *ty = totalHeight - extraLineH; + if (by) *by = totalHeight; + if (tx) *tx = 0; + if (bx) *bx = 0; return; } line = lastLine; if (wholeLine || !len) { - if (x) { + if (tx || bx) { double xl; xl = line->GetRightLocation(maxWidth); - *x = xl; + if (tx) *tx = xl; + if (bx) *bx = xl; } - if (y) { + if (ty || by) { double yl; yl = lastLine->GetLocation(); - *y = yl; - if (!top) - (*y) += lastLine->h; + if (ty) *ty = yl; + if (by) *by = yl + lastLine->h; } return; } @@ -3707,14 +3709,13 @@ void wxMediaEdit::PositionLocation(long start, double *x, double *y, line = lineRoot->FindLine(PositionLine(start, eol)); if (wholeLine) { - if (y) { + if (by || ty) { double yl; yl = line->GetLocation(); - *y = yl; - if (!top) - (*y) += line->h; + if (ty) *ty = yl; + if (by) *by = yl + line->h; } - if (!x) + if (!tx && !bx) return; } } @@ -3765,7 +3766,7 @@ void wxMediaEdit::PositionLocation(long start, double *x, double *y, } - if (x) { + if (tx || bx) { double xv; if (start && !dc) { @@ -3778,10 +3779,11 @@ void wxMediaEdit::PositionLocation(long start, double *x, double *y, } xv = horiz + (start ? snip->PartialOffset(dc, horiz, topy, start) : 0); - *x = xv; + if (tx) *tx = xv; + if (bx) *bx = xv; } - if (!wholeLine && y) { + if (!wholeLine && (ty || by)) { if (!dc) { dc = admin->GetDC(); if (!dc) { @@ -3793,14 +3795,22 @@ void wxMediaEdit::PositionLocation(long start, double *x, double *y, h = descent = space = 0.0; snip->GetExtent(dc, horiz, topy, NULL, &h, &descent, &space); align = snip->style->GetAlignment(); - if (align == wxALIGN_BOTTOM) - *y = topy + line->bottombase + descent - (top ? h : 0); - else if (align == wxALIGN_TOP) - *y = topy + line->topbase - space + (top ? 0 : h); - else { + if (align == wxALIGN_BOTTOM) { + double yl; + yl = topy + line->bottombase + descent; + if (ty) *ty = yl - h; + if (by) *by = yl; + } else if (align == wxALIGN_TOP) { + double yl; + yl = topy + line->topbase - space; + if (ty) *ty = yl; + if (by) *by = yl + h; + } else { + double yl; h = (h - descent - space) / 2; - *y = topy + ((line->topbase + line->bottombase) / 2) - + (top ? (- h - space) : (h + descent)); + yl = topy + ((line->topbase + line->bottombase) / 2); + if (ty) *ty = yl - h - space; + if (by) *by = yl + h + descent; } } @@ -3808,6 +3818,15 @@ void wxMediaEdit::PositionLocation(long start, double *x, double *y, flowLocked = fl; } +void wxMediaEdit::PositionLocation(long start, double *x, double *y, + Bool top, Bool eol, Bool wholeLine) +{ + PositionLocations(start, + top ? x : NULL, top ? y : NULL, + top ? NULL : x, top ? NULL : y, + eol, wholeLine); +} + double wxMediaEdit::LineLocation(long i, Bool top) { wxMediaLine *line; diff --git a/src/mred/wxme/wx_media.h b/src/mred/wxme/wx_media.h index 48a249fef7..dc15e60cf1 100644 --- a/src/mred/wxme/wx_media.h +++ b/src/mred/wxme/wx_media.h @@ -272,6 +272,10 @@ class wxMediaEdit : public wxMediaBuffer double *x = NULL, double *y = NULL, Bool front = TRUE, Bool eol = FALSE, Bool wholeLine = FALSE); + void PositionLocations(long start, + double *tx, double *ty, + double *bx, double *by, + Bool eol = FALSE, Bool wholeLine = FALSE); double LineLocation(long line, Bool top = TRUE); /* Get first/last caret position in a line: */ diff --git a/src/mred/wxs/wxs_mede.cxx b/src/mred/wxs/wxs_mede.cxx index 2bd9116454..028ad6a481 100644 --- a/src/mred/wxs/wxs_mede.cxx +++ b/src/mred/wxs/wxs_mede.cxx @@ -5607,6 +5607,71 @@ static Scheme_Object *os_wxMediaEditLineLocation(int n, Scheme_Object *p[]) return WITH_REMEMBERED_STACK(scheme_make_double(r)); } +static Scheme_Object *os_wxMediaEditPositionLocations(int n, Scheme_Object *p[]) +{ + WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p) + REMEMBER_VAR_STACK(); + objscheme_check_valid(os_wxMediaEdit_class, "position-locations in text%", n, p); + nnlong x0; + double _x1; + double* x1 = &_x1; + double _x2; + double* x2 = &_x2; + double _x3; + double* x3 = &_x3; + double _x4; + double* x4 = &_x4; + Bool x5; + Bool x6; + Scheme_Object *sbox_tmp; + + SETUP_VAR_STACK_REMEMBERED(1); + VAR_STACK_PUSH(0, p); + + + x0 = WITH_VAR_STACK(objscheme_unbundle_nonnegative_integer(p[POFFSET+0], "position-locations in text%")); + if (XC_SCHEME_NULLP(p[POFFSET+1])) + x1 = NULL; + else + *x1 = (sbox_tmp = WITH_VAR_STACK(objscheme_nullable_unbox(p[POFFSET+1], "position-locations in text%")), WITH_VAR_STACK(objscheme_unbundle_double(sbox_tmp, "position-locations in text%"", extracting boxed argument"))); + if (XC_SCHEME_NULLP(p[POFFSET+2])) + x2 = NULL; + else + *x2 = (sbox_tmp = WITH_VAR_STACK(objscheme_nullable_unbox(p[POFFSET+2], "position-locations in text%")), WITH_VAR_STACK(objscheme_unbundle_double(sbox_tmp, "position-locations in text%"", extracting boxed argument"))); + if (XC_SCHEME_NULLP(p[POFFSET+3])) + x3 = NULL; + else + *x3 = (sbox_tmp = WITH_VAR_STACK(objscheme_nullable_unbox(p[POFFSET+3], "position-locations in text%")), WITH_VAR_STACK(objscheme_unbundle_double(sbox_tmp, "position-locations in text%"", extracting boxed argument"))); + if (XC_SCHEME_NULLP(p[POFFSET+4])) + x4 = NULL; + else + *x4 = (sbox_tmp = WITH_VAR_STACK(objscheme_nullable_unbox(p[POFFSET+4], "position-locations in text%")), WITH_VAR_STACK(objscheme_unbundle_double(sbox_tmp, "position-locations in text%"", extracting boxed argument"))); + if (n > (POFFSET+5)) { + x5 = WITH_VAR_STACK(objscheme_unbundle_bool(p[POFFSET+5], "position-locations in text%")); + } else + x5 = FALSE; + if (n > (POFFSET+6)) { + x6 = WITH_VAR_STACK(objscheme_unbundle_bool(p[POFFSET+6], "position-locations in text%")); + } else + x6 = FALSE; + + + WITH_VAR_STACK(((wxMediaEdit *)((Scheme_Class_Object *)p[0])->primdata)->PositionLocations(x0, x1, x2, x3, x4, x5, x6)); + + + if (n > (POFFSET+1) && !XC_SCHEME_NULLP(p[POFFSET+1])) + { Scheme_Object *sbv_ = WITH_VAR_STACK(scheme_make_double(_x1)); WITH_VAR_STACK(objscheme_set_box(p[POFFSET+1], sbv_)); } + if (n > (POFFSET+2) && !XC_SCHEME_NULLP(p[POFFSET+2])) + { Scheme_Object *sbv_ = WITH_VAR_STACK(scheme_make_double(_x2)); WITH_VAR_STACK(objscheme_set_box(p[POFFSET+2], sbv_)); } + if (n > (POFFSET+3) && !XC_SCHEME_NULLP(p[POFFSET+3])) + { Scheme_Object *sbv_ = WITH_VAR_STACK(scheme_make_double(_x3)); WITH_VAR_STACK(objscheme_set_box(p[POFFSET+3], sbv_)); } + if (n > (POFFSET+4) && !XC_SCHEME_NULLP(p[POFFSET+4])) + { Scheme_Object *sbv_ = WITH_VAR_STACK(scheme_make_double(_x4)); WITH_VAR_STACK(objscheme_set_box(p[POFFSET+4], sbv_)); } + + READY_TO_RETURN; + return scheme_void; +} + static Scheme_Object *os_wxMediaEditPositionLocation(int n, Scheme_Object *p[]) { WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p) @@ -8569,7 +8634,7 @@ void objscheme_setup_wxMediaEdit(Scheme_Env *env) wxREGGLOB(os_wxMediaEdit_class); - os_wxMediaEdit_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "text%", "editor%", (Scheme_Method_Prim *)os_wxMediaEdit_ConstructScheme, 150)); + os_wxMediaEdit_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "text%", "editor%", (Scheme_Method_Prim *)os_wxMediaEdit_ConstructScheme, 151)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "call-clickback" " method", (Scheme_Method_Prim *)os_wxMediaEditCallClickback, 2, 2)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "remove-clickback" " method", (Scheme_Method_Prim *)os_wxMediaEditRemoveClickback, 2, 2)); @@ -8636,6 +8701,7 @@ void objscheme_setup_wxMediaEdit(Scheme_Env *env) WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "line-end-position" " method", (Scheme_Method_Prim *)os_wxMediaEditLineEndPosition, 1, 2)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "line-start-position" " method", (Scheme_Method_Prim *)os_wxMediaEditLineStartPosition, 1, 2)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "line-location" " method", (Scheme_Method_Prim *)os_wxMediaEditLineLocation, 1, 2)); + WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "position-locations" " method", (Scheme_Method_Prim *)os_wxMediaEditPositionLocations, 5, 7)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "position-location" " method", (Scheme_Method_Prim *)os_wxMediaEditPositionLocation, 1, 6)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "position-line" " method", (Scheme_Method_Prim *)os_wxMediaEditPositionLine, 1, 2)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "set-between-threshold" " method", (Scheme_Method_Prim *)os_wxMediaEditSetBetweenThreshold, 1, 1)); diff --git a/src/mred/wxs/wxs_mede.xc b/src/mred/wxs/wxs_mede.xc index be3b782983..b5415f59fe 100644 --- a/src/mred/wxs/wxs_mede.xc +++ b/src/mred/wxs/wxs_mede.xc @@ -152,6 +152,7 @@ @ "position-line" : long PositionLine(nnlong,bool=FALSE); @ "position-location" : void PositionLocation(nnlong,double?=NULL,double?=NULL,bool=TRUE,bool=FALSE,bool=FALSE); +@ "position-locations" : void PositionLocations(nnlong,double?,double?,double?,double?,bool=FALSE,bool=FALSE); @ "line-location" : double LineLocation(nnlong,bool=TRUE); @ "line-start-position" : long LineStartPosition(nnlong,bool=TRUE); diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c index 75d2bd8ef7..b737c4f050 100644 --- a/src/mzscheme/src/struct.c +++ b/src/mzscheme/src/struct.c @@ -788,26 +788,6 @@ static Scheme_Object *make_struct_type_property(int argc, Scheme_Object *argv[]) "list of pairs of structure type properties and procedures (arity 1)", 2, argc, argv); } - - if (SCHEME_PAIRP(supers) && SCHEME_PAIRP(SCHEME_CDR(supers))) { - /* check for duplicates */ - Scheme_Hash_Table *ht; - Scheme_Object *stack = supers; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - while (SCHEME_PAIRP(stack)) { - v = SCHEME_CAR(stack); - if (SCHEME_PAIRP(v)) v = SCHEME_CAR(v); /* appended item */ - p = (Scheme_Struct_Property *)v; - stack = SCHEME_CDR(stack); - if (scheme_hash_get(ht, (Scheme_Object *)p)) { - scheme_arg_mismatch("make-struct-type-property", - "super structure type property appears twice in given hierarchy: ", - (Scheme_Object *)p); - } - scheme_hash_set(ht, (Scheme_Object *)p, scheme_true); - stack = scheme_append(p->supers, stack); - } - } } } @@ -914,7 +894,7 @@ static Scheme_Object *guard_property(Scheme_Object *prop, Scheme_Object *v, Sche } } - return v; + return orig_v; } else { /* Normal guard handling: */ if (p->guard) { @@ -2928,9 +2908,10 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base scheme_null)); if (props) { - int num_props, i, proc_prop_set = 0; + int num_props, i; + Scheme_Object *proc_prop_set = NULL; Scheme_Hash_Table *can_override; - Scheme_Object *l, *a, *prop, *propv; + Scheme_Object *l, *a, *prop, *propv, *oldv; can_override = scheme_make_hash_table(SCHEME_hash_ptr); @@ -2963,24 +2944,29 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base a = SCHEME_CAR(l); prop = SCHEME_CAR(a); - if (scheme_hash_get(ht, prop)) { - /* Property is already in the superstruct_type */ - if (!scheme_hash_get(can_override, prop)) - break; - /* otherwise we override */ - scheme_hash_set(can_override, prop, NULL); - } else if (SAME_OBJ(prop, proc_property)) { - if (proc_prop_set) - break; - } - propv = guard_property(prop, SCHEME_CDR(a), struct_type); + if (SAME_OBJ(prop, proc_property)) { + if (proc_prop_set && !SAME_OBJ(proc_prop_set, propv)) + break; + } else { + oldv = scheme_hash_get(ht, prop); + if (oldv) { + /* Property is already in the superstruct_type */ + if (!scheme_hash_get(can_override, prop)) { + if (!SAME_OBJ(oldv, propv)) + break; + } + /* otherwise we override */ + scheme_hash_set(can_override, prop, NULL); + } + } + l = SCHEME_CDR(l); l = append_super_props((Scheme_Struct_Property *)prop, propv, l); if (SAME_OBJ(prop, proc_property)) - proc_prop_set = 1; + proc_prop_set = propv; else scheme_hash_set(ht, prop, propv); } @@ -3008,9 +2994,11 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base prop = SCHEME_CAR(a); + propv = guard_property(prop, SCHEME_CDR(a), struct_type); + /* Check whether already in table: */ if (SAME_OBJ(prop, proc_property)) { - if (proc_prop_set) + if (proc_prop_set && !SAME_OBJ(proc_prop_set, propv)) break; j = 0; } else { @@ -3020,21 +3008,21 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base } if (j < num_props) { /* already there */ - if (!scheme_hash_get(can_override, prop)) - break; + if (!scheme_hash_get(can_override, prop)) { + if (!SAME_OBJ(propv, SCHEME_CDR(pa[j]))) + break; + } /* overriding it: */ scheme_hash_set(can_override, prop, NULL); } else num_props++; } - propv = guard_property(prop, SCHEME_CDR(a), struct_type); - l = SCHEME_CDR(l); l = append_super_props((Scheme_Struct_Property *)prop, propv, l); if (SAME_OBJ(prop, proc_property)) - proc_prop_set = 1; + proc_prop_set = propv; else { a = scheme_make_pair(prop, propv); pa[j] = a;